{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Server.Main (runServer, acquireServerResources) where

import Server.Core
import Control.Monad (msum)
import Control.Exception (SomeException, catch)
import Data.Maybe (fromMaybe, isJust)
import System.Environment (lookupEnv)
import Happstack.Server
import Happstack.Server.Compression (compressedResponseFilter)
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified Data.Text as T
import qualified Database.Redis as Redis
import qualified Server.Website.Main as Website
import qualified Server.Api.Main as Api
import qualified Server.Authentication.Main as Authentication

-- TODO: consider adding breadcrumbs (https://getbootstrap.com/docs/4.0/components/breadcrumb/)

runServer :: Int -> IO ()
runServer :: Int -> IO ()
runServer Int
portNumber = do
    ServerConfiguration
serverConfiguration <- IO ServerConfiguration
readServerConfiguration
    ServerResources
serverResources <- ServerConfiguration -> IO ServerResources
acquireServerResources ServerConfiguration
serverConfiguration
    ServerConfiguration -> IO () -> IO ()
forall a b. a -> b -> b
seq ServerConfiguration
serverConfiguration (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Conf -> ServerPartT IO Response -> IO ()
forall a. ToMessage a => Conf -> ServerPartT IO a -> IO ()
simpleHTTP Conf
nullConf { port :: Int
port = Int
portNumber } (ServerConfiguration -> ServerResources -> ServerPartT IO Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources)

handleRoot :: ServerConfiguration -> ServerResources -> ServerPart Response
handleRoot :: ServerConfiguration -> ServerResources -> ServerPartT IO Response
handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources = do
    let cacheControlForAssets :: ServerPartT IO Response -> ServerPartT IO Response
cacheControlForAssets = case ServerConfiguration -> EnvironmentType
serverConfigurationEnvironmentType ServerConfiguration
serverConfiguration of
            EnvironmentType
EnvironmentTypeProd -> (Response -> Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> ServerPartT IO a -> ServerPartT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Response -> Response)
 -> ServerPartT IO Response -> ServerPartT IO Response)
-> (Response -> Response)
-> ServerPartT IO Response
-> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Cache-Control" String
"max-age=600"
            EnvironmentType
_ -> ServerPartT IO Response -> ServerPartT IO Response
forall a. a -> a
id
    String
_ <- ServerPartT IO String
forall (m :: * -> *).
(FilterMonad Response m, MonadPlus m, WebMonad Response m,
 ServerMonad m, MonadFail m) =>
m String
compressedResponseFilter
    [ServerPartT IO Response] -> ServerPartT IO Response
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"docs" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ String -> Response -> ServerPartT IO Response
forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
movedPermanently (String
"documentation/lojbanios-0.1.0.0/index.html" :: String) (() -> Response
forall a. ToMessage a => a -> Response
toResponse ())
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"documentation" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ Browsing -> [String] -> String -> ServerPartT IO Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [String] -> String -> m Response
serveDirectory Browsing
EnableBrowsing [] String
"documentation"
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"static" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerPartT IO Response -> ServerPartT IO Response
cacheControlForAssets (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ Browsing -> [String] -> String -> ServerPartT IO Response
forall (m :: * -> *).
(WebMonad Response m, ServerMonad m, FilterMonad Response m,
 MonadIO m, MonadPlus m) =>
Browsing -> [String] -> String -> m Response
serveDirectory Browsing
EnableBrowsing [] String
"static"
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"api" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> ServerPartT IO Response
Api.handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"oauth2" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> ServerPartT IO Response
Authentication.handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"authentication" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerConfiguration -> ServerResources -> ServerPartT IO Response
Authentication.handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"favicon.ico" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerPartT IO Response -> ServerPartT IO Response
cacheControlForAssets (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ (String -> ServerPartT IO String)
-> String -> ServerPartT IO Response
forall (m :: * -> *).
(ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>
(String -> m String) -> String -> m Response
serveFile (String -> String -> ServerPartT IO String
forall (m :: * -> *). Monad m => String -> String -> m String
asContentType String
"image/png") String
"static/images/favicon.png"
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"manifest.webmanifest" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerPartT IO Response -> ServerPartT IO Response
cacheControlForAssets (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ (String -> ServerPartT IO String)
-> String -> ServerPartT IO Response
forall (m :: * -> *).
(ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>
(String -> m String) -> String -> m Response
serveFile (String -> String -> ServerPartT IO String
forall (m :: * -> *). Monad m => String -> String -> m String
asContentType String
"text/json") String
"static/pwa/manifest.webmanifest"
        , String -> ServerPartT IO Response -> ServerPartT IO Response
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir String
"pwabuilder-sw.js" (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ ServerPartT IO Response -> ServerPartT IO Response
cacheControlForAssets (ServerPartT IO Response -> ServerPartT IO Response)
-> ServerPartT IO Response -> ServerPartT IO Response
forall a b. (a -> b) -> a -> b
$ (String -> ServerPartT IO String)
-> String -> ServerPartT IO Response
forall (m :: * -> *).
(ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) =>
(String -> m String) -> String -> m Response
serveFile (String -> String -> ServerPartT IO String
forall (m :: * -> *). Monad m => String -> String -> m String
asContentType String
"text/javascript") String
"static/pwa/pwabuilder-sw.js"
        , ServerConfiguration -> ServerResources -> ServerPartT IO Response
Website.handleRoot ServerConfiguration
serverConfiguration ServerResources
serverResources
        ]

acquireServerResources :: ServerConfiguration -> IO ServerResources
acquireServerResources :: ServerConfiguration -> IO ServerResources
acquireServerResources ServerConfiguration
serverConfiguration = do
    Manager
tlsManager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    let connectInfo :: ConnectInfo
connectInfo = case ServerConfiguration -> EnvironmentType
serverConfigurationEnvironmentType ServerConfiguration
serverConfiguration of
            EnvironmentType
EnvironmentTypeProd ->
                -- For prod, we must always connect over TCP to $LOJBANIOS_REDIS_HOSTNAME
                case ServerConfiguration -> Maybe String
serverConfigurationRedisHostname ServerConfiguration
serverConfiguration of
                        Maybe String
Nothing -> String -> ConnectInfo
forall a. HasCallStack => String -> a
error String
"Running in production. The environment variable LOJBANIOS_REDIS_HOSTNAME must be specified."
                        Just String
redisHostname -> ConnectInfo
Redis.defaultConnectInfo
                            { connectHost :: String
Redis.connectHost = String
redisHostname
                            }
            EnvironmentType
EnvironmentTypeDev ->
                -- For dev, if $LOJBANIOS_REDIS_HOSTNAME is unspecified, we fall back to unix sockets
                case ServerConfiguration -> Maybe String
serverConfigurationRedisHostname ServerConfiguration
serverConfiguration of
                        Maybe String
Nothing -> ConnectInfo
Redis.defaultConnectInfo
                            { connectPort :: PortID
Redis.connectPort = String -> PortID
Redis.UnixSocket String
"/tmp/lojbanios-redis-dev.sock"
                            }
                        Just String
redisHostname -> ConnectInfo
Redis.defaultConnectInfo
                            { connectHost :: String
Redis.connectHost = String
redisHostname
                            }
    Connection
redisConnection <- IO Connection -> (SomeException -> IO Connection) -> IO Connection
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (ConnectInfo -> IO Connection
Redis.checkedConnect ConnectInfo
connectInfo) SomeException -> IO Connection
redisExceptionHandler
    ServerResources -> IO ServerResources
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerResources -> IO ServerResources)
-> ServerResources -> IO ServerResources
forall a b. (a -> b) -> a -> b
$ Manager -> Connection -> ServerResources
ServerResources Manager
tlsManager Connection
redisConnection
    where
        redisExceptionHandler :: SomeException -> IO Redis.Connection
        redisExceptionHandler :: SomeException -> IO Connection
redisExceptionHandler SomeException
ex = String -> IO Connection
forall a. HasCallStack => String -> a
error (String -> IO Connection) -> String -> IO Connection
forall a b. (a -> b) -> a -> b
$ String
"Connection to redis could not be established. If running locally, outside of Docker, please make sure to run './run-redis.sh'.\nException details: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
ex

lookupStringEnvironmentVariable :: String -> IO (Maybe String)
lookupStringEnvironmentVariable :: String -> IO (Maybe String)
lookupStringEnvironmentVariable String
environmentVariableName = String -> IO (Maybe String)
lookupEnv String
environmentVariableName IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    Just String
"" -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    Just String
x -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
x

readServerConfiguration :: IO ServerConfiguration
readServerConfiguration :: IO ServerConfiguration
readServerConfiguration = do
    EnvironmentType
environmentType <- String -> IO (Maybe String)
lookupEnv String
"LOJBANIOS_ENVIRONMENT" IO (Maybe String)
-> (Maybe String -> IO EnvironmentType) -> IO EnvironmentType
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just String
"prod" -> EnvironmentType -> IO EnvironmentType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EnvironmentType
EnvironmentTypeProd
        Just String
"dev" -> EnvironmentType -> IO EnvironmentType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EnvironmentType
EnvironmentTypeDev
        Maybe String
_ -> String -> IO EnvironmentType
forall a. HasCallStack => String -> a
error String
"Error: incorrect or unspecified environment type"
    Maybe String
redisHostname <- String -> IO (Maybe String)
lookupStringEnvironmentVariable String
"LOJBANIOS_REDIS_HOSTNAME"
    Maybe String
openIdMicrosoftClientId <- String -> IO (Maybe String)
lookupStringEnvironmentVariable String
"LOJBANIOS_OPENID_MICROSOFT_CLIENT_ID"
    Maybe String
openIdMicrosoftClientSecret <- String -> IO (Maybe String)
lookupStringEnvironmentVariable String
"LOJBANIOS_OPENID_MICROSOFT_CLIENT_SECRET"
    let identityProviders :: [IdentityProvider]
identityProviders = [[IdentityProvider]] -> [IdentityProvider]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            -- Mock
            [ [Text -> Text -> Text -> IdentityProvider
IdentityProvider Text
"mock" Text
"mock" Text
"/authentication/mock/login/" | EnvironmentType
environmentType EnvironmentType -> EnvironmentType -> Bool
forall a. Eq a => a -> a -> Bool
== EnvironmentType
EnvironmentTypeDev]
            -- Google
            , [Text -> Text -> Text -> IdentityProvider
IdentityProvider Text
"google" Text
"Google" Text
"/oauth2/google/login/"] -- TODO:only if the environment variables are set
            -- Microsoft
            , [(Text -> Text -> Text -> IdentityProvider
IdentityProvider Text
"microsoft" Text
"Microsoft" Text
"/authentication/openid/microsoft/login/") | (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
openIdMicrosoftClientId Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
openIdMicrosoftClientSecret)]
            ]
    ServerConfiguration -> IO ServerConfiguration
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerConfiguration -> IO ServerConfiguration)
-> ServerConfiguration -> IO ServerConfiguration
forall a b. (a -> b) -> a -> b
$ EnvironmentType
-> [IdentityProvider]
-> Maybe String
-> Maybe String
-> Maybe String
-> ServerConfiguration
ServerConfiguration EnvironmentType
environmentType [IdentityProvider]
identityProviders Maybe String
redisHostname Maybe String
openIdMicrosoftClientId Maybe String
openIdMicrosoftClientSecret