{-# Language UndecidableInstances #-}
module Mig
(
Server (..)
, Json
, Get (..)
, Post (..)
, Put (..)
, Delete (..)
, Patch (..)
, Options (..)
, (/.)
, Capture (..)
, Query (..)
, Optional (..)
, Body (..)
, RawBody (..)
, Header (..)
, FormBody (..)
, PathInfo (..)
, AddHeaders (..)
, SetStatus (..)
, setStatus
, addHeaders
, Error (..)
, handleError
, runServer
, ServerConfig (..)
, toApplication
, HasServer (..)
, fromReader
, ToTextResp (..)
, ToJsonResp (..)
, ToHtmlResp (..)
, FromText (..)
, ToText (..)
, badRequest
, ToServer (..)
, withServerAction
, module X
) where
import Mig.Internal.Types
import Mig.Internal.Types qualified as Resp (Resp (..))
import Web.HttpApiData as X
import Web.FormUrlEncoded as X
import Data.Bifunctor
import Data.Kind
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as TL
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson qualified as Json
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BL
import Text.Blaze.Html (Html)
import Text.Blaze.Html (ToMarkup)
import Text.Read (readMaybe)
import Control.Monad.Reader
import Control.Monad.Except
import GHC.TypeLits
import Data.Proxy
import Data.Map.Strict qualified as Map
import Network.HTTP.Types.Status as X
import Network.HTTP.Types.Method
import Network.HTTP.Types.Header (ResponseHeaders)
import Network.Wai.Handler.Warp qualified as Warp
import Control.Exception (throw)
import Data.Typeable
(/.) :: ToServer a => Text -> a -> Server (ServerMonad a)
/. :: forall a. ToServer a => Text -> a -> Server (ServerMonad a)
(/.) Text
path a
act = forall (m :: * -> *). Monad m => Text -> Server m -> Server m
toWithPath Text
path (forall a. ToServer a => a -> Server (ServerMonad a)
toServer a
act)
infixr 4 /.
hoistServer :: (forall a . m a -> n a) -> Server m -> Server n
hoistServer :: forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> Server m -> Server n
hoistServer forall a. m a -> n a
f (Server Req -> m (Maybe Resp)
act) = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server (forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Req -> m (Maybe Resp)
act)
class FromText a where
fromText :: Text -> Maybe a
instance FromText ByteString where
fromText :: Text -> Maybe ByteString
fromText = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
instance FromText String where
fromText :: Text -> Maybe String
fromText = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance FromText Text where
fromText :: Text -> Maybe Text
fromText = forall a. a -> Maybe a
Just
instance FromText TL.Text where
fromText :: Text -> Maybe Text
fromText = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
instance FromText Word where
fromText :: Text -> Maybe Word
fromText = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance FromText Int where
fromText :: Text -> Maybe Int
fromText = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance FromText Integer where
fromText :: Text -> Maybe Integer
fromText = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance FromText Bool where
fromText :: Text -> Maybe Bool
fromText = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance FromText Float where
fromText :: Text -> Maybe Float
fromText = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
newtype QueryName a = QueryName Text
deriving (String -> QueryName a
forall a. (String -> a) -> IsString a
forall k (a :: k). String -> QueryName a
fromString :: String -> QueryName a
$cfromString :: forall k (a :: k). String -> QueryName a
IsString, QueryName a -> QueryName a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). QueryName a -> QueryName a -> Bool
/= :: QueryName a -> QueryName a -> Bool
$c/= :: forall k (a :: k). QueryName a -> QueryName a -> Bool
== :: QueryName a -> QueryName a -> Bool
$c== :: forall k (a :: k). QueryName a -> QueryName a -> Bool
Eq, QueryName a -> QueryName a -> Bool
QueryName a -> QueryName a -> Ordering
QueryName a -> QueryName a -> QueryName a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (a :: k). Eq (QueryName a)
forall k (a :: k). QueryName a -> QueryName a -> Bool
forall k (a :: k). QueryName a -> QueryName a -> Ordering
forall k (a :: k). QueryName a -> QueryName a -> QueryName a
min :: QueryName a -> QueryName a -> QueryName a
$cmin :: forall k (a :: k). QueryName a -> QueryName a -> QueryName a
max :: QueryName a -> QueryName a -> QueryName a
$cmax :: forall k (a :: k). QueryName a -> QueryName a -> QueryName a
>= :: QueryName a -> QueryName a -> Bool
$c>= :: forall k (a :: k). QueryName a -> QueryName a -> Bool
> :: QueryName a -> QueryName a -> Bool
$c> :: forall k (a :: k). QueryName a -> QueryName a -> Bool
<= :: QueryName a -> QueryName a -> Bool
$c<= :: forall k (a :: k). QueryName a -> QueryName a -> Bool
< :: QueryName a -> QueryName a -> Bool
$c< :: forall k (a :: k). QueryName a -> QueryName a -> Bool
compare :: QueryName a -> QueryName a -> Ordering
$ccompare :: forall k (a :: k). QueryName a -> QueryName a -> Ordering
Ord, Int -> QueryName a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> QueryName a -> ShowS
forall k (a :: k). [QueryName a] -> ShowS
forall k (a :: k). QueryName a -> String
showList :: [QueryName a] -> ShowS
$cshowList :: forall k (a :: k). [QueryName a] -> ShowS
show :: QueryName a -> String
$cshow :: forall k (a :: k). QueryName a -> String
showsPrec :: Int -> QueryName a -> ShowS
$cshowsPrec :: forall k (a :: k). Int -> QueryName a -> ShowS
Show)
toWithQuery :: ByteString -> (Maybe ByteString -> Server m) -> Server m
toWithQuery :: forall (m :: * -> *).
ByteString -> (Maybe ByteString -> Server m) -> Server m
toWithQuery ByteString
name Maybe ByteString -> Server m
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer (Maybe ByteString -> Server m
act (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
name Req
req.query)) Req
req
withQuery' :: FromHttpApiData a => QueryName a -> (Maybe a -> Server m) -> Server m
withQuery' :: forall a (m :: * -> *).
FromHttpApiData a =>
QueryName a -> (Maybe a -> Server m) -> Server m
withQuery' (QueryName Text
name) Maybe a -> Server m
act = forall (m :: * -> *).
ByteString -> (Maybe ByteString -> Server m) -> Server m
toWithQuery (Text -> ByteString
Text.encodeUtf8 Text
name) forall a b. (a -> b) -> a -> b
$ \Maybe ByteString
mVal ->
let
mArg :: Maybe a
mArg = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
Text.decodeUtf8') forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mVal
in
Maybe a -> Server m
act Maybe a
mArg
withQuery :: (Applicative m, FromHttpApiData a) => QueryName a -> (a -> Server m) -> Server m
withQuery :: forall (m :: * -> *) a.
(Applicative m, FromHttpApiData a) =>
QueryName a -> (a -> Server m) -> Server m
withQuery (QueryName Text
name) a -> Server m
act = forall (m :: * -> *).
ByteString -> (Maybe ByteString -> Server m) -> Server m
toWithQuery (Text -> ByteString
Text.encodeUtf8 Text
name) forall a b. (a -> b) -> a -> b
$ \Maybe ByteString
mVal ->
let
mArg :: Maybe a
mArg = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
Text.decodeUtf8') forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mVal
in
case Maybe a
mArg of
Just a
arg -> a -> Server m
act a
arg
Maybe a
Nothing -> forall (m :: * -> *). Functor m => m Resp -> Server m
toConst (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Resp
badRequest forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse arg: " forall a. Semigroup a => a -> a -> a
<> Text
name)
class Monad m => HasServer m where
type ServerResult m :: Type
renderServer :: Server m -> ServerResult m
instance HasServer IO where
type ServerResult IO = Server IO
renderServer :: Server IO -> ServerResult IO
renderServer = forall a. a -> a
id
instance HasServer (ReaderT env IO) where
type ServerResult (ReaderT env IO) = env -> IO (Server IO)
renderServer :: Server (ReaderT env IO) -> ServerResult (ReaderT env IO)
renderServer Server (ReaderT env IO)
server env
initEnv = forall env. env -> Server (ReaderT env IO) -> IO (Server IO)
fromReader env
initEnv Server (ReaderT env IO)
server
fromReader :: env -> Server (ReaderT env IO) -> IO (Server IO)
fromReader :: forall env. env -> Server (ReaderT env IO) -> IO (Server IO)
fromReader env
env Server (ReaderT env IO)
server =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
env forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \env
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> Server m -> Server n
hoistServer (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
e) Server (ReaderT env IO)
server
instance (Show a, Typeable a) => HasServer (ReaderT env (ExceptT (Error a) IO)) where
type ServerResult (ReaderT env (ExceptT (Error a) IO)) =
(Error a -> Server IO) -> env -> IO (Server IO)
renderServer :: Server (ReaderT env (ExceptT (Error a) IO))
-> ServerResult (ReaderT env (ExceptT (Error a) IO))
renderServer Server (ReaderT env (ExceptT (Error a) IO))
server Error a -> Server IO
handleErr env
initEnv = forall a env.
(Show a, Typeable a) =>
(Error a -> Server IO)
-> env
-> Server (ReaderT env (ExceptT (Error a) IO))
-> IO (Server IO)
fromReaderExcept Error a -> Server IO
handleErr env
initEnv Server (ReaderT env (ExceptT (Error a) IO))
server
fromReaderExcept ::
(Show a, Typeable a) =>
(Error a -> Server IO) ->
env ->
Server (ReaderT env (ExceptT (Error a) IO)) -> IO (Server IO)
fromReaderExcept :: forall a env.
(Show a, Typeable a) =>
(Error a -> Server IO)
-> env
-> Server (ReaderT env (ExceptT (Error a) IO))
-> IO (Server IO)
fromReaderExcept Error a -> Server IO
handleErr env
env Server (ReaderT env (ExceptT (Error a) IO))
server =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a (m :: * -> *).
(Exception a, MonadCatch m) =>
(a -> Server m) -> Server m -> Server m
handleError Error a -> Server IO
handleErr) forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
env forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$
\env
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> Server m -> Server n
hoistServer (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
e) Server (ReaderT env (ExceptT (Error a) IO))
server
data Json
class Monad (ServerMonad a) => ToServer a where
type ServerMonad a :: (Type -> Type)
toServer :: a -> Server (ServerMonad a)
instance Monad m => ToServer (Server m) where
type ServerMonad (Server m) = m
toServer :: Server m -> Server (ServerMonad (Server m))
toServer = forall a. a -> a
id
data SetStatus a = SetStatus
{ forall a. SetStatus a -> Status
status :: Status
, forall a. SetStatus a -> a
content :: a
}
setStatus :: Monad m => Status -> Server m -> Server m
setStatus :: forall (m :: * -> *). Monad m => Status -> Server m -> Server m
setStatus Status
st = forall (m :: * -> *).
Monad m =>
(Resp -> Resp) -> Server m -> Server m
mapResp forall a b. (a -> b) -> a -> b
$ \Resp
resp -> Resp
resp { $sel:status:Resp :: Status
Resp.status = Status
st }
data a =
{ :: ResponseHeaders
, :: a
}
addHeaders :: Monad m => ResponseHeaders -> Server m -> Server m
ResponseHeaders
headers = forall (m :: * -> *).
Monad m =>
(Resp -> Resp) -> Server m -> Server m
mapResp forall a b. (a -> b) -> a -> b
$ \Resp
resp -> Resp
resp { $sel:headers:Resp :: ResponseHeaders
Resp.headers = Resp
resp.headers forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers }
mapResp :: Monad m => (Resp -> Resp) -> Server m -> Server m
mapResp :: forall (m :: * -> *).
Monad m =>
(Resp -> Resp) -> Server m -> Server m
mapResp Resp -> Resp
f (Server Req -> m (Maybe Resp)
act) = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req ->
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 Resp -> Resp
f) forall a b. (a -> b) -> a -> b
$ Req -> m (Maybe Resp)
act Req
req
class ToTextResp a where
toTextResp :: a -> Resp
instance ToTextResp Text where
toTextResp :: Text -> Resp
toTextResp = forall a. ToText a => a -> Resp
text
instance ToTextResp TL.Text where
toTextResp :: Text -> Resp
toTextResp = forall a. ToText a => a -> Resp
text
instance ToTextResp Int where
toTextResp :: Int -> Resp
toTextResp = forall a. ToText a => a -> Resp
text
instance ToTextResp a => ToTextResp (AddHeaders a) where
toTextResp :: AddHeaders a -> Resp
toTextResp (AddHeaders ResponseHeaders
headers a
content) =
Resp
resp { $sel:headers:Resp :: ResponseHeaders
Resp.headers = Resp
resp.headers forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers }
where
resp :: Resp
resp = forall a. ToTextResp a => a -> Resp
toTextResp a
content
instance ToTextResp a => ToTextResp (SetStatus a) where
toTextResp :: SetStatus a -> Resp
toTextResp (SetStatus Status
st a
content) =
Status -> Resp -> Resp
setRespStatus Status
st (forall a. ToTextResp a => a -> Resp
toTextResp a
content)
instance (ToText err, ToTextResp a) => ToTextResp (Either (Error err) a) where
toTextResp :: Either (Error err) a -> Resp
toTextResp = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} {r}.
(ToText a, HasField "body" r a, HasField "status" r Status) =>
r -> Resp
fromError forall a. ToTextResp a => a -> Resp
toTextResp
where
fromError :: r -> Resp
fromError r
err = Status -> Resp -> Resp
setRespStatus r
err.status (forall a. ToText a => a -> Resp
text r
err.body)
class ToJsonResp a where
toJsonResp :: a -> Resp
instance {-# OVERLAPPABLE #-} ToJSON a => ToJsonResp a where
toJsonResp :: a -> Resp
toJsonResp = forall a. ToJSON a => a -> Resp
json
instance ToJsonResp a => ToJsonResp (AddHeaders a) where
toJsonResp :: AddHeaders a -> Resp
toJsonResp (AddHeaders ResponseHeaders
headers a
content) =
Resp
resp { $sel:headers:Resp :: ResponseHeaders
Resp.headers = Resp
resp.headers forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers }
where
resp :: Resp
resp = forall a. ToJsonResp a => a -> Resp
toJsonResp a
content
instance ToJsonResp a => ToJsonResp (SetStatus a) where
toJsonResp :: SetStatus a -> Resp
toJsonResp (SetStatus Status
st a
content) =
Status -> Resp -> Resp
setRespStatus Status
st (forall a. ToJsonResp a => a -> Resp
toJsonResp a
content)
instance (ToJSON err, ToJsonResp a) => ToJsonResp (Either (Error err) a) where
toJsonResp :: Either (Error err) a -> Resp
toJsonResp = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {resp} {r}.
(ToJSON resp, HasField "body" r resp,
HasField "status" r Status) =>
r -> Resp
fromError forall a. ToJsonResp a => a -> Resp
toJsonResp
where
fromError :: r -> Resp
fromError r
err = Status -> Resp -> Resp
setRespStatus r
err.status (forall a. ToJSON a => a -> Resp
json r
err.body)
class ToHtmlResp a where
toHtmlResp :: a -> Resp
instance ToMarkup a => ToHtmlResp a where
toHtmlResp :: a -> Resp
toHtmlResp = forall a. ToMarkup a => a -> Resp
html
instance ToHtmlResp a => ToHtmlResp (AddHeaders a) where
toHtmlResp :: AddHeaders a -> Resp
toHtmlResp (AddHeaders ResponseHeaders
headers a
content) =
Resp
resp { $sel:headers:Resp :: ResponseHeaders
Resp.headers = Resp
resp.headers forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers }
where
resp :: Resp
resp = forall a. ToHtmlResp a => a -> Resp
toHtmlResp a
content
instance ToHtmlResp a => ToHtmlResp (SetStatus a) where
toHtmlResp :: SetStatus a -> Resp
toHtmlResp (SetStatus Status
st a
content) =
Status -> Resp -> Resp
setRespStatus Status
st (forall a. ToHtmlResp a => a -> Resp
toHtmlResp a
content)
instance (ToJSON err, ToHtmlResp a) => ToHtmlResp (Either (Error err) a) where
toHtmlResp :: Either (Error err) a -> Resp
toHtmlResp = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {resp} {r}.
(ToJSON resp, HasField "body" r resp,
HasField "status" r Status) =>
r -> Resp
fromError forall a. ToHtmlResp a => a -> Resp
toHtmlResp
where
fromError :: r -> Resp
fromError r
err = Status -> Resp -> Resp
setRespStatus r
err.status (forall a. ToJSON a => a -> Resp
json r
err.body)
newtype Get ty m a = Get (m a)
instance (Monad m, ToTextResp a) => ToServer (Get Text m a) where
type ServerMonad (Get Text m a) = m
toServer :: Get Text m a -> Server (ServerMonad (Get Text m a))
toServer (Get m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodGet (forall a. ToTextResp a => a -> Resp
toTextResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
instance (Monad m, ToJSON a) => ToServer (Get Json m a) where
type ServerMonad (Get Json m a) = m
toServer :: Get Json m a -> Server (ServerMonad (Get Json m a))
toServer (Get m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodGet (forall a. ToJSON a => a -> Resp
json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
instance (Monad m, ToHtmlResp a) => ToServer (Get Html m a) where
type ServerMonad (Get Html m a) = m
toServer :: Get Html m a -> Server (ServerMonad (Get Html m a))
toServer (Get m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodGet (forall a. ToHtmlResp a => a -> Resp
toHtmlResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
instance (Monad m) => ToServer (Get BL.ByteString m BL.ByteString) where
type ServerMonad (Get BL.ByteString m BL.ByteString) = m
toServer :: Get ByteString m ByteString
-> Server (ServerMonad (Get ByteString m ByteString))
toServer (Get m ByteString
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodGet (ByteString -> Resp
raw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
act)
instance (Monad m) => ToServer (Get ByteString m ByteString) where
type ServerMonad (Get ByteString m ByteString) = m
toServer :: Get ByteString m ByteString
-> Server (ServerMonad (Get ByteString m ByteString))
toServer (Get m ByteString
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodGet (ByteString -> Resp
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
act)
newtype Post ty m a = Post (m a)
instance (Monad m, ToTextResp a) => ToServer (Post Text m a) where
type ServerMonad (Post Text m a) = m
toServer :: Post Text m a -> Server (ServerMonad (Post Text m a))
toServer (Post m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPost forall a b. (a -> b) -> a -> b
$ forall a. ToTextResp a => a -> Resp
toTextResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToJSON a) => ToServer (Post Json m a) where
type ServerMonad (Post Json m a) = m
toServer :: Post Json m a -> Server (ServerMonad (Post Json m a))
toServer (Post m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPost forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Resp
json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToHtmlResp a) => ToServer (Post Html m a) where
type ServerMonad (Post Html m a) = m
toServer :: Post Html m a -> Server (ServerMonad (Post Html m a))
toServer (Post m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPost (forall a. ToHtmlResp a => a -> Resp
toHtmlResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
newtype Put ty m a = Put (m a)
instance (Monad m, ToTextResp a) => ToServer (Put Text m a) where
type ServerMonad (Put Text m a) = m
toServer :: Put Text m a -> Server (ServerMonad (Put Text m a))
toServer (Put m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPut forall a b. (a -> b) -> a -> b
$ forall a. ToTextResp a => a -> Resp
toTextResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToJSON a) => ToServer (Put Json m a) where
type ServerMonad (Put Json m a) = m
toServer :: Put Json m a -> Server (ServerMonad (Put Json m a))
toServer (Put m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPut forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Resp
json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToHtmlResp a) => ToServer (Put Html m a) where
type ServerMonad (Put Html m a) = m
toServer :: Put Html m a -> Server (ServerMonad (Put Html m a))
toServer (Put m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPut (forall a. ToHtmlResp a => a -> Resp
toHtmlResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
newtype Delete ty m a = Delete (m a)
instance (Monad m, ToTextResp a) => ToServer (Delete Text m a) where
type ServerMonad (Delete Text m a) = m
toServer :: Delete Text m a -> Server (ServerMonad (Delete Text m a))
toServer (Delete m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodDelete forall a b. (a -> b) -> a -> b
$ forall a. ToTextResp a => a -> Resp
toTextResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToJSON a) => ToServer (Delete Json m a) where
type ServerMonad (Delete Json m a) = m
toServer :: Delete Json m a -> Server (ServerMonad (Delete Json m a))
toServer (Delete m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodDelete forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Resp
json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToHtmlResp a) => ToServer (Delete Html m a) where
type ServerMonad (Delete Html m a) = m
toServer :: Delete Html m a -> Server (ServerMonad (Delete Html m a))
toServer (Delete m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodDelete (forall a. ToHtmlResp a => a -> Resp
toHtmlResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
newtype Patch ty m a = Patch (m a)
instance (Monad m, ToTextResp a) => ToServer (Patch Text m a) where
type ServerMonad (Patch Text m a) = m
toServer :: Patch Text m a -> Server (ServerMonad (Patch Text m a))
toServer (Patch m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPatch forall a b. (a -> b) -> a -> b
$ forall a. ToTextResp a => a -> Resp
toTextResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToJSON a) => ToServer (Patch Json m a) where
type ServerMonad (Patch Json m a) = m
toServer :: Patch Json m a -> Server (ServerMonad (Patch Json m a))
toServer (Patch m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPatch forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Resp
json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToHtmlResp a) => ToServer (Patch Html m a) where
type ServerMonad (Patch Html m a) = m
toServer :: Patch Html m a -> Server (ServerMonad (Patch Html m a))
toServer (Patch m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodPatch (forall a. ToHtmlResp a => a -> Resp
toHtmlResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
newtype Options ty m a = Options (m a)
instance (Monad m, ToTextResp a) => ToServer (Options Text m a) where
type ServerMonad (Options Text m a) = m
toServer :: Options Text m a -> Server (ServerMonad (Options Text m a))
toServer (Options m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodOptions forall a b. (a -> b) -> a -> b
$ forall a. ToTextResp a => a -> Resp
toTextResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToJSON a) => ToServer (Options Json m a) where
type ServerMonad (Options Json m a) = m
toServer :: Options Json m a -> Server (ServerMonad (Options Json m a))
toServer (Options m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodOptions forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Resp
json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act
instance (Monad m, ToHtmlResp a) => ToServer (Options Html m a) where
type ServerMonad (Options Html m a) = m
toServer :: Options Html m a -> Server (ServerMonad (Options Html m a))
toServer (Options m a
act) = forall (m :: * -> *). Monad m => ByteString -> m Resp -> Server m
toMethod ByteString
methodOptions (forall a. ToHtmlResp a => a -> Resp
toHtmlResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
act)
newtype Query (sym :: Symbol) a = Query a
instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Query sym a -> b) where
type ServerMonad (Query sym a -> b) = ServerMonad b
toServer :: (Query sym a -> b) -> Server (ServerMonad (Query sym a -> b))
toServer Query sym a -> b
act = forall (m :: * -> *) a.
(Applicative m, FromHttpApiData a) =>
QueryName a -> (a -> Server m) -> Server m
withQuery (forall {k} (a :: k). Text -> QueryName a
QueryName (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @sym))) (forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query sym a -> b
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. a -> Query sym a
Query)
newtype Optional (sym :: Symbol) a = Optional (Maybe a)
instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Optional sym a -> b) where
type ServerMonad (Optional sym a -> b) = ServerMonad b
toServer :: (Optional sym a -> b) -> Server (ServerMonad (Optional sym a -> b))
toServer Optional sym a -> b
act = forall a (m :: * -> *).
FromHttpApiData a =>
QueryName a -> (Maybe a -> Server m) -> Server m
withQuery' (forall {k} (a :: k). Text -> QueryName a
QueryName (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @sym))) (forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optional sym a -> b
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. Maybe a -> Optional sym a
Optional)
newtype Capture a = Capture a
instance (FromHttpApiData a, ToServer b) => ToServer (Capture a -> b) where
type ServerMonad (Capture a -> b) = ServerMonad b
toServer :: (Capture a -> b) -> Server (ServerMonad (Capture a -> b))
toServer Capture a -> b
act = forall (m :: * -> *). Monad m => (Text -> Server m) -> Server m
toWithCapture forall a b. (a -> b) -> a -> b
$ \Text
txt ->
case forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
txt of
Right a
val -> forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall a b. (a -> b) -> a -> b
$ Capture a -> b
act forall a b. (a -> b) -> a -> b
$ forall a. a -> Capture a
Capture a
val
Left Text
err -> forall (m :: * -> *). Functor m => m Resp -> Server m
toConst forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Resp
badRequest (Text
"Failed to parse capture: " forall a. Semigroup a => a -> a -> a
<> Text
err)
newtype Body a = Body a
instance (MonadIO (ServerMonad b), FromJSON a, ToServer b) => ToServer (Body a -> b) where
type ServerMonad (Body a -> b) = ServerMonad b
toServer :: (Body a -> b) -> Server (ServerMonad (Body a -> b))
toServer Body a -> b
act = forall (m :: * -> *).
MonadIO m =>
(ByteString -> Server m) -> Server m
toWithBody forall a b. (a -> b) -> a -> b
$ \ByteString
val ->
case forall a. FromJSON a => ByteString -> Either String a
Json.eitherDecode ByteString
val of
Right a
v -> forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall a b. (a -> b) -> a -> b
$ Body a -> b
act forall a b. (a -> b) -> a -> b
$ forall a. a -> Body a
Body a
v
Left String
err -> forall (m :: * -> *). Functor m => m Resp -> Server m
toConst forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Resp
badRequest forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse JSON body: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
newtype RawBody = RawBody BL.ByteString
instance (MonadIO (ServerMonad b), ToServer b) => ToServer (RawBody -> b) where
type ServerMonad (RawBody -> b) = ServerMonad b
toServer :: (RawBody -> b) -> Server (ServerMonad (RawBody -> b))
toServer RawBody -> b
act = forall (m :: * -> *).
MonadIO m =>
(ByteString -> Server m) -> Server m
toWithBody forall a b. (a -> b) -> a -> b
$ forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBody -> b
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RawBody
RawBody
newtype FormBody a = FormBody a
instance (ToServer b, MonadIO (ServerMonad b), FromForm a) => ToServer (FormBody a -> b) where
type ServerMonad (FormBody a -> b) = ServerMonad b
toServer :: (FormBody a -> b) -> Server (ServerMonad (FormBody a -> b))
toServer FormBody a -> b
act = forall a (m :: * -> *).
(FromForm a, MonadIO m) =>
(a -> Server m) -> Server m
toWithFormData (forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormBody a -> b
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FormBody a
FormBody)
newtype (sym :: Symbol) a = (Maybe a)
instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Header sym a -> b) where
type ServerMonad (Header sym a -> b) = ServerMonad b
toServer :: (Header sym a -> b) -> Server (ServerMonad (Header sym a -> b))
toServer Header sym a -> b
act = forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
HeaderName -> (Maybe a -> Server m) -> Server m
toWithHeader (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @sym)) (forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header sym a -> b
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. Maybe a -> Header sym a
Header)
newtype PathInfo = PathInfo [Text]
instance (ToServer b) => ToServer (PathInfo -> b) where
type ServerMonad (PathInfo -> b) = ServerMonad b
toServer :: (PathInfo -> b) -> Server (ServerMonad (PathInfo -> b))
toServer PathInfo -> b
act = forall (m :: * -> *). ([Text] -> Server m) -> Server m
toWithPathInfo (forall a. ToServer a => a -> Server (ServerMonad a)
toServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathInfo -> b
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> PathInfo
PathInfo)
withServerAction :: Monad m => Server m -> m () -> Server m
withServerAction :: forall (m :: * -> *). Monad m => Server m -> m () -> Server m
withServerAction Server m
srv m ()
act = forall (m :: * -> *). (Req -> m (Maybe Resp)) -> Server m
Server forall a b. (a -> b) -> a -> b
$ \Req
req -> do
m ()
act
forall (m :: * -> *). Server m -> Req -> m (Maybe Resp)
unServer Server m
srv Req
req
runServer :: Int -> Server IO -> IO ()
runServer :: Int -> Server IO -> IO ()
runServer Int
port Server IO
server =
Int -> Application -> IO ()
Warp.run Int
port (ServerConfig -> Server IO -> Application
toApplication ServerConfig
config Server IO
server)
where
config :: ServerConfig
config = ServerConfig { $sel:maxBodySize:ServerConfig :: Maybe Int
maxBodySize = forall a. Maybe a
Nothing }