more playing around with servant (featuring different monads and cookies)

webapp.hs

-- application specific monads and types
type ServerMonad a
type SessionMonad a

runServerMonad :: ServerContext -> ServerMonad a -> IO (Either (Int,String) a)
authenticated :: AuthData -> SessionMonad a -> ServerMonad a

data AuthData
data AuthResponse a

getAuthData :: Request -> AuthData

message :: AuthResponse a -> a
mkAuthHeaders :: AuthResponse a -> Headers


-- servant API extension for authentication
data Auth

instance HasServer sublayout => HasServer (Auth :> sublayout) where
        type ServerT (Auth :> sublayout) m = AuthData -> ServerT sublayout m
        route Proxy server req cont = route (Proxy :: Proxy sublayout) (server $ getAuthData req) req cont


-- servant API extension for session cookie (slightly hacky)
data SetSessionCookie (method :: * -> *) a

instance (HasServer (method a), ServerT (method a) m ~ m a) => HasServer (SetSessionCookie method a) where
        type ServerT (SetSessionCookie method a) m = m (AuthResponse a)
        route Proxy action request respond =
                runEitherT action >>= \case
                        Right res -> route sub (right $ message res) request (injectHdr res)
                        Left err -> route sub (left err) request respond
                where sub = Proxy :: Proxy (method a)
                      injectHdr auth res = case routeResult res of
                                                Left err -> respond res
                                                Right r -> respond $ RR $ Right $ addHeaders r (mkAuthHeaders auth)

addHeaders :: Response -> ResponseHeaders -> Response
addHeaders (ResponseFile st hdrs path parts) newHdrs = ResponseFile st (newHdrs ++ hdrs) path parts
addHeaders (ResponseBuilder st hdrs b) newHdrs = ResponseBuilder st (newHdrs ++ hdrs) b
addHeaders (ResponseStream st hdrs b) newHdrs = ResponseStream st (newHdrs ++ hdrs) b
addHeaders (ResponseRaw h r) newHdrs = ResponseRaw h (addHeaders r newHdrs)



-- transforming handlers
class HandlerT h where
        type Ctx h
        type Run h
        enter :: h -> Ctx h -> Run h

instance HandlerT (ServerMonad a) where
        type Ctx (ServerMonad a) = ServerContext
        type Run (ServerMonad a) = EitherT (Int,String) IO a
        enter h ctx = EitherT $ runServerMonad ctx h

instance HandlerT (SessionMonad a) where
        type Ctx (SessionMonad a) = AuthData
        type Run (SessionMonad a) = ServerMonad a
        enter = flip authenticated

instance HandlerT h => HandlerT (a -> h) where
        type Ctx (a -> h) = Ctx h
        type Run (a -> h) = a -> Run h
        enter h ctx a = enter (h a) ctx

instance (HandlerT a, HandlerT b, Ctx a ~ Ctx b) => HandlerT (a :<|> b) where
        type Ctx (a :<|> b) = Ctx a
        type Run (a :<|> b) = Run a :<|> Run b
        enter (a :<|> b) ctx = enter a ctx :<|> enter b ctx


-- auth API
data Ok

type AuthAPI = "login" :> ReqBody '[JSON] LoginData :> SetSessionCookie (Post '[JSON]) Ok
          :<|> "verify" :> Auth :> Get '[JSON] Ok
authAPI :: Proxy AuthAPI
authAPI = Proxy

login :: LoginData -> ServerMonad (AuthResponse Ok)
verify :: SessionMonad Ok

myHandler :: ServerT AuthAPI ServerMonad
myHandler = login :<|> enter verify

app :: ServerContext -> Application
app ctx = serve authAPI (enter myHandler ctx)

Does this work with Raw? Specifically, l worry ln 63 might push things too far into it (though that could be solved by wrapping it in a newtype).