-- | Converts mig server to WAI-application.
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

-- | Size of the input body
type Kilobytes = Int

-- | Server config
data ServerConfig = ServerConfig
  { ServerConfig -> Maybe Kilobytes
maxBodySize :: Maybe Kilobytes
  -- ^ limit the request body size. By default it is unlimited.
  , ServerConfig -> Maybe CacheConfig
cache :: Maybe CacheConfig
  -- ^ LRU cache if needed (default is no cache)
  , ServerConfig -> FindRouteType
findRoute :: FindRouteType
  -- ^ API normal form and find route strategy (default is plain api finder)
  }

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

-- | Algorithm to find route handlers by path
data FindRouteType
  = -- | converts api to tree-like structure (prefer it for servers with many routes)
    TreeFinder
  | -- | no optimization (prefer it for small servers)
    PlainFinder

{-| Converts mig server to WAI-application.
Note that only IO-based servers are supported. To use custom monad
we can use @hoistServer@ function which renders monad to IO based or
the class @HasServer@ which defines such transformatio for several useful cases.
-}
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

-- | Convert server to WAI-application
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)

-- | Convert server to WAI-application
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)

-- | Convert response to low-level WAI-response
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 -- TODO
  where
    lbs :: ByteString -> Response
lbs = Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Response
resp.status Response
resp.headers

{-| Read request from low-level WAI-request
First argument limits the size of input body. The body is read in chunks.
-}
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

-- | Read request body in chunks. Note that this function can be used only once
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