module Mig.Server.Wai (
ServerConfig (..),
FindRouteType (..),
Kilobytes,
toApplication,
) where
import Control.Monad.Catch
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Default
import Data.Foldable
import Data.IORef
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Sequence (Seq (..), (|>))
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Network.Wai qualified as Wai
import Mig.Core
import Mig.Core.Server.Cache
type Kilobytes = Int
data ServerConfig = ServerConfig
{ ServerConfig -> Maybe Kilobytes
maxBodySize :: Maybe Kilobytes
, ServerConfig -> Maybe CacheConfig
cache :: Maybe CacheConfig
, ServerConfig -> FindRouteType
findRoute :: FindRouteType
}
instance Default ServerConfig where
def :: ServerConfig
def = Maybe Kilobytes
-> Maybe CacheConfig -> FindRouteType -> ServerConfig
ServerConfig forall a. Maybe a
Nothing forall a. Maybe a
Nothing FindRouteType
PlainFinder
data FindRouteType
=
TreeFinder
|
PlainFinder
toApplication :: ServerConfig -> Server IO -> Wai.Application
toApplication :: ServerConfig -> Server IO -> Application
toApplication ServerConfig
config = case ServerConfig
config.cache of
Just CacheConfig
cacheConfig ->
case ServerConfig
config.findRoute of
FindRouteType
TreeFinder -> forall (nf :: * -> *).
CacheConfig
-> ServerConfig -> FindRoute nf IO -> Server IO -> Application
toApplicationWithCache CacheConfig
cacheConfig ServerConfig
config forall (m :: * -> *). FindRoute TreeApi m
treeApiStrategy
FindRouteType
PlainFinder -> forall (nf :: * -> *).
CacheConfig
-> ServerConfig -> FindRoute nf IO -> Server IO -> Application
toApplicationWithCache CacheConfig
cacheConfig ServerConfig
config forall (m :: * -> *). FindRoute Api m
plainApiStrategy
Maybe CacheConfig
Nothing ->
case ServerConfig
config.findRoute of
FindRouteType
TreeFinder -> forall (nf :: * -> *).
ServerConfig -> FindRoute nf IO -> Server IO -> Application
toApplicationNoCache ServerConfig
config forall (m :: * -> *). FindRoute TreeApi m
treeApiStrategy
FindRouteType
PlainFinder -> forall (nf :: * -> *).
ServerConfig -> FindRoute nf IO -> Server IO -> Application
toApplicationNoCache ServerConfig
config forall (m :: * -> *). FindRoute Api m
plainApiStrategy
toApplicationNoCache :: ServerConfig -> FindRoute nf IO -> Server IO -> Wai.Application
toApplicationNoCache :: forall (nf :: * -> *).
ServerConfig -> FindRoute nf IO -> Server IO -> Application
toApplicationNoCache ServerConfig
config FindRoute nf IO
findRoute Server IO
server Request
req Response -> IO ResponseReceived
procResponse = do
Maybe Response
mResp <- forall a (m :: * -> *).
(Exception a, MonadCatch m) =>
(a -> ServerFun m) -> ServerFun m -> ServerFun m
handleServerError SomeException -> ServerFun IO
onErr (forall (m :: * -> *) (normalForm :: * -> *).
Monad m =>
FindRoute normalForm m -> Server m -> ServerFun m
fromServer FindRoute nf IO
findRoute Server IO
server) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Kilobytes -> Request -> IO Request
fromRequest ServerConfig
config.maxBodySize Request
req
Response -> IO ResponseReceived
procResponse forall a b. (a -> b) -> a -> b
$ Response -> Response
toWaiResponse forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Response
noResult Maybe Response
mResp
where
noResult :: Response
noResult = forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text (Text
"Server produces nothing" :: Text)
onErr :: SomeException -> ServerFun IO
onErr :: SomeException -> ServerFun IO
onErr SomeException
err = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text forall a b. (a -> b) -> a -> b
$ Text
"Error: Exception has happened: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText (forall a. Show a => a -> String
show SomeException
err)
toApplicationWithCache :: CacheConfig -> ServerConfig -> FindRoute nf IO -> Server IO -> Wai.Application
toApplicationWithCache :: forall (nf :: * -> *).
CacheConfig
-> ServerConfig -> FindRoute nf IO -> Server IO -> Application
toApplicationWithCache CacheConfig
cacheConfig ServerConfig
config FindRoute nf IO
findRoute Server IO
server Request
req Response -> IO ResponseReceived
procResponse = do
RouteCache IO
cache <- forall (m :: * -> *). CacheConfig -> IO (RouteCache m)
newRouteCache CacheConfig
cacheConfig
Maybe Response
mResp <- forall a (m :: * -> *).
(Exception a, MonadCatch m) =>
(a -> ServerFun m) -> ServerFun m -> ServerFun m
handleServerError SomeException -> ServerFun IO
onErr (forall (m :: * -> *) (normalForm :: * -> *).
MonadIO m =>
FindRoute normalForm m -> RouteCache m -> Server m -> ServerFun m
fromServerWithCache FindRoute nf IO
findRoute RouteCache IO
cache Server IO
server) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Kilobytes -> Request -> IO Request
fromRequest ServerConfig
config.maxBodySize Request
req
Response -> IO ResponseReceived
procResponse forall a b. (a -> b) -> a -> b
$ Response -> Response
toWaiResponse forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Response
noResult Maybe Response
mResp
where
noResult :: Response
noResult = forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text (Text
"Server produces nothing" :: Text)
onErr :: SomeException -> ServerFun IO
onErr :: SomeException -> ServerFun IO
onErr SomeException
err = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest @Text forall a b. (a -> b) -> a -> b
$ Text
"Error: Exception has happened: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText (forall a. Show a => a -> String
show SomeException
err)
toWaiResponse :: Response -> Wai.Response
toWaiResponse :: Response -> Response
toWaiResponse Response
resp =
case Response
resp.body of
FileResp String
file -> Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
Wai.responseFile Response
resp.status Response
resp.headers String
file forall a. Maybe a
Nothing
RawResp MediaType
_ ByteString
str -> ByteString -> Response
lbs ByteString
str
ResponseBody
StreamResp -> forall a. HasCallStack => a
undefined
where
lbs :: ByteString -> Response
lbs = Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Response
resp.status Response
resp.headers
fromRequest :: Maybe Kilobytes -> Wai.Request -> IO Request
fromRequest :: Maybe Kilobytes -> Request -> IO Request
fromRequest Maybe Kilobytes
maxSize Request
req = do
BodyCache (Either Text ByteString)
bodyCache <- forall a. IO (BodyCache a)
newBodyCache
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Request
{ $sel:path:Request :: [Text]
path = Request -> [Text]
Wai.pathInfo Request
req
, $sel:query:Request :: QueryMap
query = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Request -> Query
Wai.queryString Request
req)
, $sel:headers:Request :: HeaderMap
headers = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
Wai.requestHeaders Request
req
, $sel:method:Request :: ByteString
method = Request -> ByteString
Wai.requestMethod Request
req
, $sel:readBody:Request :: IO (Either Text ByteString)
readBody = forall a. IO a -> BodyCache a -> IO a
readBodyCache IO (Either Text ByteString)
getRequestBody BodyCache (Either Text ByteString)
bodyCache
, $sel:capture:Request :: CaptureMap
capture = forall a. Monoid a => a
mempty
, $sel:isSecure:Request :: Bool
isSecure = Request -> Bool
Wai.isSecure Request
req
}
where
getRequestBody :: IO (Either Text ByteString)
getRequestBody =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
BL.fromChunks) forall a b. (a -> b) -> a -> b
$ IO ByteString -> Maybe Kilobytes -> IO (Either Text [ByteString])
readRequestBody (Request -> IO ByteString
Wai.getRequestBodyChunk Request
req) Maybe Kilobytes
maxSize
newtype BodyCache a = BodyCache (IORef (Maybe a))
newBodyCache :: IO (BodyCache a)
newBodyCache :: forall a. IO (BodyCache a)
newBodyCache = forall a. IORef (Maybe a) -> BodyCache a
BodyCache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
readBodyCache :: IO a -> BodyCache a -> IO a
readBodyCache :: forall a. IO a -> BodyCache a -> IO a
readBodyCache IO a
getter (BodyCache IORef (Maybe a)
ref) = do
Maybe a
mVal <- forall a. IORef a -> IO a
readIORef IORef (Maybe a)
ref
case Maybe a
mVal of
Just a
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
Maybe a
Nothing -> do
a
val <- IO a
getter
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref (forall a. a -> Maybe a
Just a
val)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
readRequestBody :: IO B.ByteString -> Maybe Kilobytes -> IO (Either Text [B.ByteString])
readRequestBody :: IO ByteString -> Maybe Kilobytes -> IO (Either Text [ByteString])
readRequestBody IO ByteString
readChunk Maybe Kilobytes
maxSize = Kilobytes -> Seq ByteString -> IO (Either Text [ByteString])
loop Kilobytes
0 forall a. Seq a
Seq.empty
where
loop :: Kilobytes -> Seq B.ByteString -> IO (Either Text [B.ByteString])
loop :: Kilobytes -> Seq ByteString -> IO (Either Text [ByteString])
loop !Kilobytes
currentSize !Seq ByteString
result
| Kilobytes -> Bool
isBigger Kilobytes
currentSize = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Either Text a
outOfSize
| Bool
otherwise = do
ByteString
chunk <- IO ByteString
readChunk
if ByteString -> Bool
B.null ByteString
chunk
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq ByteString
result)
else Kilobytes -> Seq ByteString -> IO (Either Text [ByteString])
loop (Kilobytes
currentSize forall a. Num a => a -> a -> a
+ ByteString -> Kilobytes
B.length ByteString
chunk) (Seq ByteString
result forall a. Seq a -> a -> Seq a
|> ByteString
chunk)
outOfSize :: Either Text a
outOfSize :: forall a. Either Text a
outOfSize = forall a b. a -> Either a b
Left Text
"Request is too big Jim!"
isBigger :: Kilobytes -> Bool
isBigger = case Maybe Kilobytes
maxSize of
Just Kilobytes
size -> \Kilobytes
current -> Kilobytes
current forall a. Ord a => a -> a -> Bool
> Kilobytes
size
Maybe Kilobytes
Nothing -> forall a b. a -> b -> a
const Bool
False