{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module Polysemy.WebServer (WebServer, PendingWebRequest, startWebServer,
respondWebRequest, getBody, runWebServerFinal) where
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.HTTP.Types.Status as HTTP
import Polysemy
import Polysemy.Final
import Data.Functor
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
newtype PendingWebRequest =
PendingWebRequest (Wai.Response -> IO Wai.ResponseReceived)
data WebServer m a where
StartWebServer :: Warp.Port -> (
Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->
WebServer m ()
RespondWebRequest :: PendingWebRequest -> Wai.Response ->
WebServer m Wai.ResponseReceived
GetBody :: Int -> Wai.Request -> WebServer m (Maybe BS.ByteString)
makeSem ''WebServer
runStartWebServer :: forall rInitial r f.
((Final IO) `Member` r, Functor f) =>
Warp.Port -> (
Wai.Request -> PendingWebRequest ->
Sem rInitial Wai.ResponseReceived) ->
Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServer port app = do
s0 <- getInitialStateT
appFnS <- bindT $ uncurry app
ins <- getInspectorT
let
appFn :: (Wai.Request, PendingWebRequest) ->
Sem r (Maybe Wai.ResponseReceived)
appFn = runWebServerFinal . (fmap (inspect ins)) . appFnS . (s0 $>)
withStrategicToFinal $ do
appFnS' <- bindS (raise . appFn)
ins' <- getInspectorS
s1 <- getInitialStateS
let
appFn' :: (Wai.Request, PendingWebRequest) ->
IO (Maybe Wai.ResponseReceived)
appFn' = (fmap (join . inspect ins')) . appFnS' . (s1 $>)
return $ do
let
doRequestIO :: Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) ->
IO Wai.ResponseReceived
doRequestIO req respond = do
maybeRR <- appFn' (req, PendingWebRequest respond)
case maybeRR of
Just rr -> return rr
Nothing -> respond $
Wai.responseLBS (HTTP.status500) [] "Internal server error"
Warp.run port $ \req reply -> doRequestIO req reply
return $ s1 $> s0
runRespondWebRequest :: forall rInitial r f.
((Final IO) `Member` r, Functor f) =>
PendingWebRequest -> Wai.Response ->
Sem (WithTactics WebServer f (Sem rInitial) r) (f Wai.ResponseReceived)
runRespondWebRequest (PendingWebRequest respond) resp = do
s0 <- getInitialStateT
withStrategicToFinal $ do
s1 <- getInitialStateS
return $ do
rr <- respond (resp)
return $ s1 $> (s0 $> rr)
runGetBody :: forall rInitial r f.
((Final IO) `Member` r, Functor f) =>
Int -> Wai.Request ->
Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe BS.ByteString))
runGetBody maxLen req = do
body <- embedFinal $ Wai.lazyRequestBody req
let strictBody = LBS.toStrict $ LBS.take (fromIntegral $ maxLen + 1) body
if BS.length strictBody > maxLen
then pureT Nothing
else pureT (Just strictBody)
runWebServerFinal :: ((Final IO) `Member` r) =>
Sem (WebServer ': r) a -> Sem r a
runWebServerFinal =
interpretH (\v -> case v of
StartWebServer port app -> runStartWebServer port app
RespondWebRequest reqId response -> runRespondWebRequest reqId response
GetBody maxLen req -> runGetBody maxLen req
)