{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE NoImplicitPrelude #-}

module Server where

import Relude

import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT)
import Data.Map (findWithDefault)
import Data.Text (toLower, breakOn, stripPrefix)
import Database.Persist (entityVal)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Network.Mail.Mime (renderSendMailCustom, Address(..))
import Network.Wai (Application)
import Network.Wai.Handler.Warp (Port, run)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.Gzip
import Server.API
import Server.DB
import Server.DB.Queries (getUserByEmail, getPermissions, getToken)
import Server.Types
import Server.Utils (checkPassword)
import System.Directory (findExecutable)
import System.Process (callProcess)
import Options.Applicative hiding (header)
import qualified Options.Applicative as O
import Web.Scotty.Trans hiding (readEither)
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
import Paths_datarekisteri

main :: IO ()
main = do
    config <- readConfig >>= checkSendmailPath
    runMigrations (configDbUrl config)
    serverApp config >>= run 3100

readConfig :: IO Config
readConfig = do
    execParser $ info (configOpts <**> helper)
            (fullDesc <> progDesc "Serve a GraphQL API for datarekisteri"
            <> O.header "Backend API server for datarekisteri")

checkSendmailPath :: Config -> IO Config
checkSendmailPath config = do
    sendmailPath <- maybe (error "Sendmail command or file not found!") pure =<<
        findExecutable (configSendmail config)
    pure $ config {configSendmail = sendmailPath}

configOpts :: Parser Config
configOpts = Config
    <$> strOption (long "sendmail" <> short 'm' <> metavar "COMMAND" <> value "sendmail" <> help "Sendmail command")
    <*> (Address
        <$> optional (strOption (long "sender-name" <> short 'n' <> metavar "NAME" <> help "Display name for email address"))
        <*> strOption (long "address" <> short 'a' <> metavar "EMAIL" <> help "Email address to send mail"))
    <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3100 <> help "Port to listen on")
    <*> strOption (long "db-url" <> short 'u' <> metavar "URL" <> value "postgres:///id.rekisteri" <> help "Postgresql database url")

runMigrations :: Text -> IO ()
runMigrations dbUrl = do
    migrationsPath <- getDataFileName "db/migrations"
    callProcess "dbmate" ["--url", toString dbUrl, "--migrations-dir", migrationsPath, "up"]

serverApp :: Config -> IO Application
serverApp config = scottyAppT (runAPIM config) $ do
    middleware $ gzip def
    middleware $ cors $ const $ Just CorsResourcePolicy
        { corsOrigins = Nothing -- all
        , corsMethods = ["POST"]
        , corsRequestHeaders = ["Authorization"]
        , corsExposedHeaders = Nothing
        , corsMaxAge = Just (60*60*24)
        , corsVaryOrigin = False
        , corsRequireOrigin = False
        , corsIgnoreFailures = False
        }
    post "/api" $ do
        maybeAuthorization <- fmap toText <$> header "Authorization"
        let maybeBasic = parseBasic maybeAuthorization
            maybeBearer = parseBearer maybeAuthorization
            auth = case maybeBasic of
                     Just _ -> authBasic maybeBasic
                     Nothing -> authBearer maybeBearer
        auth $ do
            setHeader "Content-Type" "text/json"
            body >>= lift . runApp coreApp >>= raw

data BasicAuth = BasicAuth { emailAddress :: Email, password :: Text } deriving (Show)

data BearerToken = BearerToken Text deriving (Show)

parseBearer :: Maybe Text -> Maybe BearerToken
parseBearer auth = do
    [authType, authData] <- words <$> auth
    guard $ toLower authType == "bearer"
    pure $ BearerToken authData

authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
authBearer Nothing m = m
authBearer (Just (BearerToken bearer)) m = do
    token <- lift $ getToken bearer
    let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal
    flip local m $ \state -> state
        { stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token
        , statePermissions = permissions
        }

parseBasic :: Maybe Text -> Maybe BasicAuth
parseBasic txt = do
    [authType, authData] <- words <$> txt
    guard $ toLower authType == "basic"
    (email, password) <- rightToMaybe $
        breakOn' ":" . decodeUtf8 <$> B64.decodeBase64 (encodeUtf8 authData)
    emailAddress <- toEmail email
    pure $ BasicAuth {..}
        where breakOn' x xs = let (fst, snd) = breakOn x xs
                              in (fst, fromMaybe "" $ stripPrefix x snd)


authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
authBasic Nothing m = m
authBasic (Just basic) m = do
    user <- verifyBasic basic
    permissions <- maybe (pure mempty)
        (fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user
    flip local m $ \state -> state
        { stateCurrentUser = user
        , statePermissions = permissions
        }

-- TODO Refact, no need to convert to id and rerequest permissions
verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
verifyBasic BasicAuth {..} = do
    user <- lift $ getUserByEmail emailAddress
    if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user
       then pure $ entityToID <$> user
       else pure Nothing

newtype APIM a = APIM (ReaderT RequestState IO a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)

data RequestState = RequestState
    { stateCurrentUser :: Maybe UserID
    , statePermissions :: Map Scope Permission
    , stateConfig :: Config
    }

data Config = Config
    { configSendmail :: FilePath
    , configEmailAddress :: Address
    , configPort :: Port
    , configDbUrl :: Text
    }

instance MonadTime APIM where
    currentTime = liftIO currentTime

instance MonadDB APIM where
    runQuery query = do
        dbUrl <- asks $ configDbUrl . stateConfig
        liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query

instance MonadEmail APIM where
    sendEmail email = do
        sendmailPath <- asks $ configSendmail . stateConfig
        liftIO $ renderSendMailCustom sendmailPath ["-t"] email
    fromAddress = asks $ configEmailAddress . stateConfig

instance MonadRequest APIM where
    currentUser = asks stateCurrentUser

instance MonadRandom APIM where
    getRandomBytes = liftIO . getRandomBytes

instance MonadPermissions APIM where
    currentPermissions = show <$> asks statePermissions
    defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission)
    toPermissions = pure . fmap show . readPermission
    hasPermission scope permission = (>= permission) <$> findPermission scope
        where findPermission :: Scope -> APIM Permission
              findPermission scope@(Profile user) = selfPermissions scope user OwnProfile
              findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens
              findPermission scope = findPermission' scope <$> asks statePermissions
              findPermission' :: Scope -> Map Scope Permission -> Permission
              findPermission' = findWithDefault None
              selfPermissions :: Scope -> UserID -> Scope -> APIM Permission
              selfPermissions scope user own = do
                  isSelf <- (Just user ==) <$> currentUser
                  let f = if isSelf then max <$> findPermission' own <*> findPermission' scope
                                    else findPermission' scope

                  f <$> asks statePermissions

readPermission :: Text -> Maybe (Map Scope Permission)
readPermission = rightToMaybe . readEither . toString 

runAPIM :: Config -> APIM a -> IO a
runAPIM config (APIM m) = runReaderT m RequestState
    { stateCurrentUser = Nothing
    , statePermissions = fromList []
    , stateConfig = config
    }