{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

module Spm.Server
  ( main
  ) where

import Prelude
import Spm.Api
import Servant
import Servant.Server.Experimental.Auth

import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.Warp.Systemd
import Network.Wai.Middleware.RequestLogger

import Network.HTTP.Types

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Attoparsec.Text

import qualified Data.ByteString.Lazy as LBS

import GHC.Generics (Generic)
import Type.Reflection (Typeable)

import Control.Applicative
import Control.Monad
import Control.Arrow
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift

import Control.Lens hiding (Context)

import qualified Data.CaseInsensitive as CI

import System.IO

import Spm.Server.Database

import Database.Persist
import Database.Persist.Postgresql
import Data.Pool

import Control.Monad.Trans.Reader (ReaderT, runReaderT)

import Control.Monad.Logger

import Control.Monad.Morph

import System.Environment

import Control.Monad.Catch (Exception, MonadThrow(..))

import Data.UUID (UUID)
import qualified Data.UUID as UUID

import qualified Data.Aeson as JSON

import System.FilePath ((</>), isRelative)

import Crypto.JOSE.JWK hiding (Context)
import Crypto.JOSE.JWK.Instances ()

import Data.Maybe


hSslClientVerify, hSslClientSDn :: HeaderName
hSslClientVerify = "SSL-Client-Verify"
hSslClientSDn = "SSL-Client-S-DN"


data SSLClientVerify
  = SSLClientVerifySuccess
  | SSLClientVerifyOther Text
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance FromHttpApiData SSLClientVerify where
  parseUrlPiece = (left Text.pack .) . parseOnly $ p <* endOfInput
    where
      p :: Parser SSLClientVerify
      p =   (SSLClientVerifySuccess <$ asciiCI "success")
        <|> (SSLClientVerifyOther <$> takeText)

type instance AuthServerData (AuthProtect "spm_mailbox") = MailMailbox

type SpmServerApi =    Header' '[Required, Strict] "SPM-Domain" MailDomain
                    :> AuthProtect "spm_mailbox"
                    :> SpmApi

spmServerApi :: Proxy SpmServerApi
spmServerApi = Proxy
  
  
requestMailMailbox :: Request -> Either Text MailMailbox
requestMailMailbox req = do
    clientVerify <- getHeader hSslClientVerify
    clientSDN <- getHeader hSslClientSDn

    case clientVerify of
      SSLClientVerifySuccess -> return ()
      o@(SSLClientVerifyOther _) -> Left $ "Expected “SSLClientVerifySuccess”, but got “" <> Text.pack (show o) <> "”"
    spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN

    return $ _Wrapped # spmMailbox
  where 
    getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a
    getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req

    maybeToEither e = maybe (Left e) Right

mailboxAuthHandler :: AuthHandler Request MailMailbox
mailboxAuthHandler = mkAuthHandler handler
  where
    throw401 msg = throwError $ err401 { errBody = LBS.fromStrict $ Text.encodeUtf8 msg }
    handler = either throw401 return . requestMailMailbox

mkSpmRequestLogger :: MonadIO m => m Middleware
mkSpmRequestLogger = liftIO $ mkRequestLogger loggerSettings
  where
    loggerSettings = defaultRequestLoggerSettings
      { destination = Handle stderr
      , outputFormat = ApacheWithSettings $ defaultApacheSettings
          & setApacheUserGetter (preview (_Right . _Wrapped . to (Text.encodeUtf8. CI.original)) . requestMailMailbox)
          & setApacheIPAddrSource FromFallback
      }

data ServerCtx = ServerCtx
  { _sctxSqlPool :: Pool SqlBackend
  , _sctxInstanceId :: UUID
  , _sctxJwkSet :: JWKSet
  } deriving (Generic, Typeable)
makeLenses ''ServerCtx

type Handler' = ReaderT ServerCtx (LoggingT Handler)
type Server' api = ServerT api Handler'

data ServerCtxError
  = ServerCtxNoInstanceId | ServerCtxInvalidInstanceId
  | ServerCtxJwkSetCredentialFileNotRelative
  | ServerCtxNoCredentialsDirectory
  | ServerCtxJwkSetDecodeError String
  | ServerCtxJwkSetEmpty
  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Exception)
  
mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application
mkSpmApp = do
  requestLogger <- mkSpmRequestLogger

  connStr <- liftIO $ maybe mempty (Text.encodeUtf8 . Text.pack) <$> lookupEnv "PGCONNSTR"
  _sctxInstanceId <- maybe (throwM ServerCtxInvalidInstanceId) return . UUID.fromString =<< maybe (throwM ServerCtxNoInstanceId) return =<< liftIO (lookupEnv "SPM_INSTANCE")
  jwksetCredentialFile <- liftIO $ fromMaybe "spm-keys.json" <$> lookupEnv "SPM_KEYS_CREDENTIAL"
  unless (isRelative jwksetCredentialFile) $ throwM ServerCtxJwkSetCredentialFileNotRelative
  credentialsDir <- maybe (throwM ServerCtxNoCredentialsDirectory) return =<< liftIO (lookupEnv "CREDENTIALS_DIRECTORY")
  _sctxJwkSet@(JWKSet jwks) <- either (throwM . ServerCtxJwkSetDecodeError) return =<< liftIO (JSON.eitherDecodeFileStrict' $ credentialsDir </> jwksetCredentialFile)
  when (null jwks) $ throwM ServerCtxJwkSetEmpty

  runStderrLoggingT . withPostgresqlPool connStr 1 $ \_sctxSqlPool -> do
    let
      spmServerContext :: Context (AuthHandler Request MailMailbox ': '[])
      spmServerContext = mailboxAuthHandler :. EmptyContext

      spmServer' = spmServer

    logger <- askLoggerIO
    return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer'
      & requestLogger

spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
spmSql act = do
  sqlPool <- view sctxSqlPool
  withResource sqlPool $ runReaderT act

spmServer :: MailDomain -> MailMailbox -> Server' SpmApi
spmServer _dom mbox = whoami
                 :<|> jwkSet
                 :<|> instanceId
  where
    whoami = do
      Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
      return $ mailboxIdent ^. _Wrapped . re _Wrapped

    jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
  
    instanceId = view sctxInstanceId

main :: IO ()
main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
  where
    systemdSettings = defaultSystemdSettings
      & requireSocketActivation .~ True
    warpSettings = defaultSettings