Hey everybody,
I have been thinking about how a small, beginner-friendly web framework could look like. Basically I’ve been searching for something similar to python’s flask, but haskelly of course. All existing solutions didn’t really speak to me, so I experimented a bit. I’d love to hear your thoughts on the design space and the specific approach that I took.
My dream is something as approachable as Scotty and as safe as Servant. That’s obviously not going to work, but I feel like there is an interesting space in between those two, using some type-level programming internally but not exposing that much to the user.
I tried Yesod but I didn’t understand what was going on with all the template haskell and stuff. (Not saying it’s bad, just that it didn’t really speak to me.) Mu looks great, but I would prefer something that didn’t confront me with grpc and protobuf right in the tutorial. But if I’m honest, I also just wanted to write something myself
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
module Main (main) where
import Network.HTTP.Types.Status qualified as HttpStatus
import Network.Wai (Application, Request, Response)
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
----------------------------------------------------------------------
-------------------- Supporting definitions --------------------------
-- | The path part of a url. Wai doesn't have a type for this.
type Path = [Text]
-- | We need an heterogeneous list for the captured arguments
data HList (ts :: [Type]) where
HNil :: HList '[]
HCons :: t -> HList ts -> HList (t ': ts)
----------------------------------------------------------------------
------- Matchers: Match Paths and extract captured fragments ---------
-- | Matches path fragments. Keeping it simple for now.
--
-- Maybe this can be refactored to be a list of Matchers instead of
-- the Matcher being a linked list itself, but the captures type is
-- convenient this way.
data Matcher (captures :: [Type]) where
MatchEnd :: Matcher '[]
MatchLiteral :: Text -> Matcher cs -> Matcher cs
MatchCapture :: Matcher cs -> Matcher (Text ': cs)
-- | Run a Matcher against a Path and return it's captures if it
-- matched
runMatcher' :: Matcher captures -> Path -> Maybe (HList captures)
runMatcher' matcher path =
case matcher of
MatchEnd -> if null path then Just HNil else Nothing
MatchLiteral expectedFragment matchRest ->
case path of
fragment : rest
| fragment == expectedFragment ->
runMatcher' matchRest rest
_ -> Nothing
MatchCapture matchRest ->
case path of
fragment : rest ->
HCons fragment <$> runMatcher' matchRest rest
[] ->
Nothing
----------------------------------------------------------------------
----- Routes: Create an instance of a user-defined route type --------
-- | An instance of this means that a routeConstructor is a function
-- with arguments captures, returning a route.
class RouteFor routeConstructor captures route where
instantiateRoute :: routeConstructor -> captures -> route
-- | Everything can be a zero-argument route constructor
instance RouteFor x (HList '[]) x where
instantiateRoute x HNil = x
-- | Given that routeConstructor is a route constructor for route with
-- arguments args, (arg -> routeConstructor) is a route constructor
-- for route with arguments (arg : args)
instance
RouteFor routeConstructor (HList args) route =>
RouteFor (arg -> routeConstructor) (HList (arg ': args)) route
where
instantiateRoute route (HCons arg args) =
instantiateRoute (route arg) args
-- | Run a Matcher against a Path and apply a compatible route
-- constructor if it matches
runMatcher ::
forall (captures :: [Type]) route routeConstructor.
RouteFor routeConstructor (HList captures) route =>
Matcher captures ->
Path ->
routeConstructor ->
Maybe route
runMatcher matcher path routeConstructor =
case runMatcher' matcher path of
Nothing -> Nothing
Just captures ->
Just $ instantiateRoute routeConstructor captures
----------------------------------------------------------------------
-------- RouteSpecs: Allow users to specify their routes -------------
-- | RouteSpec' encapsulates a Matcher with a compatible route
-- Constructor. The name isn't great.
data RouteSpec' route where
RouteSpec' ::
forall route routeConstructor (captures :: [Type]).
RouteFor routeConstructor (HList captures) route =>
Matcher captures ->
routeConstructor ->
RouteSpec' route
-- | A list of route matchers with route constructors. This represents
-- the endpoints of a web service
newtype RouteSpec route = RouteSpec [RouteSpec' route]
deriving newtype (Semigroup)
-- | Take a single matcher and it's route constructor and try it
-- against a path. If it matches, return the constructed route.
runRouteSpec' :: RouteSpec' route -> Path -> Maybe route
runRouteSpec' (RouteSpec' matcher routeConstructor) path =
runMatcher matcher path routeConstructor
-- | Try a whole RouteSpec against a path and return the first
-- matching route.
runRouteSpec :: RouteSpec route -> Path -> Maybe route
runRouteSpec (RouteSpec routes) path =
case mapMaybe (`runRouteSpec'` path) routes of
[] -> Nothing
[route] -> Just route
route : _moreRoute ->
-- This should be logged or something maybe
Just route
----------------------------------------------------------------------
------------------- Wai Application Interface ------------------------
-- | Create a Wai Application from a RouteSpec and a handler function
routedApplication ::
RouteSpec route -> (route -> Request -> IO Response) -> Application
routedApplication routes handler request respond =
case runRouteSpec routes (Wai.pathInfo request) of
Nothing ->
respond $
Wai.responseLBS
HttpStatus.notFound404
[("Content-Type", "text/plain")]
"nope D:"
Just route ->
respond =<< handler route request
----------------------------------------------------------------------
------------------ This is what a user would do ----------------------
data MyRoutes
= Index
| Hi Text
myRouteSpec :: RouteSpec MyRoutes
myRouteSpec =
RouteSpec
[ MatchEnd `RouteSpec'` Index,
MatchLiteral "hi" (MatchCapture MatchEnd) `RouteSpec'` Hi
]
handle :: MyRoutes -> Request -> IO Response
handle route _request =
pure $ case route of
Index ->
Wai.responseLBS
HttpStatus.ok200
[("Content-Type", "text/plain")]
"yo"
Hi name ->
Wai.responseLBS
HttpStatus.ok200
[("Content-Type", "text/plain")]
$ "hello " <> encodeUtf8 name <> "!"
main :: IO ()
main = Warp.run 8000 $ routedApplication myRouteSpec handle
Edit: Fixed syntax highlighting