Something went wrong. Try again.
A Haskell Webserver Template
Something went wrong. Try again.
4.7 kB · 129 lines
Haskell
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130module Webserver.Control.Handler ( Handler, Route, resolveHandler, handle, respond, serveHtml, require, requireJust, requireRight, throwResponse, readJsonBody, readJsonBodyWith, liftIO,)where
----------------------------------------------------------------------------------------------------
import Control.Monad.IO.Class (liftIO)import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)import Data.Aeson (FromJSON)import qualified Network.HTTP.Types as Httpimport qualified Network.Wai as Waiimport qualified System.Directory as Dirimport qualified Webserver.Control.Body as Bodyimport Webserver.Data.Context (Context)import qualified Webserver.Data.Response as Responseimport Webserver.Data.Response (Response, toWaiResponse)import Webserver.Data.Sql.Cache.Session (Sessions)
----------------------------------------------------------------------------------------------------
-- | A handler monad where the "error" channel is an HTTP response (early return)type Handler = ExceptT Response IO
-- | A route handler that produces a 'Response' without needing the WAI callbacktype Route = Sessions -> Context -> Wai.Request -> IO Response
-- | Collapse a 'Handler' computation into a plain 'IO Response'resolveHandler :: Handler Response -> IO ResponseresolveHandler handler = runExceptT handler >>= \case Left earlyReturn -> return earlyReturn Right result_ -> return result_
-- | Bridge a 'Route' into a full WAI handler by applying 'toWaiResponse' oncehandle :: Route -> Sessions -> Context -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceivedhandle route sn ctx request respondWith = do r <- route sn ctx request respondWith <| toWaiResponse r
-- | Use a pre-built 'Response' as a 'Route' (ignores session, context, request)respond :: Response -> Routerespond r _ _ _ = return r
----------------------------------------------------------------------------------------------------
-- | Require a condition to be 'True', otherwise early-return the given responserequire :: Bool -> Response -> Handler ()require condition fallback = if condition then return () else throwE fallback
{- | Unwrap a 'Just', otherwise early-return the given response. Response comes first to support @>>= requireJust badRequest@ chaining.-}requireJust :: Response -> Maybe a -> Handler arequireJust fallback = \case Just val -> return val Nothing -> throwE fallback
-- | Unwrap a 'Right', otherwise map the error to a response and early-returnrequireRight :: (e -> Response) -> Either e a -> Handler arequireRight toResponse = \case Right val -> return val Left err -> throwE <| toResponse err
-- | Explicitly early-return a responsethrowResponse :: Response -> Handler athrowResponse = throwE
----------------------------------------------------------------------------------------------------
-- | Read and decode a JSON request body inside 'Handler', early-returning on errorsreadJsonBody :: (FromJSON a) => Wai.Request -> Handler areadJsonBody request = do result_ <- liftIO <| Body.readJsonBody request requireRight Response.respondBodyError result_
-- | Read and decode a JSON request body with a custom size limit inside 'Handler'readJsonBodyWith :: (FromJSON a) => Int -> Wai.Request -> Handler areadJsonBodyWith maxSize request = do result_ <- liftIO <| Body.readJsonBodyWith maxSize request requireRight Response.respondBodyError result_
----------------------------------------------------------------------------------------------------
{- | Serve an HTML file as a 'Handler Response'. Returns a 500 error response if the file doesn't exist.-}serveHtml :: String -> Handler ResponseserveHtml filePath = let htmlDir = "./static/html" fullPath = htmlDir <> "/" <> filePath htmlHeaders = [("Content-Type", "text/html; charset=utf-8")] errorBody = "<!DOCTYPE html><html><body><h1>500 Internal Server Error</h1><p>Template file not found.</p></body></html>" in do exists <- liftIO <| Dir.doesFileExist fullPath if exists then return ( Response.response Http.ok200 |> Response.withHeaders htmlHeaders |> Response.withFileBody fullPath ) else return ( Response.response Http.internalServerError500 |> Response.withHeaders htmlHeaders |> Response.withBody errorBody )