309 lines
12 KiB
Haskell
309 lines
12 KiB
Haskell
{-# 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
|
|
}
|