monadicsystems/okapi
1
1
Fork 0
mirror of https://github.com/monadicsystems/okapi.git synced 2024-12-11 19:59:47 +03:00
Code Issues Projects Releases Wiki Activity
d014c5adab
okapi/lib/NewDesign.md
Rashad Gover 8685165771 Major refactor
2023-04-20 06:36:55 +00:00

16 KiB
Raw Blame History

Build A Web Framework in Haskell From Scratch

Haskell for Backend Web Development

What is WAI?

The Simplest Possible Server

server :: Request -> Response

Interacting With The Real World

server :: Monad m => Request -> m Response

server :: Request -> Identity Response

Making Our Server Modular

server :: Reader Request Response

Separating Effects

Once concern with the Okapi monad is that I can interleave random IO actions in the route parser. This means the programmer has to be careful of where IO actions are executed. Once an IO action is executed, it can't be undone. Even with backtracking. In practice, we want to keep our route parser, and handler (which might use IO) separate.

  1. The Router - The one and only job of the router is to extract and verify the existence of data in the request.
  2. The Handler - The one and only job of the handler is to accept data provided by the router and generate a response in the desired context.

In this way, we achieve separation of concerns. What does this look like?

server
  :: Monad m
  => Router a          -- Router
  -> (a -> m Response) -- Handler
  -> (m a -> IO a)     -- Lifter
  -> Application       -- Application
server = undefined

data Router a = Router
  { 
  }

server
  :: Monad m
  => Router a          -- Router
  -> (a -> m Response) -- Handler
  -> (m ~> IO)         -- Lifter (Natural Transformation)
  -> Application       -- Application
server = undefined

serverPure
  :: (Request -> a)
  -> (a -> Response)
  -> Application
serverPure = undefined

serverPure'
  :: (Request -> Response)
  -> Application
serverPure' = undefined

A Simpler Routing Interface

server
  :: (RouteData -> Route -> m Response)
  -> (m ~> IO)
  -> Application
server f nt = ...

data Route = Route
  { method :: Method
  , path :: [Text]
  }

pattern GetUser :: UserID -> Route
pattern GetUser userID = Route GET ["users", userID]

pattern PostUser :: UserID -> Route
pattern PostUser userID = Route POST ["users", userID]

server
  :: RouteData
  -> Route %1
  -> m Response
server routeData = \case
  GetUser userID -> do
    ...
  PostUser userID -> do
    ...
  _ -> return notFoundResponse

-- Record of higher order functions
data RouteData = RouteData
  { queryParam :: HttpApiData a => Text -> Result a
  , header :: HttpApiData a => Text -> Result a
  , body :: ...
  , file :: ...
  , formParam :: ...
  , ...
  }

server
  :: RouteData
  -> Route %1
  -> m Response
server routeData route = do
  let
    setup1 = do
	  ...
	setup2 = ...
  setup3 <- ...
  case route of
    GetUser userID -> do
      ...
    PostUser userID -> do
      ...
    _ -> return notFoundResponse

Alternate Syntax

Fast API Like

getUsers :: Controller
getUsers = [get|
    /users
    ?age:Int
    ?name:Text
    ?status:Status
  |] id handler
  where
    handler :: (Int, Text, Status) -> m Response
    handler = ...

[post| /user/:UserID |] :: ...

[put| /user/:UserID |]

Controller Method

data Error = JSONError ... | ...
data Result a = Cont a | Next

data Extractor a = ...

instance Applicative Extractor where

extractUser :: Extractor User
extractUser = do
  methodIs GET
  pathParamIs @Text "users" <|> pathParamIs "people"
  userID <- pathParam @UserID
  userQuery <- json @UserQuery
  pure GetUser{..}

data Extractor a = Ok a | Fail

data Result a = Respond a | Next

type Handler m a = Extractor a -> m (Result Response)

controller
  :: (m ~> IO)
  -> Extractor a
  -> Handler m a
  -> Controller
controller transformer router handler = ...

combineController
  :: Controller
  -> Controller
  -> Controller
combineController c1 c2 = ...

data Controller = Controller
  { 
  }

Mixing Patterns with Extractors

Use patterns for method and path. Use extractors for everything else.

router :: Route -> Extractor a
router = \case
  (GET, ["index"]) -> do
	..
  (GET, ["posts", PathParam postID]) -> do
	..
  _ -> undefined

Probably not ideal because the exact extractor value can depend on the path parameter. We can't guarantee the developer won't do this.

Route as Data

myRoute :: Endpoint
myRoute = Endpoint
  { method = GET
  , path =
	  [ Static "people"
	  , Param @PersonID "personID"
	  ]
  , query =
	  [ Param @Bool "profile"
	  ]
  , headers =
	  [ Param @Text "X-Some-Header"
	  ]
  , body = JSON @PersonFilter
  }

Combine with extractor DSL?

myRoute :: Endpoint pd qd hd bd
myRoute = Endpoint
  { method = GET
  , path = do
      static "profile"
      pID <- param @ProfileID
      pure pID
  , query = do
	  useProfile <- flag "profile"
	  pure useProfile
  , headers = NoHeaders
  , body = json @PersonFilter
  }

myRoute' :: Endpoint pd qd hd bd rd
myRoute' = Endpoint
  { method = GET :| [PUT, POST]
  , path = do
      static "profile"
      pID <- param @ProfileID
      pure pID
  , query = do
       useProfile <- flag "profile"
	   pure useProfile
  , headers = NoHeaders
  , body = do
	  filter <- json @PersonFilter
	  pure filter
  , responder = do
	  sendOk <- ok
	  sendNotFound <- notFound
	  pure Send{..}
  }

myRoute'' :: Endpoint pd qd hd bd rd
myRoute'' = Endpoint
  GET
  static "index"
  NoQuery
  NoHeaders
  NoBody
  ok

data Params pd qd hd bd rd = Params
  { path :: pd
  , query :: qd
  , headers :: hd
  , body :: bd
  , response :: rd %1
  -- TODO: Have two fields for response ~
  -- On Error and on Ok
  -- , responseError :: red %1
  }

-- Use type level function to produce types for both
-- Endpoint and Params.

myHandler
  :: Monad m
  => (Params pd qd hd bd rd) %1
  -> m (Action Response)
myHandler paramsResult = case paramsResult of
  Error err -> do
	-- | Do logging or whatever if error
	liftIO $ print err
    return Next
  Ok params -> do
	let
      profileID     = path params
      isProfileView = query params
      personFilter  = body params

	return $ params.response.respondOk responseValue

makeController
  :: Monad m
  => (m ~> IO)
  -> Endpoint pd qd hd bd rd
  -> (Params pd qd hd bd rd -> m Response)
  -> Controller
makeController lifter endpoint handler = ...

The above seems to be the best design.

Combining Controllers

Non-Empty List

type Server = NonEmptyList Controller
-- Use Map instead

myServer = controller1 :| [controller2, controller3]

genApplication
  :: ServerOptions
  {-| Control body max size
	  , default response
	  , IO error to response
	  , etc.
  -}
  -> Server
  -> Application

genJSClient :: Server -> FilePath -> IO ()

genOpenAPISpec :: Server -> OpenAPISpec

genApplication takes server options and a server definition.

Megalith Web Framework

File-based Routing

Megalith supports file-based routing. Placing a .ml file in your project's pages directory will automatically generate a route to that page. .ml files can contain plain HTML. Here's an example .ml file called index.ml:

<div>
  <h1>
    Welcome to my website.
  </h1>
  <p>
    This website was built using the Megalith web framweork.
  </p>
</div>

If we run this app and go to localhost:3000/index, this page will be rendered in our browser.

Nested File-based Routes

We may create nested routes by simply creating a directory in our pages directory. For example, if we create a products directory in the pages directory, and then put bolts.ml in the products directory, our app will have the route localhost:3000/products/bolts.

Dynamic Routes

We can also create dynamic routes that contain parameters. We can use these route parameters in our templates. To do this, we need to wrap the file/directory name in square brackets ([]). We can then use the name inside the square brackets to refer to the parameter in our templates. Here's an example:

<!-- pages/products/[category].ml -->
<div>
  <h1>This is the $(category::Text) category.</h1>
</div>

Maybe consider using ! instead of [] for dynamic routes.

Running the app and going to localhost:3000/pages/products/watches will render the page:

<div>
  <h1>This is the watches category.</h1>
</div>

Template Syntax

Pushup like approach:

myHTML :: HTML
myHTML =
  <ul>
    ^forEach [1..10] \n ->
       <li>Number: ^n</li>
  </ul>

Or, a more traditional approach:

myHTML :: HTML
myHTML =
  <ul>
    {list}
  </ul>
  where
    list = forEach [1..10] \n -> <li>Number: {n}</li>

Megalith includes a GHC plugin that introduces a literal syntax for HTML tags. Inspired by JSX and Phoenix Components.

Components

type Component a = a -> HTML

class Component a where
  render :: a -> HTML

Routes

get
  :: Parser a
  -> (a -> m Response)
  -> ???

type Application m a = (Parser a, a -> m Response)

Server Pages

-- pages/index.mli --> localhost:3000/index

<div>
  <h1>Welcome to the Home Page!</h1>
</div>

-- pages/products/[category].mli
import Data.Text

<div>
  
</div>

Plan.Plan
  { lifter = id,
    endpoint =
      Endpoint.Endpoint
        { method = GET,
          path = do
            Path.static "index"
            magicNumber <- Path.param @Int
            pure magicNumber,
          query = do
            x <- Query.param @Int "x"
            y <- Query.option 10 $ Query.param @Int "y"
            pure (x, y),
          headers = pure (),
          body = pure (),
          responder = do
            itsOk <- Responder.json
              @Int
              HTTP.status200
              do
                addSecretNumber <- ResponderHeaders.has @Int "X-SECRET"
                pure addSecretNumber
            pure itsOk
        },
    handler = \(Params.Params magicNumber (x, y) () () responder) -> do
      let newNumber = magicNumber + x * y
      print newNumber
      return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
  }

Plan.Plan
  { -- Identity function as the lifter.
    lifter = id,

    -- Define the endpoint for the web service.
    endpoint =
      Endpoint.Endpoint
        { -- HTTP GET method for this endpoint.
          method = GET,

          -- Path pattern for this endpoint.
          path = do
            -- Expect "index" as a static part of the path.
            Path.static "index"

            -- Capture an integer parameter from the path.
            magicNumber <- Path.param @Int
            pure magicNumber,

          -- Query parameters for this endpoint.
          query = do
            -- Capture an integer query parameter named "x".
            x <- Query.param @Int "x"

            -- Capture an optional integer query parameter named "y" with a default value of 10.
            y <- Query.option 10 $ Query.param @Int "y"
            pure (x, y),

          -- No specific headers expected for this endpoint.
          headers = pure (),

          -- No request body expected for this endpoint.
          body = pure (),

          -- Define the responder for this endpoint.
          responder = do
            -- Create a JSON responder with HTTP status 200 and an integer value.
            itsOk <- Responder.json @Int HTTP.status200
              do
                -- Check for the presence of an "X-SECRET" header with an integer value.
                addSecretNumber <- ResponderHeaders.has @Int "X-SECRET"
                pure addSecretNumber

            -- Return the configured responder.
            pure itsOk
        },

    -- Define the handler function for the web service.
    handler = \(Params.Params magicNumber (x, y) () () responder) -> do
      -- Calculate a new number based on the magicNumber, x, and y.
      let newNumber = magicNumber + x * y

      -- Print the new number to the console.
      print newNumber

      -- Return a response with the new number and an additional header based on the new number.
      return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
  }


Plan.Plan
  { lifter = id,
    endpoint = Endpoint.Endpoint
      GET
      do
        Path.static "index"
        magicNumber <- Path.param @Int
        pure magicNumber
      do
        x <- Query.param @Int "x"
        y <- Query.option 10 $ Query.param @Int "y"
        pure (x, y)
      pure ()
      pure ()
      do
        itsOk <- Responder.json @Int HTTP.status200
          do
            addSecretNumber <- ResponderHeaders.has @Int "X-SECRET"
            pure addSecretNumber
        pure itsOk
    handler = \(Params.Params magicNumber (x, y) () () responder) -> do
      let newNumber = magicNumber + x * y
      print newNumber
      return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
  }

Plan
  Endpoint
    Method.GET
    Path.do
      Path.static "index"
      magicNumber <- Path.param @Int
      Path.pure magicNumber
    Query.do
      x <- Query.param @Int "x"
      y <- Query.option 10 $ Query.param @Int "y"
      Query.pure (x, y)
    Headers.pure ()
    Body.pure ()
    Responder.do
      itsOk <- Responder.json @Int HTTP.status200
        ResponderHeaders.do
          addSecretNumber <- ResponderHeaders.has @Int "X-SECRET"
          ResponderHeaders.pure addSecretNumber
      Responder.pure itsOk
  \magicNumber (x, y) () () responder -> do
    let newNumber = magicNumber + x * y
    print newNumber
    return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
  id

Plan $$
  Endpoint $$
    Method.GET
    Path.do
      Path.static "index"
      magicNumber <- Path.param @Int
      Path.pure magicNumber
    Query.do
      x <- Query.param @Int "x"
      y <- Query.option 10 $ Query.param @Int "y"
      Query.pure (x, y)
    Headers.pure ()
    Body.pure ()
    Responder.do
      itsOk <- Responder.json @Int HTTP.status200
        ResponderHeaders.do
          addSecretNumber <- ResponderHeaders.has @Int "X-SECRET"
          ResponderHeaders.pure addSecretNumber
      Responder.pure itsOk
  \magicNumber (x, y) () () responder -> do
    let newNumber = magicNumber + x * y
    print newNumber
    return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
  id

Plan $$
  Endpoint $$
    GET
    do
      Path.static "index"
      magicNumber <- Path.param @Int
      pure magicNumber
    do
      x <- Query.param @Int "x"
      y <- Query.option 10 $ Query.param @Int "y"
      pure (x, y)
    do pure ()
    do pure ()
    do
      itsOk <- Responder.json @Int HTTP.status200 do
        addSecretNumber <- ResponderHeaders.has @Int "X-SECRET"
        ResponderHeaders.pure addSecretNumber
      pure itsOk
  \magicNumber (x, y) () () responder -> do
    let newNumber = magicNumber + x * y
    print newNumber
    return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
  id

Endpoint Patterns

data Request = Request StdMethod [Text] Query BS.ByteString RequestHeaders
data Server m r = Server
  { responder :: Responder r
  , handler :: Request -> r -> m Response
  }

pattern GetUsers :: Maybe Filter -> Request
pattern GetUsers optFilter <- Request
  GET
  ["users"]
  (Query.eval filterQuery -> Ok filter)
  ""
  _
  
pattern AddUser :: User -> Request
pattern AddUser user <- Request
  POST
  ["users"]
  _
  (Body.eval (json @User) -> Ok user)
  _

pattern GetUsersByID :: UserID -> MatcherInput
pattern GetUsersByID userID <- Request
  GET
  (Path.eval pathParams -> Ok userID)
  _
  ""
  _
  where
    pathParams = do
      Path.static "users"
      userID <- Path.param @UserID "userID"
      pure userID

myServer :: MyResponderType -> Request -> IO Response 
myServer res = \case
  GetUser -> do
    ...
  GetUserByID userID -> do
    ...
  AddUser user -> do
    ...
  _ -> do
    ...

myServer = Server myResponder myServer

spend :: a %1 -> a %m ????