{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE NoImplicitPrelude #-}

module Datarekisteri.Backend.Sql where

import Relude

import Data.Aeson (Result(..), fromJSON, toJSON)
import Data.Time (nominalDay)
import Database.Persist (Entity(..), (=.))

import Datarekisteri.Backend.Sql.Queries (SqlM, UserUpdate(..))

import qualified Datarekisteri.Backend.Sql.Queries as Sql

import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types

class Monad m => MonadSql m where
    runQuery :: SqlM a -> m a

dbUpdateUser :: MonadSql m => UpdateData -> m (DBEither (DBUser m))
dbUpdateUser UpdateData {..} = do
    let memberDataUpdates = catMaybes
            [ SetUserName <$> name
            , SetUserNickname . Just <$> nickname
            , SetUserHomeplace <$> homeplace
            , SetUserPhoneNumber <$> phoneNumber
            , SetUserApplication <$> application
            ]
        userUpdates = catMaybes
            [ (SqlUserPasswordCrypt =.) <$> passwordHash
            , (SqlUserPermissions =.) <$> permissions
            ]
    sqlUser <- runQuery $ do
        Sql.updateUserData user userUpdates memberDataUpdates
        case email of
          Nothing -> pure ()
          Just newEmail -> do
              Sql.deleteUnverifiedEmail user
              maybeOldEmail <- fmap (sqlEmailEmail . entityVal) <$> Sql.getUserEmail user
              when (maybe True (/= newEmail) maybeOldEmail) $ do
                  verificationID <- Sql.addEmailVerification verificationSecret updateTime
                  void $ Sql.addEmail SqlEmail
                      { sqlEmailUid = fromID user
                      , sqlEmailEmail = newEmail
                      , sqlEmailVid = Just verificationID
                      }
        fromMaybe (error "Inconsistent DB at APIM dbUpdateUser!") <$> Sql.getUser user
    pure $ Right $ sqlUserToDBUser user sqlUser

dbAddUser :: MonadSql m => ApplicationData -> m (DBEither (DBUser m))
dbAddUser ApplicationData {..} = runQuery $ do
    userID <- Sql.addUser SqlUser
        { sqlUserRegistered = registered
        , sqlUserPasswordCrypt = passwordHash
        , sqlUserPermissions = permissions
        , sqlUserAccepted = Nothing
        , sqlUserMemberData = toJSON $ MemberData {..}
        }
    verificationID <- Sql.addEmailVerification verificationSecret (addTime (7*nominalDay) registered)
    void $ Sql.addEmail SqlEmail
        { sqlEmailUid = fromID userID
        , sqlEmailEmail = email
        , sqlEmailVid = Just verificationID
        }
    Right . sqlUserToDBUser userID . fromMaybe (error "") <$> Sql.getUser userID

dbAcceptApplication :: MonadSql m => UserID -> Time -> m (DBEither ())
dbAcceptApplication userID time = do
    marked <- runQuery $ Sql.markAsAccepted userID time
    if marked
       then pure $ Right ()
       else pure $ Left $ "No application with id " <> show userID <> " found!"

dbRejectApplication :: MonadSql m => UserID -> m (DBEither ())
dbRejectApplication userID = do
    deleted <- runQuery $ Sql.deleteApplication userID
    if deleted
       then pure $ Right ()
       else pure $ Left $ "No application with id " <> show userID <> " found!"

dbVerifyEmail :: MonadSql m => Text -> m (DBEither ())
dbVerifyEmail secret = do
    verified <- runQuery $ Sql.verifyEmailSecret secret
    if verified
       then pure $ Right ()
       else pure $ Left $ "Invalid verification secret"

dbAddToken :: MonadSql m => NewTokenData -> m (DBEither (DBToken m))
dbAddToken NewTokenData {..} = do
    (sqlTokenID, sqlToken) <- runQuery $ do
        tokenID <- Sql.addToken SqlToken
            { sqlTokenUid = fromID user
            , sqlTokenName = name
            , sqlTokenData = tokenData
            , sqlTokenComment = fromMaybe "" comment
            , sqlTokenIssued = issued
            , sqlTokenExpires = expires
            , sqlTokenPermissions = permissions
            }
        token <- fromMaybe (error "Inconsistent DB at APIM dbAddToken!") <$> Sql.getToken tokenID
        pure (tokenID, token)
    pure $ Right $ sqlTokenToDBToken sqlTokenID sqlToken

dbAddKey :: MonadSql m => NewKeyData -> m (DBEither (DBPGPKey m))
dbAddKey NewKeyData {..} = do
    (keyID, sqlKey) <- runQuery $ do
        keyID <- Sql.addKey SqlKey
            { sqlKeyUid = fromID user
            , sqlKeyData = keyData
            , sqlKeyExpires = expires
            , sqlKeyUploaded = uploaded
            , sqlKeyComment = fromMaybe "" comment
            , sqlKeyIsPrimaryEncryptionKey = False
            }
        sqlKey <- fromMaybe (error "Inconsistent DB at APIM dbAddKey") <$> Sql.getKey keyID
        pure (keyID, sqlKey)
    pure $ Right $ sqlKeyToDBKey keyID sqlKey

dbGetUser :: MonadSql m => UserID -> m (DBEither (DBUser m))
dbGetUser userID = do
    maybeUser <- runQuery $ Sql.getUser userID
    pure $ case maybeUser of
      Nothing -> Left $ "Invalid user ID"
      Just sqlUser -> Right $ sqlUserToDBUser userID sqlUser

dbGetUserByEmail :: MonadSql m => Email -> m (DBEither (DBUser m))
dbGetUserByEmail email = do
    maybeUser <- runQuery $ Sql.getUserByEmail email
    pure $ case maybeUser of
      Nothing -> Left $ "No user with such email"
      Just userEntity -> Right $ entityToDBUser userEntity

dbGetUsers :: MonadSql m => m [DBUser m]
dbGetUsers = map entityToDBUser <$> runQuery Sql.getAllUsers

dbGetUserTokens :: MonadSql m => UserID -> m (DBEither [DBToken m])
dbGetUserTokens userID = Right . map entityToDBToken <$> runQuery (Sql.getUserTokens userID)

dbGetUserKeys :: MonadSql m => UserID -> m (DBEither [DBPGPKey m])
dbGetUserKeys userID = Right . map entityToDBKey <$> runQuery (Sql.getKeys userID)

dbGetUserPrimaryKey :: MonadSql m => UserID -> m (DBEither (Maybe (DBPGPKey m)))
dbGetUserPrimaryKey userID = Right . fmap entityToDBKey <$> runQuery (Sql.getPrimaryKey userID)

dbGetApplications :: MonadSql m => m [DBUser m]
dbGetApplications = map entityToDBUser <$> runQuery Sql.getApplicants

dbGetEmailVerificationSecret :: MonadSql m => UserID -> m (DBEither (Maybe Text))
dbGetEmailVerificationSecret userID = fmap Right $ runQuery $ Sql.getEmailVerificationSecret userID

dbGetTokenBySecret :: MonadSql m => Text -> m (DBEither (DBToken m))
dbGetTokenBySecret secret = maybe (Left "Invalid secret") Right . fmap entityToDBToken <$>
    runQuery (Sql.getTokenBySecret secret)

entityToDBUser :: MonadSql m => Entity SqlUser -> DBUser m
entityToDBUser (Entity userKey sqlUser) = sqlUserToDBUser (toID userKey) sqlUser

sqlUserToDBUser :: MonadSql m => UserID -> SqlUser -> DBUser m
sqlUserToDBUser userID SqlUser {..} =
    let Success MemberData {..} = fromJSON sqlUserMemberData
     in DBUser
         { dbUserId = pure userID
         , dbUserEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $ Sql.getUserEmail userID
         , dbUserPendingEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $
             Sql.getUserPendingEmail userID
         , dbUserName = pure name
         , dbUserNickname = pure $ fromMaybe (fromMaybe (error "Invalid name in the database") $
             viaNonEmpty head $ words name) nickname
         , dbUserBirthdate = pure birthdate
         , dbUserHomeplace = pure homeplace
         , dbUserApplication = pure application
         , dbUserPhoneNumber = pure phoneNumber
         , dbUserRegistered = pure sqlUserRegistered
         , dbUserAccepted = pure sqlUserAccepted
         , dbUserPermissions = pure sqlUserPermissions
         , dbUserPasswordHash = pure sqlUserPasswordCrypt
         , dbUserTokens = fmap (map entityToDBToken) $ runQuery $ Sql.getUserTokens userID
         , dbUserKeys = fmap (map entityToDBKey) $ runQuery $ Sql.getKeys userID
         , dbUserPrimaryKey = fmap (fmap entityToDBKey) $ runQuery $ Sql.getPrimaryKey userID
         }

entityToDBToken :: MonadSql m => Entity SqlToken -> DBToken m
entityToDBToken (Entity tokenKey sqlToken) = sqlTokenToDBToken (toID tokenKey) sqlToken

sqlTokenToDBToken :: MonadSql m => TokenID -> SqlToken -> DBToken m
sqlTokenToDBToken tokenID SqlToken {..} = DBToken
    { dbTokenId = pure tokenID
    , dbTokenUser =
        let userID = toID sqlTokenUid
         in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlTokenToDBToken!")) $
             runQuery $ Sql.getUser userID
    , dbTokenName = pure sqlTokenName
    , dbTokenData = pure sqlTokenData
    , dbTokenComment = pure sqlTokenComment
    , dbTokenIssued = pure sqlTokenIssued
    , dbTokenExpires = pure sqlTokenExpires
    , dbTokenPermissions = pure sqlTokenPermissions
    }

entityToDBKey :: MonadSql m => Entity SqlKey -> DBPGPKey m
entityToDBKey (Entity keyKey sqlKey) = sqlKeyToDBKey (toID keyKey) sqlKey

sqlKeyToDBKey :: MonadSql m => KeyID -> SqlKey -> DBPGPKey m
sqlKeyToDBKey keyID SqlKey {..} = DBPGPKey
    { dbPGPKeyId = pure keyID
    , dbPGPKeyData = pure $ base64Encode sqlKeyData
    , dbPGPKeyExpires = pure sqlKeyExpires
    , dbPGPKeyUploaded = pure sqlKeyUploaded
    , dbPGPKeyComment = pure sqlKeyComment
    }