{-# 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

{-| Main function.
 -}
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 []

{-| Main function which allows you to pass error handlers.
 -}
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
    }

-- Config

-- | This defines the host part of a URL.
--
-- For example, in the URL https://some.url.com:8090/, the host is
-- @some.url.com@.
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)

-- | This defines the protocol part of a URL.
--
-- For example, in the URL https://some.url.com:8090/, the protocol is
-- @https@.
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