355 lines
15 KiB
Haskell
355 lines
15 KiB
Haskell
{-# 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 NoGeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
|
|
|
|
import Relude hiding (Undefined, void, when, get)
|
|
|
|
import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
|
|
import Control.Monad.Except (MonadError, throwError)
|
|
import Data.Aeson (fromJSON, Result(..), toJSON)
|
|
import Data.Maybe (fromJust)
|
|
import Data.Morpheus.Server (deriveApp, runApp)
|
|
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
|
|
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
|
|
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
|
|
import Datarekisteri.Core.Types
|
|
import Datarekisteri.Backend.DB
|
|
import Datarekisteri.Backend.DB.Queries
|
|
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
|
|
import Datarekisteri.Backend.Types
|
|
import Datarekisteri.Backend.Utils
|
|
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
|
|
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 :: MonadDB m => Entity DBUser -> User m
|
|
dbUserToUser user = let id = entityToID user
|
|
DBUser {..} = entityVal user
|
|
Success (MemberData {..}) = fromJSON dBUserMemberData
|
|
-- XXX: Explodes if database doesn't contain needed data
|
|
in User
|
|
{ id = pure id
|
|
, email = fmap (dBEmailEmail . entityVal) <$> getUserEmail id
|
|
, pendingEmail = fmap (dBEmailEmail . entityVal) <$> getUserPendingEmail id
|
|
, 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
|
|
, isMember = pure $ isJust dBUserAccepted
|
|
, 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
|
|
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
|
|
{ dBUserRegistered = time
|
|
, dBUserPasswordCrypt = passwordHash
|
|
, dBUserPermissions = permissions
|
|
, dBUserAccepted = Nothing
|
|
, dBUserMemberData = toJSON memberData
|
|
}
|
|
verification <- addEmailVerification secret
|
|
email <- addEmail $ DBEmail
|
|
{ dBEmailUid = toDBKey user
|
|
, dBEmailEmail = email
|
|
, dBEmailVid = Just verification
|
|
}
|
|
sendVerificationSecret email
|
|
return user
|
|
|
|
genVerificationSecret :: MonadRandom m => m Text
|
|
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
|
|
|
|
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
|
|
sendVerificationSecret email = void $ do
|
|
maybeDBEmail <- runQuery $ get email
|
|
case maybeDBEmail of
|
|
Nothing -> pure Unit
|
|
Just dbEmail -> do
|
|
case dBEmailVid dbEmail of
|
|
Nothing -> pure Unit
|
|
Just dbVerificationId -> do
|
|
secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId
|
|
let email = dBEmailEmail dbEmail
|
|
void $ sendVerificationEmail secret email
|
|
|
|
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
|
|
UserID -> UpdateData -> m UserID
|
|
updateUser user (UpdateData {..}) = do
|
|
hash <- sequence $ hashPassword <$> password
|
|
-- TODO: assert stuff valid
|
|
user <- updateUserData user
|
|
(catMaybes [(DBUserPasswordCrypt =.) <$> hash])
|
|
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
|
|
SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
|
|
case email of
|
|
Nothing -> pure Unit
|
|
Just email' -> do
|
|
verificationSecret <- genVerificationSecret
|
|
emailKey <- updateEmail user email' verificationSecret
|
|
sendVerificationSecret emailKey
|
|
return user
|
|
|
|
makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
|
|
NewTokenArgs -> UserID -> m TokenID
|
|
makeNewToken (NewTokenArgs {..}) user = do
|
|
tokenData <- B64.encodeBase64 <$> 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, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
|
|
acceptApplication user = void $ do
|
|
maybeEmail <- getUserEmail user
|
|
case maybeEmail of
|
|
Nothing -> throwError $ "No valid application for " <> show user <> "!"
|
|
Just email -> do
|
|
time <- currentTime
|
|
applicationAccepted <- markAsAccepted user time
|
|
when applicationAccepted $
|
|
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
|
|
|
|
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
|
|
rejectApplication user = void $ do
|
|
maybeEmail <- getUserEmail user
|
|
case maybeEmail of
|
|
Nothing -> throwError $ "No valid application for " <> show user <> "!"
|
|
Just email -> do
|
|
applicationDeleted <- deleteApplication user
|
|
when applicationDeleted $
|
|
sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
|
|
|
|
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 (not x) $ throwError "Invalid verification secret"
|
|
, resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
|
|
maybe (pure Unit) (sendVerificationSecret . entityKey)
|
|
, 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)
|
|
, 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)
|