{-# LANGUAGE UndecidableInstances #-}

-- | Server definition
module Mig.Core.Server (
  Server (..),
  FindRoute (..),
  treeApiStrategy,
  plainApiStrategy,
  mapServerFun,
  mapResponse,
  fromServer,
  fromServerWithCache,
  fillCaptures,
  addTag,
  setDescription,
  setSummary,
  mapRouteInfo,
  staticFiles,
  describeInputs,
  atPath,
  filterPath,
  getServerPaths,
  addPathLink,
) where

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BL
import Data.List qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Safe (atMay, headMay)
import System.FilePath (takeExtension)
import Web.HttpApiData

import Mig.Core.Api (Api, fromNormalApi, toNormalApi)
import Mig.Core.Api qualified as Api
import Mig.Core.Api.NormalForm.TreeApi qualified as TreeApi
import Mig.Core.Class.MediaType
import Mig.Core.Class.Response (IsResp (..), Resp (..))
import Mig.Core.Class.Route
import Mig.Core.Server.Cache
import Mig.Core.ServerFun (ServerFun)
import Mig.Core.Types (Request (..), Response, setContent)
import Mig.Core.Types.Info (RouteInfo (..), RouteInput (..), describeInfoInputs, setOutputMedia)
import Mig.Core.Types.Info qualified as Describe (Describe (..))
import Mig.Core.Types.Route

{-| Server type. It is a function fron request to response.
Some servers does not return valid value. We use it to find right path.

Example:

> server :: Server IO
> server =
>   "api/v1" /.
>      [ "foo" /. handleFoo
>      , "bar" /. handleBar
>      ]
>
> handleFoo :: Query "name" Int -> Get IO (Resp Json Text)
> handleBar :: Post Json IO Text

Note that server is monoid and it can be constructed with Monoid functions and
path constructor @(/.)@. To pass inputs for handler we can use special newtype wrappers:

* @Query@ - for required query parameters
* @Optional@ - for optional query parameters
* @QueryFlag@ - for boolean query flags
* @Capture@ - for parsing elements of URI
* @Header@ - for parsing headers
* @OptionalHeader@ - for parsing optional headers
* @Body@ - fot request-body input

and other request types.

To distinguish by HTTP-method we use corresponding constructors: Get, Post, Put, etc.
Let's discuss the structure of the constructor. Let's take Get for example:

> type Get m a = Send GET m a
> newtype Send method m a = Send (m a)

 Let's look at the arguments of he type

* @method@ - type tag of the HTTP-method (GET, POST, PUT, DELETE, etc.)
* @m@ - underlying server monad
* @a@ - response type. It should be convertible to the type of the response (see @IsResp@ class).
-}
newtype Server m = Server {forall (m :: * -> *). Server m -> Api (Route m)
unServer :: Api (Route m)}
  deriving newtype (NonEmpty (Server m) -> Server m
Server m -> Server m -> Server m
forall b. Integral b => b -> Server m -> Server m
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (m :: * -> *). NonEmpty (Server m) -> Server m
forall (m :: * -> *). Server m -> Server m -> Server m
forall (m :: * -> *) b. Integral b => b -> Server m -> Server m
stimes :: forall b. Integral b => b -> Server m -> Server m
$cstimes :: forall (m :: * -> *) b. Integral b => b -> Server m -> Server m
sconcat :: NonEmpty (Server m) -> Server m
$csconcat :: forall (m :: * -> *). NonEmpty (Server m) -> Server m
<> :: Server m -> Server m -> Server m
$c<> :: forall (m :: * -> *). Server m -> Server m -> Server m
Semigroup, Server m
[Server m] -> Server m
Server m -> Server m -> Server m
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (m :: * -> *). Semigroup (Server m)
forall (m :: * -> *). Server m
forall (m :: * -> *). [Server m] -> Server m
forall (m :: * -> *). Server m -> Server m -> Server m
mconcat :: [Server m] -> Server m
$cmconcat :: forall (m :: * -> *). [Server m] -> Server m
mappend :: Server m -> Server m -> Server m
$cmappend :: forall (m :: * -> *). Server m -> Server m -> Server m
mempty :: Server m
$cmempty :: forall (m :: * -> *). Server m
Monoid)

-- | Applies server function to all routes
mapServerFun :: (ServerFun m -> ServerFun n) -> Server m -> Server n
mapServerFun :: forall (m :: * -> *) (n :: * -> *).
(ServerFun m -> ServerFun n) -> Server m -> Server n
mapServerFun ServerFun m -> ServerFun n
f (Server Api (Route m)
server) = forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Route m
x -> forall (m :: * -> *). RouteInfo -> ServerFun m -> Route m
Route Route m
x.info (ServerFun m -> ServerFun n
f Route m
x.run)) Api (Route m)
server

-- | Mapps response of the server
mapResponse :: (Functor m) => (Response -> Response) -> Server m -> Server m
mapResponse :: forall (m :: * -> *).
Functor m =>
(Response -> Response) -> Server m -> Server m
mapResponse Response -> Response
f = forall (m :: * -> *) (n :: * -> *).
(ServerFun m -> ServerFun n) -> Server m -> Server n
mapServerFun forall a b. (a -> b) -> a -> b
$ \ServerFun m
fun -> 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 Response -> Response
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerFun m
fun

{-| API route finder strategy. The API can be transformed to some normal form
for faster route lookup. So far we have two normal forms.
One is plain Api type as it is. And another one is tree-structure
where path switches are encoded with Map's.
-}
data FindRoute normalForm m = FindRoute
  { forall (normalForm :: * -> *) (m :: * -> *).
FindRoute normalForm m -> Api (Route m) -> normalForm (Route m)
toNormalForm :: Api (Route m) -> normalForm (Route m)
  , forall (normalForm :: * -> *) (m :: * -> *).
FindRoute normalForm m
-> [Text] -> normalForm (Route m) -> Maybe (Route m, CaptureMap)
getPath :: [Text] -> normalForm (Route m) -> Maybe (Route m, Api.CaptureMap)
  }

-- | Use TreeApi normal form. Path switches are encoded as Maps.
treeApiStrategy :: FindRoute TreeApi.TreeApi m
treeApiStrategy :: forall (m :: * -> *). FindRoute TreeApi m
treeApiStrategy =
  FindRoute
    { $sel:toNormalForm:FindRoute :: Api (Route m) -> TreeApi (Route m)
toNormalForm = forall a. Api a -> TreeApi a
TreeApi.toTreeApi
    , $sel:getPath:FindRoute :: [Text] -> TreeApi (Route m) -> Maybe (Route m, CaptureMap)
getPath = forall a. [Text] -> TreeApi a -> Maybe (a, CaptureMap)
TreeApi.getPath
    }

-- | Use plain api type. Just Api type as it is.
plainApiStrategy :: FindRoute Api.Api m
plainApiStrategy :: forall (m :: * -> *). FindRoute Api m
plainApiStrategy =
  FindRoute
    { $sel:toNormalForm:FindRoute :: Api (Route m) -> Api (Route m)
toNormalForm = forall a. a -> a
id
    , $sel:getPath:FindRoute :: [Text] -> Api (Route m) -> Maybe (Route m, CaptureMap)
getPath = forall a. [Text] -> Api a -> Maybe (a, CaptureMap)
Api.getPath
    }

{-| Converts server to server function. Server function can be used to implement low-level handlers
in various server-libraries.
-}
fromServer :: forall m normalForm. (Monad m) => FindRoute normalForm m -> Server m -> ServerFun m
fromServer :: forall (m :: * -> *) (normalForm :: * -> *).
Monad m =>
FindRoute normalForm m -> Server m -> ServerFun m
fromServer FindRoute normalForm m
strategy (Server Api (Route m)
server) = \Request
req -> do
  case Request -> Maybe (Route m, CaptureMap)
getRoute Request
req of
    Just (Route m
routes, CaptureMap
captureMap) -> Route m
routes.run Request
req{$sel:capture:Request :: CaptureMap
capture = CaptureMap
captureMap}
    Maybe (Route m, CaptureMap)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  where
    serverNormal :: ApiNormal (normalForm (Route m))
serverNormal = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FindRoute normalForm m
strategy.toNormalForm forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Api (Route m) -> ApiNormal (Api (Route m))
toNormalApi (forall (m :: * -> *). Api (Route m) -> Api (Route m)
fillCaptures Api (Route m)
server)

    getRoute :: Request -> Maybe (Route m, CaptureMap)
getRoute Request
req = do
      normalForm (Route m)
api <- forall a.
ByteString -> ByteString -> ByteString -> ApiNormal a -> Maybe a
fromNormalApi Request
req.method (forall {a} {k} {r}.
(IsString a, Ord k, HasField "headers" r (Map k a)) =>
k -> r -> a
getMediaType HeaderName
"Accept" Request
req) (forall {a} {k} {r}.
(IsString a, Ord k, HasField "headers" r (Map k a)) =>
k -> r -> a
getMediaType HeaderName
"Content-Type" Request
req) ApiNormal (normalForm (Route m))
serverNormal
      FindRoute normalForm m
strategy.getPath Request
req.path normalForm (Route m)
api

    getMediaType :: k -> r -> a
getMediaType k
name r
req = forall a. a -> Maybe a -> a
fromMaybe a
"*/*" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
name r
req.headers

{-| Converts server to server function. Server function can be used to implement low-level handlers
in various server-libraries. This function also uses LRU-cache to cache fetching of
the routes
-}
fromServerWithCache :: forall m normalForm. (MonadIO m) => FindRoute normalForm m -> RouteCache m -> Server m -> ServerFun m
fromServerWithCache :: forall (m :: * -> *) (normalForm :: * -> *).
MonadIO m =>
FindRoute normalForm m -> RouteCache m -> Server m -> ServerFun m
fromServerWithCache FindRoute normalForm m
strategy RouteCache m
cache (Server Api (Route m)
server) = \Request
req -> do
  Maybe (CacheValue m)
mRoute <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
RouteCache m
-> (CacheKey -> Maybe (CacheValue m))
-> CacheKey
-> IO (Maybe (CacheValue m))
withCache RouteCache m
cache CacheKey -> Maybe (CacheValue m)
getRouteCache (Request -> CacheKey
getCacheKey Request
req)
  case Maybe (CacheValue m)
mRoute of
    Just (CacheValue CaptureMap
captureMap Route m
routes) -> Route m
routes.run Request
req{$sel:capture:Request :: CaptureMap
capture = CaptureMap
captureMap}
    Maybe (CacheValue m)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  where
    serverNormal :: ApiNormal (normalForm (Route m))
serverNormal = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FindRoute normalForm m
strategy.toNormalForm forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Api (Route m) -> ApiNormal (Api (Route m))
toNormalApi (forall (m :: * -> *). Api (Route m) -> Api (Route m)
fillCaptures Api (Route m)
server)

    getRouteCache :: CacheKey -> Maybe (CacheValue m)
    getRouteCache :: CacheKey -> Maybe (CacheValue m)
getRouteCache CacheKey
key = do
      normalForm (Route m)
api <- forall a.
ByteString -> ByteString -> ByteString -> ApiNormal a -> Maybe a
fromNormalApi CacheKey
key.method CacheKey
key.outputType CacheKey
key.inputType ApiNormal (normalForm (Route m))
serverNormal
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). CaptureMap -> Route m -> CacheValue m
CacheValue) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FindRoute normalForm m
strategy.getPath CacheKey
key.path normalForm (Route m)
api

getCacheKey :: Request -> CacheKey
getCacheKey :: Request -> CacheKey
getCacheKey Request
req =
  CacheKey
    { $sel:inputType:CacheKey :: ByteString
inputType = HeaderName -> ByteString
getMediaType HeaderName
"Content-Type"
    , $sel:outputType:CacheKey :: ByteString
outputType = HeaderName -> ByteString
getMediaType HeaderName
"Accept"
    , $sel:method:CacheKey :: ByteString
method = Request
req.method
    , $sel:path:CacheKey :: [Text]
path = Request
req.path
    }
  where
    getMediaType :: HeaderName -> ByteString
getMediaType HeaderName
name = forall a. a -> Maybe a -> a
fromMaybe ByteString
"*/*" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderName
name Request
req.headers

{-| Substitutes all stars * for corresponding names in captures
if there are more captures in the route than in the path it adds
additional captures from the route to the path
-}
fillCaptures :: Api (Route m) -> Api (Route m)
fillCaptures :: forall (m :: * -> *). Api (Route m) -> Api (Route m)
fillCaptures = forall {m :: * -> *}. Path -> Int -> Api (Route m) -> Api (Route m)
go forall a. Monoid a => a
mempty Int
0
  where
    go :: Path -> Int -> Api (Route m) -> Api (Route m)
go Path
pathSoFar Int
n = \case
      Api.WithPath Path
path Api (Route m)
api ->
        let (Path
pathNext, Int
m) = forall (m :: * -> *).
Path -> Int -> Path -> Api (Route m) -> (Path, Int)
goPath (Path
pathSoFar forall a. Semigroup a => a -> a -> a
<> Path
path) Int
n Path
path Api (Route m)
api
         in forall a. Path -> Api a -> Api a
Api.WithPath Path
pathNext (Path -> Int -> Api (Route m) -> Api (Route m)
go (Path
pathSoFar forall a. Semigroup a => a -> a -> a
<> Path
path) Int
m Api (Route m)
api)
      Api.Append Api (Route m)
a Api (Route m)
b -> forall a. Api a -> Api a -> Api a
Api.Append (Path -> Int -> Api (Route m) -> Api (Route m)
go Path
pathSoFar Int
n Api (Route m)
a) (Path -> Int -> Api (Route m) -> Api (Route m)
go Path
pathSoFar Int
n Api (Route m)
b)
      Api (Route m)
Api.Empty -> forall a. Api a
Api.Empty
      Api.HandleRoute Route m
a -> forall {a} {m :: * -> *}.
ToHttpApiData a =>
a -> Int -> Route m -> Api (Route m)
goRoute Path
pathSoFar Int
n Route m
a

    goPath :: Api.Path -> Int -> Api.Path -> Api (Route m) -> (Api.Path, Int)
    goPath :: forall (m :: * -> *).
Path -> Int -> Path -> Api (Route m) -> (Path, Int)
goPath Path
pathSoFar Int
n (Api.Path [PathItem]
path) Api (Route m)
api = case [PathItem]
path of
      [] -> ([PathItem] -> Path
Api.Path [PathItem]
path, Int
n)
      Api.CapturePath Text
"*" : [PathItem]
rest ->
        let (Path
nextRest, Int
m) = forall (m :: * -> *).
Path -> Int -> Path -> Api (Route m) -> (Path, Int)
goPath Path
pathSoFar (Int
n forall a. Num a => a -> a -> a
+ Int
1) ([PathItem] -> Path
Api.Path [PathItem]
rest) Api (Route m)
api
         in case forall (m :: * -> *). Int -> Api (Route m) -> Maybe Text
getCaptureName Int
n Api (Route m)
api of
              Just Text
name -> ([PathItem] -> Path
Api.Path [Text -> PathItem
Api.CapturePath Text
name] forall a. Semigroup a => a -> a -> a
<> Path
nextRest, Int
m)
              Maybe Text
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"No capture argument for start in path " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (forall a. ToHttpApiData a => a -> Text
toUrlPiece Path
pathSoFar) forall a. Semigroup a => a -> a -> a
<> String
" at the index: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n
      PathItem
a : [PathItem]
rest ->
        let (Path
nextRest, Int
m) = forall (m :: * -> *).
Path -> Int -> Path -> Api (Route m) -> (Path, Int)
goPath Path
pathSoFar Int
n ([PathItem] -> Path
Api.Path [PathItem]
rest) Api (Route m)
api
         in ([PathItem] -> Path
Api.Path [PathItem
a] forall a. Semigroup a => a -> a -> a
<> Path
nextRest, Int
m)

    goRoute :: a -> Int -> Route m -> Api (Route m)
goRoute a
pathSoFar Int
pathCaptureCount Route m
route
      | Int
missingCapturesCount forall a. Ord a => a -> a -> Bool
> Int
0 = forall {a} {m :: * -> *}.
ToHttpApiData a =>
a -> [Int] -> Api (Route m) -> Api (Route m)
withMissingCaptures a
pathSoFar [Int
pathCaptureCount .. Int
routeCaptureCount forall a. Num a => a -> a -> a
- Int
1] (forall a. a -> Api a
Api.HandleRoute Route m
route)
      | Bool
otherwise = forall a. a -> Api a
Api.HandleRoute Route m
route
      where
        missingCapturesCount :: Int
missingCapturesCount = Int
routeCaptureCount forall a. Num a => a -> a -> a
- Int
pathCaptureCount

        routeCaptureCount :: Int
routeCaptureCount = forall {t :: * -> *} {b} {a} {r}.
(Foldable t, Num b, HasField "content" a RouteInput,
 HasField "inputs" r (t a)) =>
r -> b
captureCount Route m
route.info

    withMissingCaptures :: a -> [Int] -> Api (Route m) -> Api (Route m)
withMissingCaptures a
pathSoFar [Int]
indexes Api (Route m)
route =
      forall a. Path -> Api a -> Api a
Api.WithPath ([PathItem] -> Path
Api.Path forall a b. (a -> b) -> a -> b
$ Text -> PathItem
Api.CapturePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
names) Api (Route m)
route
      where
        names :: [Text]
names =
          forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Not enough captures at path: " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (forall a. ToHttpApiData a => a -> Text
toUrlPiece a
pathSoFar)) forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
index -> forall (m :: * -> *). Int -> Api (Route m) -> Maybe Text
getCaptureName Int
index Api (Route m)
route) [Int]
indexes

    captureCount :: r -> b
captureCount r
routeInfo = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall {r} {a}.
(HasField "content" r RouteInput, Num a) =>
a -> r -> a
count b
0 r
routeInfo.inputs
      where
        count :: a -> r -> a
count a
res r
inp = case r
inp.content of
          CaptureInput Text
_ Schema
_ -> a
1 forall a. Num a => a -> a -> a
+ a
res
          RouteInput
_ -> a
res

getCaptureName :: Int -> Api (Route m) -> Maybe Text
getCaptureName :: forall (m :: * -> *). Int -> Api (Route m) -> Maybe Text
getCaptureName Int
index = \case
  Api.Append Api (Route m)
a Api (Route m)
_b -> Api (Route m) -> Maybe Text
rec Api (Route m)
a
  Api (Route m)
Api.Empty -> forall a. Maybe a
Nothing
  Api.WithPath Path
_ Api (Route m)
a -> Api (Route m) -> Maybe Text
rec Api (Route m)
a
  Api.HandleRoute Route m
a -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RouteInput -> Maybe Text
toCapture forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Describe a -> a
Describe.content) Route m
a.info.inputs forall a. [a] -> Int -> Maybe a
`atMay` Int
index
  where
    rec :: Api (Route m) -> Maybe Text
rec = forall (m :: * -> *). Int -> Api (Route m) -> Maybe Text
getCaptureName Int
index

    toCapture :: RouteInput -> Maybe Text
    toCapture :: RouteInput -> Maybe Text
toCapture = \case
      CaptureInput Text
name Schema
_ -> forall a. a -> Maybe a
Just Text
name
      RouteInput
_ -> forall a. Maybe a
Nothing

-- | Adds tag to the route
addTag :: Text -> Server m -> Server m
addTag :: forall (m :: * -> *). Text -> Server m -> Server m
addTag Text
tag = forall (m :: * -> *).
(RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo (Text -> RouteInfo -> RouteInfo
insertTag Text
tag)

-- | Sets description of the route
setDescription :: Text -> Server m -> Server m
setDescription :: forall (m :: * -> *). Text -> Server m -> Server m
setDescription Text
desc = forall (m :: * -> *).
(RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo forall a b. (a -> b) -> a -> b
$ \RouteInfo
info -> RouteInfo
info{$sel:description:RouteInfo :: Text
description = Text
desc}

-- | Sets summary of the route
setSummary :: Text -> Server m -> Server m
setSummary :: forall (m :: * -> *). Text -> Server m -> Server m
setSummary Text
val = forall (m :: * -> *).
(RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo forall a b. (a -> b) -> a -> b
$ \RouteInfo
info -> RouteInfo
info{$sel:summary:RouteInfo :: Text
summary = Text
val}

-- | Maps over route API-information
mapRouteInfo :: (RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo :: forall (m :: * -> *).
(RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo RouteInfo -> RouteInfo
f (Server Api (Route m)
srv) = forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Route m
route -> Route m
route{$sel:info:Route :: RouteInfo
info = RouteInfo -> RouteInfo
f Route m
route.info}) Api (Route m)
srv

-- | Adds OpenApi tag to the route
insertTag :: Text -> RouteInfo -> RouteInfo
insertTag :: Text -> RouteInfo -> RouteInfo
insertTag Text
tag RouteInfo
info = RouteInfo
info{$sel:tags:RouteInfo :: [Text]
tags = Text
tag forall a. a -> [a] -> [a]
: RouteInfo
info.tags}

{-| Appends descriptiton for the inputs. It passes pairs for @(input-name, input-description)@.
special name request-body is dedicated to request body input
nd raw-input is dedicated to raw input
-}
describeInputs :: [(Text, Text)] -> Server m -> Server m
describeInputs :: forall (m :: * -> *). [(Text, Text)] -> Server m -> Server m
describeInputs [(Text, Text)]
descs = forall (m :: * -> *).
(RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo ([(Text, Text)] -> RouteInfo -> RouteInfo
describeInfoInputs [(Text, Text)]
descs)

{-| Serves static files. The file path is a path to where to server the file.
The media-type is derived from the extension. There is a special case if we need
to server the file from the rooot of the server we can omit everything from the path
but keep extension. Otherwise it is not able to derive the media type.

It is convenient to use it with function @embedRecursiveDir@ from the library @file-embed@ or @file-embed-lzma@.
-}
staticFiles :: forall m. (MonadIO m) => [(FilePath, ByteString)] -> Server m
staticFiles :: forall (m :: * -> *).
MonadIO m =>
[(String, ByteString)] -> Server m
staticFiles [(String, ByteString)]
files =
  forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ByteString -> Api (Route m)
serveFile) [(String, ByteString)]
files
  where
    serveFile :: String -> ByteString -> Api (Route m)
serveFile String
path ByteString
content =
      forall (m :: * -> *). Server m -> Api (Route m)
unServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(RouteInfo -> RouteInfo) -> Server m -> Server m
mapRouteInfo (MediaType -> RouteInfo -> RouteInfo
setOutputMedia MediaType
media) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$
        ( if forall a. [a] -> Maybe a
headMay String
path forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
'.'
            then forall a. a -> a
id
            else ((forall a. IsString a => String -> a
fromString String
path) `Api.WithPath`)
        )
          (forall a. a -> Api a
Api.HandleRoute (forall a. ToRoute a => a -> Route (MonadOf a)
toRoute (MediaType -> ByteString -> Get m (Resp AnyMedia ByteString)
getFile MediaType
media ByteString
content)))
      where
        media :: MediaType
media = String -> MediaType
getMediaType String
path

    getFile :: MediaType -> ByteString -> Get m (Resp AnyMedia BL.ByteString)
    getFile :: MediaType -> ByteString -> Get m (Resp AnyMedia ByteString)
getFile MediaType
ty ByteString
fileContent =
      forall {k} {k} (method :: k) (m :: k -> *) (a :: k).
m a -> Send method m a
Send 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. IsResp a => ResponseHeaders -> a -> a
addHeaders (MediaType -> ResponseHeaders
setContent MediaType
ty) forall a b. (a -> b) -> a -> b
$
            forall a. IsResp a => RespBody a -> a
ok forall a b. (a -> b) -> a -> b
$
              ByteString -> ByteString
BL.fromStrict ByteString
fileContent

    getMediaType :: FilePath -> MediaType
    getMediaType :: String -> MediaType
getMediaType String
path =
      forall a. a -> Maybe a -> a
fromMaybe MediaType
"application/octet-stream" forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> String
takeExtension String
path) Map String MediaType
extToMimeMap

extToMimeMap :: Map String MediaType
extToMimeMap :: Map String MediaType
extToMimeMap =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (String
".aac", MediaType
"audio/aac") -- AAC audio
    , (String
".abw", MediaType
"application/x-abiword") -- AbiWord document
    , (String
".arc", MediaType
"application/x-freearc") -- Archive document (multiple files embedded)
    , (String
".avif", MediaType
"image/avif") -- AVIF image
    , (String
".avi", MediaType
"video/x-msvideo") -- 	AVI: Audio Video Interleave
    , (String
".azw", MediaType
"application/vnd.amazon.ebook") -- 	Amazon Kindle eBook format
    , (String
".bin", MediaType
"application/octet-stream") -- 	Any kind of binary data
    , (String
".bmp", MediaType
"image/bmp") -- 	Windows OS/2 Bitmap Graphics
    , (String
".bz", MediaType
"application/x-bzip") -- 	BZip archive
    , (String
".bz2", MediaType
"application/x-bzip2") -- 	BZip2 archive
    , (String
".cda", MediaType
"application/x-cdf") -- CD audio
    , (String
".csh", MediaType
"application/x-csh") -- 	C-Shell script
    , (String
".css", MediaType
"text/css") -- 	Cascading Style Sheets (CSS)
    , (String
".csv", MediaType
"text/csv") -- 	Comma-separated values (CSV)
    , (String
".doc", MediaType
"application/msword") -- 	Microsoft Word
    , (String
".docx", MediaType
"application/vnd.openxmlformats-officedocument.wordprocessingml.document") -- 	Microsoft Word (OpenXML)
    , (String
".eot", MediaType
"application/vnd.ms-fontobject") -- 	MS Embedded OpenType fonts
    , (String
".epub", MediaType
"application/epub+zip") -- 	Electronic publication (EPUB)
    , (String
".gz", MediaType
"application/gzip") -- 	GZip Compressed Archive
    , (String
".gif", MediaType
"image/gif") -- 	Graphics Interchange Format (GIF)
    , (String
".htm", MediaType
"text/html") -- , .html	HyperText Markup Language (HTML)
    , (String
".ico", MediaType
"image/vnd.microsoft.icon") -- 	Icon format
    , (String
".ics", MediaType
"text/calendar") -- 	iCalendar format
    , (String
".jar", MediaType
"application/java-archive") -- 	Java Archive (JAR)
    , (String
".jpeg", MediaType
"image/jpeg") -- JPEG images
    , (String
".jpg", MediaType
"image/jpeg") -- JPEG images
    , (String
".js", MediaType
"text/javascript") -- 	JavaScript	 (Specifications: HTML and RFC 9239)
    , (String
".json", MediaType
"application/json") -- 	JSON format
    , (String
".jsonld", MediaType
"application/ld+json") -- 	JSON-LD format
    , (String
".mid", MediaType
"audio/midi") -- 	Musical Instrument Digital Interface (MIDI)	, audio/x-midi
    , (String
".midi", MediaType
"audio/midi") -- 	Musical Instrument Digital Interface (MIDI)	, audio/x-midi
    , (String
".mjs", MediaType
"text/javascript") -- 	JavaScript module
    , (String
".mp3", MediaType
"audio/mpeg") -- 	MP3 audio
    , (String
".mp4", MediaType
"video/mp4") -- MP4 video
    , (String
".mpeg", MediaType
"video/mpeg") -- 	MPEG Video
    , (String
".mpkg", MediaType
"application/vnd.apple.installer+xml") -- 	Apple Installer Package
    , (String
".odp", MediaType
"application/vnd.oasis.opendocument.presentation") -- 	OpenDocument presentation document
    , (String
".ods", MediaType
"application/vnd.oasis.opendocument.spreadsheet") -- 	OpenDocument spreadsheet document
    , (String
".odt", MediaType
"application/vnd.oasis.opendocument.text") -- 	OpenDocument text document
    , (String
".oga", MediaType
"audio/ogg") -- 	OGG audio
    , (String
".ogv", MediaType
"video/ogg") -- 	OGG video
    , (String
".ogx", MediaType
"application/ogg") -- 	OGG
    , (String
".opus", MediaType
"audio/opus") -- Opus audio
    , (String
".otf", MediaType
"font/otf") -- 	OpenType font
    , (String
".png", MediaType
"image/png") -- 	Portable Network Graphics
    , (String
".pdf", MediaType
"application/pdf") -- 	Adobe Portable Document Format (PDF)
    , (String
".php", MediaType
"application/x-httpd-php") -- 	Hypertext Preprocessor (Personal Home Page)
    , (String
".ppt", MediaType
"application/vnd.ms-powerpoint") -- 	Microsoft PowerPoint
    , (String
".pptx", MediaType
"application/vnd.openxmlformats-officedocument.presentationml.presentation") -- 	Microsoft PowerPoint (OpenXML)
    , (String
".rar", MediaType
"application/vnd.rar") -- 	RAR archive
    , (String
".rtf", MediaType
"application/rtf") -- 	Rich Text Format (RTF)
    , (String
".sh", MediaType
"application/x-sh") -- 	Bourne shell script
    , (String
".svg", MediaType
"image/svg+xml") -- 	Scalable Vector Graphics (SVG)
    , (String
".tar", MediaType
"application/x-tar") -- 	Tape Archive (TAR)
    , (String
".tif", MediaType
"image/tiff") -- 	Tagged Image File Format (TIFF)
    , (String
".tiff", MediaType
"image/tiff") -- 	Tagged Image File Format (TIFF)
    , (String
".ts", MediaType
"video/mp2t") -- 	MPEG transport stream
    , (String
".ttf", MediaType
"font/ttf") -- 	TrueType Font
    , (String
".txt", MediaType
"text/plain") -- 	Text, (generally ASCII or ISO 8859-n)
    , (String
".vsd", MediaType
"application/vnd.visio") -- 	Microsoft Visio
    , (String
".wav", MediaType
"audio/wav") -- 	Waveform Audio Format
    , (String
".weba", MediaType
"audio/webm") -- 	WEBM audio
    , (String
".webm", MediaType
"video/webm") -- 	WEBM video
    , (String
".webp", MediaType
"image/webp") -- 	WEBP image
    , (String
".woff", MediaType
"font/woff") -- 	Web Open Font Format (WOFF)
    , (String
".woff2", MediaType
"font/woff2") -- 	Web Open Font Format (WOFF)
    , (String
".xhtml", MediaType
"application/xhtml+xml") -- 	XHTML
    , (String
".xls", MediaType
"application/vnd.ms-excel") -- 	Microsoft Excel
    , (String
".xlsx", MediaType
"application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") -- 	Microsoft Excel (OpenXML)
    , (String
".xml", MediaType
"application/xml") -- 	XML	 is recommended as of RFC 7303 (section 4.1), but text/xml is still used sometimes. You can assign a specific MIME type to a file with .xml extension depending on how its contents are meant to be interpreted. For instance, an Atom feed is application/atom+xml, but application/xml serves as a valid default.
    , (String
".xul", MediaType
"application/vnd.mozilla.xul+xml") -- 	XUL
    , (String
".zip", MediaType
"application/zip") -- 	ZIP archive
    , (String
".3gp", MediaType
"video/3gpp") -- 	3GPP audio/video container	; audio/3gpp if it doesn't contain video
    , (String
".3g2", MediaType
"video/3gpp2") -- 	3GPP2 audio/video container	; audio/3gpp2 if it doesn't contain video
    , (String
".7z", MediaType
"application/x-7z-compressed") -- 	7-zip archive
    ]

{- i wonder what is analog of this function?
-- | Handle errors
handleError ::(Exception a, MonadCatch m) => (a -> Server m) -> Server m -> Server m
handleError handler (Server act) = Server $ \req ->
  (act req) `catch` (\err -> unServer (handler err) req)
-}

{-| Sub-server for a server on given path
it might be usefule to emulate links from one route to another within the server
or reuse part of the server inside another server.
-}
atPath :: forall m. Api.Path -> Server m -> Server m
atPath :: forall (m :: * -> *). Path -> Server m -> Server m
atPath Path
rootPath Server m
rootServer = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall (m :: * -> *). Api (Route m) -> Server m
Server forall a b. (a -> b) -> a -> b
$ Path -> Api (Route m) -> Maybe (Api (Route m))
find Path
rootPath Server m
rootServer.unServer
  where
    find :: Api.Path -> Api (Route m) -> Maybe (Api (Route m))
    find :: Path -> Api (Route m) -> Maybe (Api (Route m))
find (Api.Path [PathItem]
path) Api (Route m)
server = case [PathItem]
path of
      [] -> forall a. a -> Maybe a
Just Api (Route m)
server
      [PathItem]
_ ->
        case Api (Route m)
server of
          Api (Route m)
Api.Empty -> forall a. Maybe a
Nothing
          Api.HandleRoute Route m
_ -> forall a. Maybe a
Nothing
          Api.Append Api (Route m)
a Api (Route m)
b -> Path -> Api (Route m) -> Maybe (Api (Route m))
find ([PathItem] -> Path
Api.Path [PathItem]
path) Api (Route m)
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Path -> Api (Route m) -> Maybe (Api (Route m))
find ([PathItem] -> Path
Api.Path [PathItem]
path) Api (Route m)
b
          Api.WithPath (Api.Path [PathItem]
pathB) Api (Route m)
serverB ->
            forall a b c. (a -> b -> c) -> b -> a -> c
flip Path -> Api (Route m) -> Maybe (Api (Route m))
find Api (Route m)
serverB forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [PathItem] -> [PathItem] -> Maybe Path
matchPath [PathItem]
pathB [PathItem]
path

    matchPath :: [Api.PathItem] -> [Api.PathItem] -> Maybe Api.Path
    matchPath :: [PathItem] -> [PathItem] -> Maybe Path
matchPath [PathItem]
prefix [PathItem]
path = case [PathItem]
prefix of
      [] -> forall a. a -> Maybe a
Just ([PathItem] -> Path
Api.Path [PathItem]
path)
      PathItem
prefixHead : [PathItem]
prefixTail -> do
        (PathItem
pathHead, [PathItem]
pathTail) <- forall a. [a] -> Maybe (a, [a])
List.uncons [PathItem]
path
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (PathItem
prefixHead forall a. Eq a => a -> a -> Bool
== PathItem
pathHead)
        [PathItem] -> [PathItem] -> Maybe Path
matchPath [PathItem]
prefixTail [PathItem]
pathTail

filterPath :: (Api.Path -> Bool) -> Server m -> Server m
filterPath :: forall (m :: * -> *). (Path -> Bool) -> Server m -> Server m
filterPath Path -> Bool
cond (Server Api (Route m)
a) =
  forall (m :: * -> *). Api (Route m) -> Server m
Server (forall a. [(Path, a)] -> Api a
Api.fromFlatApi forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Path -> Bool
cond forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. Api a -> [(Path, a)]
Api.flatApi Api (Route m)
a)

-- | Returns a list of all paths in the server
getServerPaths :: Server m -> [Api.Path]
getServerPaths :: forall (m :: * -> *). Server m -> [Path]
getServerPaths (Server Api (Route m)
a) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Api a -> [(Path, a)]
Api.flatApi (forall (m :: * -> *). Api (Route m) -> Api (Route m)
fillCaptures Api (Route m)
a)

{-| Links one route of the server to another
so that every call to first path is redirected to the second path
-}
addPathLink :: Api.Path -> Api.Path -> Server m -> Server m
addPathLink :: forall (m :: * -> *). Path -> Path -> Server m -> Server m
addPathLink Path
from Path
to Server m
server =
  Server m
server forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *). Api (Route m) -> Server m
Server (forall a. Path -> Api a -> Api a
Api.WithPath Path
from (forall (m :: * -> *). Path -> Server m -> Server m
atPath Path
to Server m
server).unServer)