The microframework design space

Show and Tell
#1

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 :smiley:

{-# 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

3 Likes