datarekisteri/Server/API.hs

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

{-# LANGUAGE NoImplicitPrelude #-}

module Server.API (coreApp, runApp, resolver) where

import Relude hiding (Undefined, void, when)

import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
import Control.Monad.Except (MonadError, throwError)
import Data.Aeson (fromJSON, Result(..), toJSON)
import Data.Morpheus.Server (deriveApp, runApp)
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
import Data.Time (nominalDay)
import Database.Persist (Entity, entityVal, (=.))
import Server.DB
import Server.DB.Queries
import Server.Email (sendVerificationEmail)
import Server.Types
import Server.Utils
import qualified Data.ByteString.Base64 as B64 (encode)
import qualified Data.Text as T (null, chunksOf, intercalate)

-- 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 

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

when :: Monad m => Bool -> m a -> m Unit
when b m = if b then void m else pure Unit

dbUserToUser :: Monad m => Entity DBUser -> User m
dbUserToUser user = let id = entityToID user
                        DBUser {..} = entityVal user
                        Success (MemberData {..}) = fromJSON dBUserMemberData
                        -- Explodes if database doesn't contain needed data
                    in User
                        { id = pure id
                        , email = pure dBUserEmail
                        , pendingEmail = pure dBUserPendingEmail
                        , phoneNumber = pure phoneNumber
                        , name = pure name
                        , nickname = pure $ fromMaybe (error "db contains empty name") $
                            maybe (viaNonEmpty head $ words $ name) Just nickname
                        , birthdate = pure birthdate
                        , homeplace = pure homeplace
                        , registered = pure dBUserRegistered
                        , accepted = pure dBUserAccepted
                        , seceded = pure dBUserSeceded
                        , isMember = pure $ isJust dBUserAccepted && not (isJust dBUserSeceded)
                        , permissions = pure dBUserPermissions
                        , application = pure application
                        }

dbKeyToPGPKey :: (MonadDB m, MonadError GQLError m) => Entity DBKey -> PGPKey m
dbKeyToPGPKey key = let id = entityToID key
                        DBKey {..} = entityVal key
                    in PGPKey
                        { id = pure id
                        , user = getByID (fromDBKey dBKeyUid :: UserID)
                              >>= fmap dbUserToUser . fromMaybeFail ""
                        , pgpKeyData = pure $ base64Encode dBKeyData
                        , expires = pure dBKeyExpires
                        , uploaded = pure dBKeyUploaded
                        , comment = pure dBKeyComment
                        }

dbTokenToToken :: (MonadDB m, MonadError GQLError m) => Entity DBToken -> Token m
dbTokenToToken token = let id = entityToID token
                           DBToken {..} = entityVal token
                       in Token
                           { id = pure id
                           , user = getByID (fromDBKey dBTokenUid :: UserID)
                                 >>= fmap dbUserToUser . fromMaybeFail ""
                           , name = pure dBTokenName
                           , tokenData = pure dBTokenData
                           , comment = pure dBTokenComment
                           , issued = pure dBTokenIssued
                           , expires = pure dBTokenExpires
                           , permissions = pure dBTokenPermissions
                           }

newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
    ApplicationData -> m UserID
newUser (ApplicationData {..}) = do
    time <- currentTime
    verificationExpires <- verificationExpireTime
    secret <- 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"
    let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
    user <- addUser $ DBUser
        { dBUserEmail = Nothing
        , dBUserPendingEmail = Just email
        , dBUserRegistered = time
        , dBUserToBeDeleted = Just $ verificationExpires
        , dBUserPasswordCrypt = passwordHash
        , dBUserPermissions = permissions
        , dBUserAccepted = Nothing
        , dBUserSeceded = Nothing
        , dBUserRejected = Nothing
        , dBUserMemberData = toJSON memberData
        , dBUserEmailVerificationSecret = Just secret
        }
    sendVerificationSecret user
    return user

verificationExpireTime :: MonadTime m => m Time
verificationExpireTime = addTime (7 * nominalDay) <$> currentTime

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

sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => UserID -> m Unit
sendVerificationSecret user = void $ do
    maybeDBUser <- fmap entityVal <$> getByID user
    let email = dBUserPendingEmail =<< maybeDBUser
        secret = dBUserEmailVerificationSecret =<< maybeDBUser
        args = (,) <$> email <*> secret
    maybe (pure ()) (uncurry sendVerificationEmail) args

updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
    UserID -> UpdateData -> m UserID
updateUser user (UpdateData {..}) = do
    hash <- sequence $ hashPassword <$> password
    -- assert stuff valid
    verificationSecretUpdate <- maybe (pure Nothing)
        (const $ Just . (DBUserEmailVerificationSecret =. ) . Just <$> genVerificationSecret) email
    user <- updateUserData user
        (catMaybes [(DBUserPendingEmail =. ) . Just <$> email, verificationSecretUpdate,
            (DBUserPasswordCrypt =.) <$> hash])
        (catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
            SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
    when (isJust email) $ sendVerificationSecret user
    return user

makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
    NewTokenArgs -> UserID -> m TokenID
makeNewToken (NewTokenArgs {..}) user = do
    tokenData <- decodeUtf8 . B64.encode <$> getRandomBytes 128
    time <- currentTime
    permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
    addToken $ DBToken
        { dBTokenUid = toDBKey user
        , dBTokenName = name
        , dBTokenData = tokenData
        , dBTokenComment = fromMaybe "" comment
        , dBTokenIssued = time
        , dBTokenExpires = Nothing
        , dBTokenPermissions = permissions
        }

makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
    KeyData -> UserID -> m KeyID
makeNewKey (KeyData {..}) user = do
    time <- currentTime
    keyData' <- fromMaybeFail "" $ base64Decode keyData
    addKey $ DBKey
        { dBKeyUid = toDBKey user
        , dBKeyData = keyData'
        , dBKeyExpires = expires
        , dBKeyUploaded = time
        , dBKeyComment = fromMaybe "" comment
        , dBKeyIsPrimaryEncryptionKey = True
        }

acceptApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit
acceptApplication user = void $ do
    time <- currentTime
    markAsAccepted user time

rejectApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit
rejectApplication user = void $ do
    time <- currentTime
    markAsRejected user time

resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
resolveQuery = Query
    { users = requirePermission Members ReadOnly >> map (dbUserToUser) <$> getAllUsers
    , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
        fmap dbUserToUser <$> getByID user
    , tokens = \(Arg id) -> targetUser id >>= \user ->
        requirePermission (Tokens user) ReadOnly >> map dbTokenToToken <$> getUserTokens user
    , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> applicants
    , keys = \(Arg id) -> targetUser id >>= \user ->
        requirePermission (Profile user) ReadOnly >> map dbKeyToPGPKey <$> getKeys user
    --, key = \(Arg id) -> resolve (pure id)
    -- TODO is this actually useful
    , primaryKey = \(Arg id) -> targetUser id >>= \user ->
        requirePermission (Profile user) ReadOnly >> getPrimaryKey user >>= pure . fmap dbKeyToPGPKey
    , permissions = currentPermissions
    }

resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
    MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
resolveMutation = Mutation
    { apply = \x -> do
        userID <- newUser x
        maybeUser <- getByID userID
        user <- fromMaybeFail "" maybeUser
        pure $ dbUserToUser user
    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (x < 1) $ throwError "Invalid verification secret"
    , resendVerificationEmail = \(Arg id) -> targetUser id >>= sendVerificationSecret
    , update = \updateData (Arg id) -> targetUser id >>= \user ->
        requirePermission (Profile user) ReadWrite >>
            updateUser user updateData >> getByID user >>= fmap dbUserToUser . fromMaybeFail ""
    , newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
        requirePermission (Profile user) ReadWrite >> makeNewToken args user >>=
            getByID >>= fmap dbTokenToToken . fromMaybeFail ""
    , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
        requirePermission (Profile user) ReadWrite >> makeNewKey args user >>=
            getByID >>= fmap dbKeyToPGPKey . fromMaybeFail ""
    , 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 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)
    , seceded :: m (Maybe Time)
    , permissions :: m Text
    , isMember :: m Bool
    , application :: m Text
    } deriving (Generic, GQLType)

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

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

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

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

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

newtype Cursor = Cursor Text
    deriving (Generic, GQLType, Eq, Show)

data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
    deriving (Generic, GQLType)

data NewTokenArgs = NewTokenArgs
    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe 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]
    , tokens :: Arg "user" (Maybe UserID) -> m [Token m]
    , keys :: Arg "user" (Maybe UserID) -> m [PGPKey m]
    , permissions :: m Text
    --, key :: Arg "id" KeyID -> m (PGPKey m)
    , primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
    } deriving (Generic, GQLType)

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