Giraffe computation expression (PureScript prototype)

Giraffe.purs

module Giraffe where

import Prelude

import Control.Monad.Cont (Cont, callCC, cont, lift, runCont)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Data.Maybe (Maybe(..))
  
data HttpContext = HttpContext
type HttpFuncResult = Maybe HttpContext -- Task<Option<..>> actually, but ignore Task for simplicity here
type HttpHandler = (HttpContext -> HttpFuncResult) -> HttpContext -> HttpFuncResult

-- | (G)eneralized 'HttpHandler'. Namely, 'GHttpHandler HttpContext' ~ 'HttpHandler', see function 'httpHandler'.
newtype GHttpHandler a = GHttpHandler (ReaderT HttpContext (Cont HttpFuncResult) a)

derive newtype instance functorGHandler :: Functor GHttpHandler
derive newtype instance applyGHandler :: Apply GHttpHandler
derive newtype instance applicativeGHandler :: Applicative GHttpHandler
derive newtype instance bindGHandler :: Bind GHttpHandler
derive newtype instance monadGHandler :: Monad GHttpHandler

-- | Go back from the generalized HTTP handler "closed" with 'HttpContext' to the regular Giraffe HTTP handler.
httpHandler :: GHttpHandler HttpContext -> HttpHandler
httpHandler (GHttpHandler ghandler) nekst ctx = runCont (runReaderT ghandler ctx) nekst

-- | Access current HTTP context.
context :: GHttpHandler HttpContext
context = GHttpHandler ask

-- | Continue processing in the pipeline.
next :: GHttpHandler HttpContext
next = GHttpHandler do
  c <- ask
  callCC \cont -> cont c

-- Continue --

-- Low-level helper (simulation)
setHttpHeader' :: forall m key value. Applicative m => HttpContext -> key -> value -> m Unit
setHttpHeader' _ _ _ = pure unit

{- Giraffe documentation example

let setHttpHeader key value : HttpHandler =
    fun (next : HttpFunc) (ctx : HttpContext) ->
        ctx.SetHttpHeader key value
        next ctx

becomes:

-}

setHttpHeader :: forall key value. key -> value -> GHttpHandler HttpContext
setHttpHeader key value = do
  c <- context
  setHttpHeader' c key value
  next

-- Return early --

-- Low-level helper (simulation)
setStatusCode' :: forall m. Applicative m => Int -> HttpContext -> m Unit
setStatusCode' _ _ = pure unit

-- A helper
setStatusCode :: forall a. Int -> (HttpContext -> HttpFuncResult) -> GHttpHandler a
setStatusCode httpStatus nekst = do
  c <- context
  setStatusCode' httpStatus c
  GHttpHandler $ lift $ cont \_ -> nekst c

{- Giraffe documentation example

let earlyReturn : HttpFunc = Some >> Task.FromResult

let checkUserIsLoggedIn : HttpHandler =
    fun (next : HttpFunc) (ctx : HttpContext) ->
        if isNotNull ctx.User && ctx.User.Identity.IsAuthenticated
        then next ctx
        else setStatusCode 401 earlyReturn ctx

becomes:

-}

checkUserIsLoggedIn :: GHttpHandler HttpContext
checkUserIsLoggedIn = do
  let
    isAuthenticated = const true -- simulation
    earlyReturn = Just
  c <- context
  if isAuthenticated c then next else setStatusCode 401 earlyReturn

-- Skip --

{- Giraffe documentation example

let skip : HttpFuncResult = Task.FromResult None

let GET : HttpHandler =
    fun (next : HttpFunc) (ctx : HttpContext) ->
        if HttpMethods.IsGet ctx.Request.Method
        then next ctx
        else skip

becomes:

-}

-- A helper
isGet :: HttpContext -> Boolean
isGet _ = true

skip :: forall a. GHttpHandler a
skip = GHttpHandler $ lift $ cont $ const Nothing

get :: GHttpHandler HttpContext
get = do
  c <- context
  if isGet c then next else skip