{-# LANGUAGE UndecidableInstances #-}
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
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)
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
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
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)
}
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
}
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
}
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
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
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
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)
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}
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}
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
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}
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)
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")
, (String
".abw", MediaType
"application/x-abiword")
, (String
".arc", MediaType
"application/x-freearc")
, (String
".avif", MediaType
"image/avif")
, (String
".avi", MediaType
"video/x-msvideo")
, (String
".azw", MediaType
"application/vnd.amazon.ebook")
, (String
".bin", MediaType
"application/octet-stream")
, (String
".bmp", MediaType
"image/bmp")
, (String
".bz", MediaType
"application/x-bzip")
, (String
".bz2", MediaType
"application/x-bzip2")
, (String
".cda", MediaType
"application/x-cdf")
, (String
".csh", MediaType
"application/x-csh")
, (String
".css", MediaType
"text/css")
, (String
".csv", MediaType
"text/csv")
, (String
".doc", MediaType
"application/msword")
, (String
".docx", MediaType
"application/vnd.openxmlformats-officedocument.wordprocessingml.document")
, (String
".eot", MediaType
"application/vnd.ms-fontobject")
, (String
".epub", MediaType
"application/epub+zip")
, (String
".gz", MediaType
"application/gzip")
, (String
".gif", MediaType
"image/gif")
, (String
".htm", MediaType
"text/html")
, (String
".ico", MediaType
"image/vnd.microsoft.icon")
, (String
".ics", MediaType
"text/calendar")
, (String
".jar", MediaType
"application/java-archive")
, (String
".jpeg", MediaType
"image/jpeg")
, (String
".jpg", MediaType
"image/jpeg")
, (String
".js", MediaType
"text/javascript")
, (String
".json", MediaType
"application/json")
, (String
".jsonld", MediaType
"application/ld+json")
, (String
".mid", MediaType
"audio/midi")
, (String
".midi", MediaType
"audio/midi")
, (String
".mjs", MediaType
"text/javascript")
, (String
".mp3", MediaType
"audio/mpeg")
, (String
".mp4", MediaType
"video/mp4")
, (String
".mpeg", MediaType
"video/mpeg")
, (String
".mpkg", MediaType
"application/vnd.apple.installer+xml")
, (String
".odp", MediaType
"application/vnd.oasis.opendocument.presentation")
, (String
".ods", MediaType
"application/vnd.oasis.opendocument.spreadsheet")
, (String
".odt", MediaType
"application/vnd.oasis.opendocument.text")
, (String
".oga", MediaType
"audio/ogg")
, (String
".ogv", MediaType
"video/ogg")
, (String
".ogx", MediaType
"application/ogg")
, (String
".opus", MediaType
"audio/opus")
, (String
".otf", MediaType
"font/otf")
, (String
".png", MediaType
"image/png")
, (String
".pdf", MediaType
"application/pdf")
, (String
".php", MediaType
"application/x-httpd-php")
, (String
".ppt", MediaType
"application/vnd.ms-powerpoint")
, (String
".pptx", MediaType
"application/vnd.openxmlformats-officedocument.presentationml.presentation")
, (String
".rar", MediaType
"application/vnd.rar")
, (String
".rtf", MediaType
"application/rtf")
, (String
".sh", MediaType
"application/x-sh")
, (String
".svg", MediaType
"image/svg+xml")
, (String
".tar", MediaType
"application/x-tar")
, (String
".tif", MediaType
"image/tiff")
, (String
".tiff", MediaType
"image/tiff")
, (String
".ts", MediaType
"video/mp2t")
, (String
".ttf", MediaType
"font/ttf")
, (String
".txt", MediaType
"text/plain")
, (String
".vsd", MediaType
"application/vnd.visio")
, (String
".wav", MediaType
"audio/wav")
, (String
".weba", MediaType
"audio/webm")
, (String
".webm", MediaType
"video/webm")
, (String
".webp", MediaType
"image/webp")
, (String
".woff", MediaType
"font/woff")
, (String
".woff2", MediaType
"font/woff2")
, (String
".xhtml", MediaType
"application/xhtml+xml")
, (String
".xls", MediaType
"application/vnd.ms-excel")
, (String
".xlsx", MediaType
"application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
, (String
".xml", MediaType
"application/xml")
, (String
".xul", MediaType
"application/vnd.mozilla.xul+xml")
, (String
".zip", MediaType
"application/zip")
, (String
".3gp", MediaType
"video/3gpp")
, (String
".3g2", MediaType
"video/3gpp2")
, (String
".7z", MediaType
"application/x-7z-compressed")
]
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)
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)
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)