module Mensam.Server.Server where

import Mensam.API.API
import Mensam.Server.Application.Configured.Class
import Mensam.Server.Application.Email.Class
import Mensam.Server.Application.LoggerCustom.Class
import Mensam.Server.Application.Secret.Class
import Mensam.Server.Application.SeldaPool.Class
import Mensam.Server.Configuration
import Mensam.Server.Configuration.BaseUrl
import Mensam.Server.Secrets
import Mensam.Server.Server.Auth
import Mensam.Server.Server.Handler
import Mensam.Server.Server.Handler.RequestHash
import Mensam.Server.Server.Route

import Control.Monad
import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Data.ByteString.Char8 qualified as B
import Data.Kind
import Data.Proxy
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Trans
import Servant.API
import Servant.Auth.Server
import Servant.Server
import Servant.Server.Generic
import System.Posix.Signals
import System.Posix.Signals.Patterns

type WrappedAPI :: Type
type WrappedAPI = RequestHash :> API

type ContextList :: [Type]
type ContextList = '[BasicAuthCfg, CookieSettings, JWTSettings]

hoistServerRunHandlerT :: (MonadIO m, MonadLoggerCustom m) => ServerT API (HandlerT m) -> ServerT WrappedAPI m
hoistServerRunHandlerT :: forall (m :: * -> *).
(MonadIO m, MonadLoggerCustom m) =>
ServerT API (HandlerT m) -> ServerT WrappedAPI m
hoistServerRunHandlerT ServerT API (HandlerT m)
handler Hash
randomHash = Proxy
  ((("api" :> NamedRoutes Routes)
    :<|> ("openapi" :> NamedRoutes Routes))
   :<|> (("static" :> API)
         :<|> (("haddock" :> API)
               :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
-> Proxy '[RunLoginInIO, CookieSettings, JWTSettings]
-> (forall x. HandlerT m x -> m x)
-> ServerT
     ((("api" :> NamedRoutes Routes)
       :<|> ("openapi" :> NamedRoutes Routes))
      :<|> (("static" :> API)
            :<|> (("haddock" :> API)
                  :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
     (HandlerT m)
-> ServerT
     ((("api" :> NamedRoutes Routes)
       :<|> ("openapi" :> NamedRoutes Routes))
      :<|> (("static" :> API)
            :<|> (("haddock" :> API)
                  :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
     m
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy
  ((("api" :> NamedRoutes Routes)
    :<|> ("openapi" :> NamedRoutes Routes))
   :<|> (("static" :> API)
         :<|> (("haddock" :> API)
               :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
-> Proxy '[RunLoginInIO, CookieSettings, JWTSettings]
-> (forall x. m x -> n x)
-> ServerT
     ((("api" :> NamedRoutes Routes)
       :<|> ("openapi" :> NamedRoutes Routes))
      :<|> (("static" :> API)
            :<|> (("haddock" :> API)
                  :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
     m
-> ServerT
     ((("api" :> NamedRoutes Routes)
       :<|> ("openapi" :> NamedRoutes Routes))
      :<|> (("static" :> API)
            :<|> (("haddock" :> API)
                  :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
     n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @API) (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ContextList) (Hash -> HandlerT m x -> m x
forall (m :: * -> *) a.
(MonadIO m, MonadLoggerCustom m) =>
Hash -> HandlerT m a -> m a
runHandlerT Hash
randomHash) ServerT
  ((("api" :> NamedRoutes Routes)
    :<|> ("openapi" :> NamedRoutes Routes))
   :<|> (("static" :> API)
         :<|> (("haddock" :> API)
               :<|> (CaptureAll "segments" Text :> Get '[HTML] Html))))
  (HandlerT m)
ServerT API (HandlerT m)
handler

server :: forall m. (MonadConfigured m, MonadEmail m, MonadLoggerCustom m, MonadMask m, MonadSecret m, MonadSeldaPool m, MonadUnliftIO m) => m ()
server :: forall (m :: * -> *).
(MonadConfigured m, MonadEmail m, MonadLoggerCustom m, MonadMask m,
 MonadSecret m, MonadSeldaPool m, MonadUnliftIO m) =>
m ()
server = do
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Configure warp."
  Settings -> Settings
withPort <- Port -> Settings -> Settings
setPort (Port -> Settings -> Settings)
-> (Configuration -> Port) -> Configuration -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Port
forall a. Enum a => a -> Port
fromEnum (Word16 -> Port)
-> (Configuration -> Word16) -> Configuration -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Word16
configPort (Configuration -> Settings -> Settings)
-> m Configuration -> m (Settings -> Settings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
  Settings -> Settings
withShutdownHandler <- ((forall a. m a -> IO a) -> IO (Settings -> Settings))
-> m (Settings -> Settings)
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Settings -> Settings))
 -> m (Settings -> Settings))
-> ((forall a. m a -> IO a) -> IO (Settings -> Settings))
-> m (Settings -> Settings)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    (Settings -> Settings) -> IO (Settings -> Settings)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Settings -> Settings) -> IO (Settings -> Settings))
-> ((IO () -> IO ()) -> Settings -> Settings)
-> (IO () -> IO ())
-> IO (Settings -> Settings)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler ((IO () -> IO ()) -> IO (Settings -> Settings))
-> (IO () -> IO ()) -> IO (Settings -> Settings)
forall a b. (a -> b) -> a -> b
$ \IO ()
closeSocket -> do
      let catchOnceShutdown :: Signal -> Handler
catchOnceShutdown Signal
sig = IO () -> Handler
CatchOnce (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
            m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Received signal '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show @Signal Signal
sig) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'."
              Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn Text
"Shutdown."
            IO ()
closeSocket
      let installShutdownHandler :: Signal -> IO ()
installShutdownHandler Signal
sig = IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sig (Signal -> Handler
catchOnceShutdown Signal
sig) Maybe SignalSet
forall a. Maybe a
Nothing
      Signal -> IO ()
installShutdownHandler Signal
SIGHUP
      Signal -> IO ()
installShutdownHandler Signal
SIGINT
      Signal -> IO ()
installShutdownHandler Signal
SIGTERM
  let settings :: Settings
settings = Settings -> Settings
withShutdownHandler (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings -> Settings
withPort Settings
defaultSettings

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Configure middleware."
  Middleware
addMiddleware <- MiddlewareT m -> m Middleware
forall (m :: * -> *).
MonadUnliftIO m =>
MiddlewareT m -> m Middleware
runMiddlewareT MiddlewareT m
forall (m :: * -> *).
(MonadConfigured m, MonadLogger m) =>
MiddlewareT m
middleware

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Configure JWT settings."
  JWTSettings
jwtSettings <- JWK -> JWTSettings
mkJwtSettings (JWK -> JWTSettings) -> (Secrets -> JWK) -> Secrets -> JWTSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Secrets -> JWK
secretsJwk (Secrets -> JWTSettings) -> m Secrets -> m JWTSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Secrets
forall (m :: * -> *). MonadSecret m => m Secrets
secrets

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Start server."
  ((forall a. m a -> IO a) -> IO ()) -> m ()
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    Settings -> Application -> IO ()
runSettings Settings
settings (Application -> IO ()) -> Middleware -> Application -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
addMiddleware (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let
        context :: Context ContextList
        context :: Context ContextList
context =
          (m (AuthResult UserAuthenticated)
 -> IO (AuthResult UserAuthenticated))
-> RunLoginInIO
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadSeldaPool m, MonadThrow m) =>
(m (AuthResult UserAuthenticated)
 -> IO (AuthResult UserAuthenticated))
-> RunLoginInIO
MkRunLoginInIO m (AuthResult UserAuthenticated)
-> IO (AuthResult UserAuthenticated)
forall a. m a -> IO a
runInIO
            RunLoginInIO
-> Context '[CookieSettings, JWTSettings]
-> Context '[RunLoginInIO, CookieSettings, JWTSettings]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. CookieSettings
cookieSettings
            CookieSettings
-> Context '[JWTSettings] -> Context '[CookieSettings, JWTSettings]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. JWTSettings
jwtSettings
            JWTSettings -> Context '[] -> Context '[JWTSettings]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext
        runInHandler :: forall a. m a -> Servant.Server.Handler a
        runInHandler :: forall a. m a -> Handler a
runInHandler m a
ma =
          (Either ServerError a -> Handler a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither =<<) (Handler (Either ServerError a) -> Handler a)
-> Handler (Either ServerError a) -> Handler a
forall a b. (a -> b) -> a -> b
$
            IO (Either ServerError a) -> Handler (Either ServerError a)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ServerError a) -> Handler (Either ServerError a))
-> IO (Either ServerError a) -> Handler (Either ServerError a)
forall a b. (a -> b) -> a -> b
$
              m (Either ServerError a) -> IO (Either ServerError a)
forall a. m a -> IO a
runInIO (m (Either ServerError a) -> IO (Either ServerError a))
-> m (Either ServerError a) -> IO (Either ServerError a)
forall a b. (a -> b) -> a -> b
$
                m (Either ServerError a)
-> (SomeException -> m (Either ServerError a))
-> m (Either ServerError a)
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (a -> Either ServerError a
forall a b. b -> Either a b
Right (a -> Either ServerError a) -> m a -> m (Either ServerError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
ma) ((SomeException -> m (Either ServerError a))
 -> m (Either ServerError a))
-> (SomeException -> m (Either ServerError a))
-> m (Either ServerError a)
forall a b. (a -> b) -> a -> b
$
                  \(SomeException
err :: SomeException) -> do
                    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Handler encountered an exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
                    Either ServerError a -> m (Either ServerError a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ServerError a -> m (Either ServerError a))
-> Either ServerError a -> m (Either ServerError a)
forall a b. (a -> b) -> a -> b
$
                      ServerError -> Either ServerError a
forall a b. a -> Either a b
Left
                        ServerError
                          { $sel:errHTTPCode:ServerError :: Port
errHTTPCode = Port
500
                          , $sel:errReasonPhrase:ServerError :: String
errReasonPhrase = String
"Internal Server Error"
                          , $sel:errBody:ServerError :: ByteString
errBody = ByteString
"Encountered an internal error in the HTTP handler."
                          , $sel:errHeaders:ServerError :: [Header]
errHeaders = [Header]
forall a. Monoid a => a
mempty
                          }
      Proxy
  (RequestHash
   :> ((("api" :> NamedRoutes Routes)
        :<|> ("openapi" :> NamedRoutes Routes))
       :<|> (("static" :> API)
             :<|> (("haddock" :> API)
                   :<|> (CaptureAll "segments" Text :> Get '[HTML] Html)))))
-> Context '[RunLoginInIO, CookieSettings, JWTSettings]
-> (forall a. m a -> Handler a)
-> ServerT
     (RequestHash
      :> ((("api" :> NamedRoutes Routes)
           :<|> ("openapi" :> NamedRoutes Routes))
          :<|> (("static" :> API)
                :<|> (("haddock" :> API)
                      :<|> (CaptureAll "segments" Text :> Get '[HTML] Html)))))
     m
-> Application
forall {k} (api :: k) (context :: [*]) (m :: * -> *).
(HasServer api context, ServerContext context) =>
Proxy api
-> Context context
-> (forall x. m x -> Handler x)
-> ServerT api m
-> Application
serveWithContextT (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @WrappedAPI) Context ContextList
Context '[RunLoginInIO, CookieSettings, JWTSettings]
context m x -> Handler x
forall a. m a -> Handler a
runInHandler (ServerT
   (RequestHash
    :> ((("api" :> NamedRoutes Routes)
         :<|> ("openapi" :> NamedRoutes Routes))
        :<|> (("static" :> API)
              :<|> (("haddock" :> API)
                    :<|> (CaptureAll "segments" Text :> Get '[HTML] Html)))))
   m
 -> Application)
-> ServerT
     (RequestHash
      :> ((("api" :> NamedRoutes Routes)
           :<|> ("openapi" :> NamedRoutes Routes))
          :<|> (("static" :> API)
                :<|> (("haddock" :> API)
                      :<|> (CaptureAll "segments" Text :> Get '[HTML] Html)))))
     m
-> Application
forall a b. (a -> b) -> a -> b
$
        ServerT API (HandlerT m) -> ServerT WrappedAPI m
forall (m :: * -> *).
(MonadIO m, MonadLoggerCustom m) =>
ServerT API (HandlerT m) -> ServerT WrappedAPI m
hoistServerRunHandlerT (ServerT API (HandlerT m) -> ServerT WrappedAPI m)
-> ServerT API (HandlerT m) -> ServerT WrappedAPI m
forall a b. (a -> b) -> a -> b
$
          Routes (AsServerT (HandlerT m))
-> ToServant Routes (AsServerT (HandlerT m))
forall (routes :: * -> *) (m :: * -> *).
GenericServant routes (AsServerT m) =>
routes (AsServerT m) -> ToServant routes (AsServerT m)
genericServerT Routes (AsServerT (HandlerT m))
forall (m :: * -> *).
(MonadConfigured m, MonadEmail m, MonadLogger m, MonadSecret m,
 MonadSeldaPool m, MonadUnliftIO m) =>
Routes (AsServerT m)
routes

middleware :: (MonadConfigured m, MonadLogger m) => MiddlewareT m
middleware :: forall (m :: * -> *).
(MonadConfigured m, MonadLogger m) =>
MiddlewareT m
middleware ApplicationT m
application Request
req Response -> m ResponseReceived
resp = do
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Received HTTP request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Request -> String
forall a. Show a => a -> String
show Request
req)
  let
    path :: Text
path = ByteString -> Text
T.decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
req
    found302Builder :: Text -> m ResponseReceived
found302Builder Text
locationPath = do
      BaseUrl
baseUrl <- Configuration -> BaseUrl
configBaseUrl (Configuration -> BaseUrl) -> m Configuration -> m BaseUrl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
      let location :: ByteString
location = String -> ByteString
B.pack (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
displayBaseUrlPath BaseUrl
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
locationPath) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
rawQueryString Request
req
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Redirect HTTP request to new location: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ByteString -> String
forall a. Show a => a -> String
show ByteString
location)
      Response -> m ResponseReceived
resp (Response -> m ResponseReceived) -> Response -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [Header] -> Builder -> Response
responseBuilder Status
status302 [(HeaderName
hLocation, ByteString
location)] Builder
forall a. Monoid a => a
mempty
  case Text -> Maybe (Text, Char)
T.unsnoc Text
path of
    Maybe (Text, Char)
Nothing -> Text -> m ResponseReceived
found302Builder Text
"/"
    Just (Text
xs, Char
'/') -> case Text -> Maybe (Text, Char)
T.unsnoc Text
xs of
      Maybe (Text, Char)
Nothing -> ApplicationT m
application Request
req Response -> m ResponseReceived
resp
      Just (Text
_, Char
'/') -> ApplicationT m
application Request
req Response -> m ResponseReceived
resp
      Just (Text
_, Char
_) -> Text -> m ResponseReceived
found302Builder Text
xs
    Maybe (Text, Char)
_ -> ApplicationT m
application Request
req Response -> m ResponseReceived
resp