{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
module Tonatona.Servant
( Tonatona.Servant.run
, runWithHandlers
, redirect
, Config(..)
, Host(..)
, Port
, Protocol(..)
) where
import RIO
import Data.Default (def)
import Data.Kind (Type)
import Network.HTTP.Types.Header
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Port)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger (OutputFormat(..), logStdout, logStdoutDev, mkRequestLogger, outputFormat)
import Network.Wai.Middleware.RequestLogger.JSON (formatAsJSONWithHeaders)
import Servant
import TonaParser (Parser, (.||), argLong, envVar, optionalVal)
import Tonatona (HasConfig(..), HasParser(..))
import qualified Tonatona.Logger as TonaLogger
run ::
forall (api :: Type) env.
(HasServer api '[], HasConfig env Config, HasConfig env TonaLogger.Config)
=> ServerT api (RIO env)
-> RIO env ()
run :: forall api env.
(HasServer api '[], HasConfig env Config, HasConfig env Config) =>
ServerT api (RIO env) -> RIO env ()
run =
forall api env.
(HasServer api '[], HasConfig env Config, HasConfig env Config) =>
(forall a. [Handler (RIO env) a])
-> ServerT api (RIO env) -> RIO env ()
runWithHandlers @api []
runWithHandlers ::
forall (api :: Type) env.
(HasServer api '[], HasConfig env Config, HasConfig env TonaLogger.Config)
=> (forall a. [RIO.Handler (RIO env) a])
-> ServerT api (RIO env)
-> RIO env ()
runWithHandlers :: forall api env.
(HasServer api '[], HasConfig env Config, HasConfig env Config) =>
(forall a. [Handler (RIO env) a])
-> ServerT api (RIO env) -> RIO env ()
runWithHandlers forall a. [Handler (RIO env) a]
handlers ServerT api (RIO env)
servantServer = do
env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
Config
conf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env config. HasConfig env config => env -> config
config
Middleware
loggingMiddleware <- forall env. HasConfig env Config => RIO env Middleware
reqLogMiddleware
let app :: Application
app = forall api env.
HasServer api '[] =>
env
-> (forall a. [Handler (RIO env) a])
-> ServerT api (RIO env)
-> Application
runServant @api env
env forall a. [Handler (RIO env) a]
handlers ServerT api (RIO env)
servantServer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Port -> Application -> IO ()
Warp.run (Config -> Port
port Config
conf) forall a b. (a -> b) -> a -> b
$ Middleware
loggingMiddleware Application
app
runServant ::
forall (api :: Type) env. (HasServer api '[])
=> env
-> (forall a. [RIO.Handler (RIO env) a])
-> ServerT api (RIO env)
-> Application
runServant :: forall api env.
HasServer api '[] =>
env
-> (forall a. [Handler (RIO env) a])
-> ServerT api (RIO env)
-> Application
runServant env
env forall a. [Handler (RIO env) a]
handlers ServerT api (RIO env)
servantServer =
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (forall {k} (t :: k). Proxy t
Proxy @api) forall a b. (a -> b) -> a -> b
$ forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (forall {k} (t :: k). Proxy t
Proxy @api) (forall a. RIO env a -> Handler a
transformation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RIO env a -> RIO env a
t) ServerT api (RIO env)
servantServer
where
t :: forall a. RIO env a -> RIO env a
t :: forall a. RIO env a -> RIO env a
t = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
catches forall a. [Handler (RIO env) a]
handlers
transformation
:: forall a. RIO env a -> Servant.Handler a
transformation :: forall a. RIO env a -> Handler a
transformation RIO env a
action = do
let
ioAction :: IO (Either ServerError a)
ioAction = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env RIO env a
action
Either ServerError a
eitherRes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (Either ServerError a)
ioAction forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ServerError
e :: ServerError) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ServerError
e
case Either ServerError a
eitherRes of
Right a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
Left ServerError
servantErr -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
servantErr
redirect :: ByteString -> RIO env a
redirect :: forall env a. ByteString -> RIO env a
redirect ByteString
redirectLocation =
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
ServerError
err302
{ errHeaders :: [Header]
errHeaders = [(HeaderName
hLocation, ByteString
redirectLocation)]
}
reqLogMiddleware :: (HasConfig env TonaLogger.Config) => RIO env Middleware
reqLogMiddleware :: forall env. HasConfig env Config => RIO env Middleware
reqLogMiddleware = do
TonaLogger.Config {DeployMode
mode :: Config -> DeployMode
mode :: DeployMode
mode, Verbose
verbose :: Config -> Verbose
verbose :: Verbose
verbose} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env config. HasConfig env config => env -> config
config
case (DeployMode
mode, Verbose
verbose) of
(DeployMode
TonaLogger.Development, TonaLogger.Verbose Bool
True) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Middleware
mkLogStdoutVerbose
(DeployMode
TonaLogger.Development, TonaLogger.Verbose Bool
False) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Middleware
logStdoutDev
(DeployMode
_, TonaLogger.Verbose Bool
True) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Middleware
logStdoutDev
(DeployMode
_, TonaLogger.Verbose Bool
False) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Middleware
logStdout
mkLogStdoutVerbose :: IO Middleware
mkLogStdoutVerbose :: IO Middleware
mkLogStdoutVerbose = do
RequestLoggerSettings -> IO Middleware
mkRequestLogger forall a. Default a => a
def
{ outputFormat :: OutputFormat
outputFormat = OutputFormatterWithDetailsAndHeaders -> OutputFormat
CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders
formatAsJSONWithHeaders
}
newtype Host = Host
{ Host -> Text
unHost :: Text
} deriving (Host -> Host -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Host -> Host -> Bool
$c/= :: Host -> Host -> Bool
== :: Host -> Host -> Bool
$c== :: Host -> Host -> Bool
Eq, String -> Host
forall a. (String -> a) -> IsString a
fromString :: String -> Host
$cfromString :: String -> Host
IsString, ReadPrec [Host]
ReadPrec Host
Port -> ReadS Host
ReadS [Host]
forall a.
(Port -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Host]
$creadListPrec :: ReadPrec [Host]
readPrec :: ReadPrec Host
$creadPrec :: ReadPrec Host
readList :: ReadS [Host]
$creadList :: ReadS [Host]
readsPrec :: Port -> ReadS Host
$creadsPrec :: Port -> ReadS Host
Read, Port -> Host -> ShowS
[Host] -> ShowS
Host -> String
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Host] -> ShowS
$cshowList :: [Host] -> ShowS
show :: Host -> String
$cshow :: Host -> String
showsPrec :: Port -> Host -> ShowS
$cshowsPrec :: Port -> Host -> ShowS
Show)
newtype Protocol = Protocol
{ Protocol -> Text
unProtocol :: Text
} deriving (Protocol -> Protocol -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Protocol -> Protocol -> Bool
$c/= :: Protocol -> Protocol -> Bool
== :: Protocol -> Protocol -> Bool
$c== :: Protocol -> Protocol -> Bool
Eq, String -> Protocol
forall a. (String -> a) -> IsString a
fromString :: String -> Protocol
$cfromString :: String -> Protocol
IsString, ReadPrec [Protocol]
ReadPrec Protocol
Port -> ReadS Protocol
ReadS [Protocol]
forall a.
(Port -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Protocol]
$creadListPrec :: ReadPrec [Protocol]
readPrec :: ReadPrec Protocol
$creadPrec :: ReadPrec Protocol
readList :: ReadS [Protocol]
$creadList :: ReadS [Protocol]
readsPrec :: Port -> ReadS Protocol
$creadsPrec :: Port -> ReadS Protocol
Read, Port -> Protocol -> ShowS
[Protocol] -> ShowS
Protocol -> String
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Protocol] -> ShowS
$cshowList :: [Protocol] -> ShowS
show :: Protocol -> String
$cshow :: Protocol -> String
showsPrec :: Port -> Protocol -> ShowS
$cshowsPrec :: Port -> Protocol -> ShowS
Show)
data Config = Config
{ Config -> Host
host :: Host
, Config -> Protocol
protocol :: Protocol
, Config -> Port
port :: Port
}
deriving (Port -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Port -> Config -> ShowS
$cshowsPrec :: Port -> Config -> ShowS
Show)
instance HasParser Host where
parser :: Parser Host
parser = Text -> Host
Host forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. Var a => Description -> Source -> a -> Parser a
optionalVal
Description
"Host name to serve"
(String -> Source
argLong String
"host" Source -> Source -> Source
.|| String -> Source
envVar String
"HOST")
Text
"localhost"
instance HasParser Protocol where
parser :: Parser Protocol
parser = Text -> Protocol
Protocol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. Var a => Description -> Source -> a -> Parser a
optionalVal
Description
"Protocol to serve"
(String -> Source
argLong String
"protocol" Source -> Source -> Source
.|| String -> Source
envVar String
"PROTOCOL")
Text
"http"
portParser :: Parser Port
portParser :: Parser Port
portParser =
forall a. Var a => Description -> Source -> a -> Parser a
optionalVal
Description
"Port to serve"
(String -> Source
argLong String
"port" Source -> Source -> Source
.|| String -> Source
envVar String
"PORT")
Port
8000
instance HasParser Config where
parser :: Parser Config
parser = Host -> Protocol -> Port -> Config
Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasParser a => Parser a
parser
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. HasParser a => Parser a
parser
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Port
portParser