{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Server.Util where

import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Happstack.Server
import qualified Data.ByteString.Lazy as BS

forceSlash :: ServerPart Response -> ServerPart Response
forceSlash :: ServerPart Response -> ServerPart Response
forceSlash ServerPart Response
x = ServerPartT IO ()
forall (m :: * -> *). (ServerMonad m, MonadPlus m) => m ()
nullDir ServerPartT IO () -> ServerPart Response -> ServerPart Response
forall a b.
ServerPartT IO a -> ServerPartT IO b -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ServerPart Response] -> ServerPart Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ServerPartT IO ()
forall (m :: * -> *). (ServerMonad m, MonadPlus m) => m ()
trailingSlash ServerPartT IO () -> ServerPart Response -> ServerPart Response
forall a b.
ServerPartT IO a -> ServerPartT IO b -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ServerPart Response
x, ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq ServerPartT IO Request
-> (Request -> ServerPart Response) -> ServerPart Response
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Request
rq -> [Char] -> Response -> ServerPart Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (Request -> [Char]
rqUri Request
rq [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/") (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())]

getBody :: ServerPart BS.ByteString
getBody :: ServerPart ByteString
getBody = ServerPartT IO Request
forall (m :: * -> *). ServerMonad m => m Request
askRq ServerPartT IO Request
-> (Request -> ServerPartT IO (Maybe RqBody))
-> ServerPartT IO (Maybe RqBody)
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe RqBody) -> ServerPartT IO (Maybe RqBody)
forall a. IO a -> ServerPartT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe RqBody) -> ServerPartT IO (Maybe RqBody))
-> (Request -> IO (Maybe RqBody))
-> Request
-> ServerPartT IO (Maybe RqBody)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO (Maybe RqBody)
forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody ServerPartT IO (Maybe RqBody)
-> (Maybe RqBody -> ServerPart ByteString) -> ServerPart ByteString
forall a b.
ServerPartT IO a -> (a -> ServerPartT IO b) -> ServerPartT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
        Just RqBody
rqbody -> ByteString -> ServerPart ByteString
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ServerPart ByteString)
-> (RqBody -> ByteString) -> RqBody -> ServerPart ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RqBody -> ByteString
unBody (RqBody -> ServerPart ByteString)
-> RqBody -> ServerPart ByteString
forall a b. (a -> b) -> a -> b
$ RqBody
rqbody
        Maybe RqBody
Nothing     -> ByteString -> ServerPart ByteString
forall a. a -> ServerPartT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""