341 lines
14 KiB
Haskell
341 lines
14 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 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 "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 :: 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 <- 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) => 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)
|