{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}

{-# LANGUAGE NoImplicitPrelude #-}

module Datarekisteri.Backend.API (coreApp, runApp, resolver) where

import Relude hiding (Undefined, get)

import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
import qualified "base64" Data.ByteString.Base64 as B64

import Control.Monad.Except (MonadError, throwError, catchError)
import Data.Morpheus.Server (deriveApp, runApp)
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)

import qualified Data.Text as T

import Datarekisteri.Backend.Email
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils
import Datarekisteri.Core.Types

-- General functions, maybe migrate to Utils or API.Utils

targetUser :: (MonadError GQLError m, MonadRequest m) => Maybe UserID -> m UserID
targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure

fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
fromMaybeFail txt = maybe (throwError txt) pure

voidU :: Monad m => m a -> m Unit
voidU m = m >> pure Unit

liftDBEither :: MonadError GQLError m => DBEither a -> m a
liftDBEither = either (throwError . fromString) pure

applicationArgsToData :: (MonadTime m, MonadRandom m, MonadPermissions m, MonadError GQLError m) =>
    ApplicationArgs -> m ApplicationData
applicationArgsToData ApplicationArgs {..} = do
    registered <- currentTime
    verificationSecret <- genVerificationSecret
    passwordHash <- hashPassword password
    permissions <- defaultPermissions
    when (T.null name) $ throwError "Name must not be empty"
    when (T.null password) $ throwError "Password must not be empty"
    when (T.null homeplace) $ throwError "Homeplace must not be empty"
    pure ApplicationData {..}

newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
    ApplicationArgs -> m (User m)
newUser args = do
    applicationData <- applicationArgsToData args
    user <- dbAddUser applicationData >>= liftDBEither
    sendVerificationSecret user >>= flip unless (throwError "Sending email verification failed!")
    return $ dbUserToUser user

genVerificationSecret :: MonadRandom m => m Text
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10

sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => DBUser m -> m Bool
sendVerificationSecret DBUser {..} = do
    secret <- dbUserId >>= dbGetEmailVerificationSecret >>= liftDBEither
    pendingEmail <- dbUserPendingEmail
    case (secret, pendingEmail) of
      (Just secret', Just pendingEmail') ->
          sendVerificationEmail secret' pendingEmail' >> pure True
      _ -> pure False

updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
    UpdateArgs -> UserID -> m UpdateData
updateArgsToData UpdateArgs {..} user = do
    when (maybe False T.null name) $ throwError "Name must not be empty"
    when (maybe False T.null password) $ throwError "Password must not be empty"
    when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
    isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
    when (isMember && isJust application) $ throwError "Members can't update their applications"
    passwordHash <- sequence $ hashPassword <$> password
    updateTime <- currentTime
    verificationSecret <- genVerificationSecret
    pure UpdateData {..}

updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
    MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
updateUser user args = do
    updateData@(UpdateData {..}) <- updateArgsToData args user
    updatedUser <- dbUpdateUser updateData >>= liftDBEither
    when (isJust email) $ void $ sendVerificationSecret updatedUser
    pure $ dbUserToUser updatedUser

newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) =>
    NewTokenArgs -> UserID -> m NewTokenData
newTokenArgsToData NewTokenArgs {..} user = do
    tokenData <- B64.encodeBase64 <$> getRandomBytes 128
    issued <- currentTime
    permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
    let expires = Nothing
    pure NewTokenData {..}

makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
    NewTokenArgs -> UserID -> m (Token m)
makeNewToken args user = do
    tokenData <- newTokenArgsToData args user
    fmap dbTokenToToken $ dbAddToken tokenData >>= liftDBEither

newKeyArgsToData :: (MonadTime m, MonadError GQLError m) => NewKeyArgs -> UserID -> m NewKeyData
newKeyArgsToData NewKeyArgs {..} user = do
    uploaded <- currentTime
    keyData <- maybe (throwError "Invalid base64") pure $ base64Decode keyData
    pure NewKeyData {..}

makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
    NewKeyArgs -> UserID -> m (PGPKey m)
makeNewKey args user = do
    newKeyData <- newKeyArgsToData args user
    fmap dbPGPKeyToPGPKey $ dbAddKey newKeyData >>= liftDBEither

acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
acceptApplication user = voidU $ do
    maybeEmail <- dbGetUserEmail user >>= liftDBEither
    case maybeEmail of
      Nothing -> throwError $ "No valid application for " <> show user <> "!"
      Just email -> do
          time <- currentTime
          dbAcceptApplication user time >>= liftDBEither
          sendApplicationAcceptedEmail email

rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
rejectApplication user = voidU $ do
    maybeEmail <- dbGetUserEmail user >>= liftDBEither
    case maybeEmail of
      Nothing -> throwError $ "No valid application for " <> show user <> "!"
      Just email -> do
          dbRejectApplication user
          sendApplicationRejectedEmail email

resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
resolveQuery = Query
    { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers
    , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
        (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
    , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
    , permissions = currentPermissions
    }

resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
    MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
resolveMutation = Mutation
    { apply = newUser
    , verifyEmail = \(Arg secret) -> either (const False) (const True) <$> dbVerifyEmail secret
    , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
        maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
    , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
        requirePermission (Profile user) ReadWrite >> updateUser user updateArgs
    , newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
        requirePermission (Profile user) ReadWrite >> makeNewToken args user
    , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
        requirePermission (Profile user) ReadWrite >> makeNewKey args user
    , accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id
    , reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id
    }

-- ScopedTypeVariables requires explicit forall m.
coreApp :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
    MonadTime m, MonadDB m, MonadPermissions m) => App () m
coreApp = deriveApp resolver

resolver :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
    MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation }

data ApplicationArgs = ApplicationArgs
    { email :: Email
    , phoneNumber :: PhoneNumber
    , password :: Text
    , name :: Text
    , nickname :: Maybe Text
    , birthdate :: Date
    , homeplace :: Text
    , application :: Text
    } deriving (Generic, GQLType, Eq, Show)

data UpdateArgs = UpdateArgs
    { email :: Maybe Email
    , phoneNumber :: Maybe PhoneNumber
    , password :: Maybe Text
    , name :: Maybe Text
    , nickname :: Maybe Text
    , homeplace :: Maybe Text
    , application :: Maybe Text
    } deriving (Generic, GQLType, Eq, Show)

data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
    deriving (Generic, GQLType, Eq, Show)

data NewTokenArgs = NewTokenArgs
    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
    deriving (Generic, GQLType)

data User m = User
    { id :: m UserID
    , email :: m (Maybe Email)
    , pendingEmail :: m (Maybe Email)
    , name :: m Text
    , nickname :: m Text
    , phoneNumber :: m PhoneNumber
    , birthdate :: m Date
    , homeplace :: m Text
    , registered :: m Time
    , accepted :: m (Maybe Time)
    , permissions :: m Text
    , isMember :: m Bool
    , application :: m Text
    , tokens :: m [Token m]
    , keys :: m [PGPKey m]
    , primaryKey :: m (Maybe (PGPKey m))
    } deriving (Generic, GQLType)

data PGPKey m = PGPKey
    { id :: m KeyID
    , pgpKeyData :: m Base64
    , expires :: m (Maybe Time)
    , uploaded :: m Time
    , comment :: m Text
    } deriving (Generic, GQLType)

data Token m = Token
    { id :: m TokenID
    , name :: m (Maybe Text)
    , tokenData :: m Text
    , comment :: m Text
    , issued :: m Time
    , expires :: m (Maybe Time)
    , permissions :: m Text
    } deriving (Generic, GQLType)

data Query m = Query
    { users :: m [User m]
    , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
    , applications :: m [User m]
    , permissions :: m Text
    } deriving (Generic, GQLType)

data Mutation m = Mutation
    { apply :: ApplicationArgs -> m (User m)
    , verifyEmail :: Arg "secret" Text -> m Bool
    , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
    , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
    , newToken :: NewTokenArgs -> m (Token m)
    , newKey :: NewKeyArgs -> m (PGPKey m)
    , accept :: Arg "user" UserID -> m Unit
    , reject :: Arg "user" UserID -> m Unit
    } deriving (Generic, GQLType)

dbUserToUser :: (MonadPermissions m, MonadError GQLError m) => DBUser m -> User m
dbUserToUser DBUser {..} = User
    { id = dbUserId
    , email = dbUserEmail
    , pendingEmail = dbUserPendingEmail
    , name = dbUserName
    , nickname = dbUserNickname
    , phoneNumber = dbUserPhoneNumber
    , birthdate = dbUserBirthdate
    , homeplace = dbUserHomeplace
    , registered = dbUserRegistered
    , accepted = dbUserAccepted
    , permissions = dbUserPermissions
    , isMember = isJust <$> dbUserAccepted
    , application = dbUserApplication
    , tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
    , keys = map dbPGPKeyToPGPKey <$> dbUserKeys
    , primaryKey = fmap dbPGPKeyToPGPKey <$> dbUserPrimaryKey
    }

dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
    { id = dbPGPKeyId
    , pgpKeyData = dbPGPKeyData
    , expires = dbPGPKeyExpires
    , uploaded = dbPGPKeyUploaded
    , comment = dbPGPKeyComment
    }

dbTokenToToken :: Monad m => DBToken m -> Token m
dbTokenToToken DBToken {..} = Token
    { id = dbTokenId
    , name = dbTokenName
    , tokenData = dbTokenData
    , comment = dbTokenComment
    , issued = dbTokenIssued
    , expires = dbTokenExpires
    , permissions = dbTokenPermissions
    }