{-# 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)