From 3942d547e0a400c8b056f34f0b9d6bab4eeaf44a Mon Sep 17 00:00:00 2001 From: Saku Laesvuori Date: Mon, 2 Oct 2023 17:45:56 +0300 Subject: [PATCH] Abstract SQL table structure from database queries --- backend/datarekisteri-backend.cabal | 10 +- backend/src/Datarekisteri/Backend.hs | 70 +++- backend/src/Datarekisteri/Backend/API.hs | 371 ++++++++---------- backend/src/Datarekisteri/Backend/DB.hs | 117 +----- .../src/Datarekisteri/Backend/DB/Queries.hs | 204 ---------- backend/src/Datarekisteri/Backend/Sql.hs | 209 ++++++++++ .../src/Datarekisteri/Backend/Sql/Queries.hs | 234 +++++++++++ .../src/Datarekisteri/Backend/Sql/Types.hs | 97 +++++ backend/src/Datarekisteri/Backend/Types.hs | 188 ++++++++- backend/src/Datarekisteri/CLI.hs | 54 +-- 10 files changed, 984 insertions(+), 570 deletions(-) delete mode 100644 backend/src/Datarekisteri/Backend/DB/Queries.hs create mode 100644 backend/src/Datarekisteri/Backend/Sql.hs create mode 100644 backend/src/Datarekisteri/Backend/Sql/Queries.hs create mode 100644 backend/src/Datarekisteri/Backend/Sql/Types.hs diff --git a/backend/datarekisteri-backend.cabal b/backend/datarekisteri-backend.cabal index da23b16..33fc992 100644 --- a/backend/datarekisteri-backend.cabal +++ b/backend/datarekisteri-backend.cabal @@ -18,6 +18,7 @@ executable datarekisteri-backend datarekisteri-core, email-validate, esqueleto, + http-types, memory, mime-mail, monad-logger, @@ -45,7 +46,9 @@ executable datarekisteri-backend other-modules: Datarekisteri.Backend.API, Datarekisteri.Backend.DB, - Datarekisteri.Backend.DB.Queries, + Datarekisteri.Backend.Sql, + Datarekisteri.Backend.Sql.Types, + Datarekisteri.Backend.Sql.Queries, Datarekisteri.Backend.Email, Datarekisteri.Backend.Types, Datarekisteri.Backend.Utils, @@ -82,8 +85,9 @@ executable datarekisteri-cli time main-is: Datarekisteri/CLI.hs other-modules: - Datarekisteri.Backend.DB, - Datarekisteri.Backend.DB.Queries, + Datarekisteri.Backend.Sql, + Datarekisteri.Backend.Sql.Types, + Datarekisteri.Backend.Sql.Queries, Datarekisteri.Backend.Types, Datarekisteri.Backend.Utils, hs-source-dirs: src diff --git a/backend/src/Datarekisteri/Backend.hs b/backend/src/Datarekisteri/Backend.hs index 8c03e0e..16b24bf 100644 --- a/backend/src/Datarekisteri/Backend.hs +++ b/backend/src/Datarekisteri/Backend.hs @@ -9,24 +9,25 @@ import Relude import "cryptonite" Crypto.Random (MonadRandom(..)) import Control.Monad.Logger (runStderrLoggingT) +import Control.Monad.Except (catchError) import Data.Map (findWithDefault) import Data.Text (toLower, breakOn, stripPrefix) -import Database.Persist (entityVal) import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn) import Datarekisteri.Core.Types +import Network.HTTP.Types.Status (status500, status401) import Network.Mail.Mime (renderSendMailCustom, Address(..)) import Network.Wai (Application) import Network.Wai.Handler.Warp (Port, run) import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Gzip import Datarekisteri.Backend.API -import Datarekisteri.Backend.DB -import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken) +import qualified Datarekisteri.Backend.Sql as Sql +import Datarekisteri.Backend.Sql (MonadSql) import Datarekisteri.Backend.Types import Datarekisteri.Backend.Utils (checkPassword) import System.Directory (findExecutable) import System.Process (callProcess) -import Options.Applicative hiding (header) +import Options.Applicative hiding (Success, header) import qualified Options.Applicative as O import Web.Scotty.Trans hiding (readEither) import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64) @@ -101,10 +102,15 @@ parseBearer auth = do authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a authBearer Nothing m = m authBearer (Just (BearerToken bearer)) m = do - token <- lift $ getToken bearer - let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal + let getUserPermissions = do + Right DBToken {..} <- lift $ dbGetTokenBySecret bearer + permissions' <- fromMaybe mempty . readPermission <$> lift dbTokenPermissions + DBUser {..} <- lift dbTokenUser + userID <- lift dbUserId + pure (Just userID, permissions') + (user, permissions) <- getUserPermissions `catchError` const (pure (Nothing, mempty)) flip local m $ \state -> state - { stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token + { stateCurrentUser = user , statePermissions = permissions } @@ -123,21 +129,23 @@ parseBasic txt = do authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a authBasic Nothing m = m authBasic (Just basic) m = do - user <- verifyBasic basic - permissions <- maybe (pure mempty) - (fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user + DBUser {..} <- verifyBasic basic + permissions <- readPermission <$> lift dbUserPermissions >>= + fromMaybeFail status500 "Internal server error" + userID <- lift dbUserId flip local m $ \state -> state - { stateCurrentUser = user + { stateCurrentUser = Just userID , statePermissions = permissions } --- TODO Refact, no need to convert to id and rerequest permissions -verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID) +verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM) verifyBasic BasicAuth {..} = do - user <- lift $ getUserByEmail emailAddress - if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user - then pure $ entityToID <$> user - else pure Nothing + Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress + correctPassword <- checkPassword password <$> lift dbUserPasswordHash + if correctPassword + then pure user + else do setHeader "WWW-Authenticate" "Basic realm=\"GraphQL API\", Bearer realm\"GraphQL API\"" + raiseStatus status401 "Wrong password or email" newtype APIM a = APIM (ReaderT RequestState IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState) @@ -158,10 +166,29 @@ data Config = Config instance MonadTime APIM where currentTime = liftIO currentTime -instance MonadDB APIM where +instance MonadSql APIM where runQuery query = do - dbUrl <- asks $ configDbUrl . stateConfig - liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query + dbUrl <- fmap encodeUtf8 $ asks $ configDbUrl . stateConfig + liftIO $ runStderrLoggingT $ withPostgresqlConn dbUrl $ runSqlConn query + +-- TODO: Catch database exceptions into Left values +instance MonadDB APIM where + dbUpdateUser = Sql.dbUpdateUser + dbAddUser = Sql.dbAddUser + dbAcceptApplication = Sql.dbAcceptApplication + dbRejectApplication = Sql.dbRejectApplication + dbVerifyEmail = Sql.dbVerifyEmail + dbAddToken = Sql.dbAddToken + dbAddKey = Sql.dbAddKey + dbGetUser = Sql.dbGetUser + dbGetUserByEmail = Sql.dbGetUserByEmail + dbGetUsers = Sql.dbGetUsers + dbGetUserTokens = Sql.dbGetUserTokens + dbGetUserKeys = Sql.dbGetUserKeys + dbGetUserPrimaryKey = Sql.dbGetUserPrimaryKey + dbGetApplications = Sql.dbGetApplications + dbGetEmailVerificationSecret = Sql.dbGetEmailVerificationSecret + dbGetTokenBySecret = Sql.dbGetTokenBySecret instance MonadEmail APIM where sendEmail email = do @@ -200,3 +227,6 @@ runAPIM config (APIM m) = runReaderT m RequestState , statePermissions = fromList [] , stateConfig = config } + +fromMaybeFail status err Nothing = raiseStatus status err +fromMaybeFail _ _ (Just x) = pure x diff --git a/backend/src/Datarekisteri/Backend/API.hs b/backend/src/Datarekisteri/Backend/API.hs index a3a5948..2f7f161 100644 --- a/backend/src/Datarekisteri/Backend/API.hs +++ b/backend/src/Datarekisteri/Backend/API.hs @@ -18,21 +18,17 @@ module Datarekisteri.Backend.API (coreApp, runApp, resolver) where -import Relude hiding (Undefined, void, when, get) +import Relude hiding (Undefined, get) import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom) -import Control.Monad.Except (MonadError, throwError) -import Data.Aeson (fromJSON, Result(..), toJSON) -import Data.Maybe (fromJust) +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 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.DB import Datarekisteri.Backend.Utils import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64) import qualified Data.Text as T (null, chunksOf, intercalate) @@ -45,210 +41,142 @@ targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) p 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 +voidU :: Monad m => m a -> m Unit +voidU m = m >> pure Unit -when :: Monad m => Bool -> m a -> m Unit -when b m = if b then void m else pure Unit +liftDBEither :: MonadError GQLError m => DBEither a -> m a +liftDBEither = either (throwError . fromString) pure -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 +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" - 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 + 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) => 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 +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) => + 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" + passwordHash <- sequence $ hashPassword <$> password + updateTime <- currentTime + verificationSecret <- genVerificationSecret + pure UpdateData {..} 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 + 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 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 - } + 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) => - 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 - } + 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 = void $ do - maybeEmail <- getUserEmail user +acceptApplication user = voidU $ do + maybeEmail <- dbGetUserEmail user >>= liftDBEither 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 + dbAcceptApplication user time >>= liftDBEither + sendApplicationAcceptedEmail email rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit -rejectApplication user = void $ do - maybeEmail <- getUserEmail user +rejectApplication user = voidU $ do + maybeEmail <- dbGetUserEmail user >>= liftDBEither case maybeEmail of Nothing -> throwError $ "No valid application for " <> show user <> "!" Just email -> do - applicationDeleted <- deleteApplication user - when applicationDeleted $ - sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email + dbRejectApplication user + sendApplicationRejectedEmail email resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m resolveQuery = Query - { users = requirePermission Members ReadOnly >> map (dbUserToUser) <$> getAllUsers + { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers , 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 + (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing) + , tokens = \(Arg id) -> targetUser id >>= \user -> do + requirePermission (Tokens user) ReadOnly + map dbTokenToToken <$> (dbGetUserTokens user >>= liftDBEither) + , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications + , keys = \(Arg id) -> targetUser id >>= \user -> do + requirePermission (Profile user) ReadOnly + map dbPGPKeyToPGPKey <$> (dbGetUserKeys user >>= liftDBEither) --, 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 + , primaryKey = \(Arg id) -> targetUser id >>= \user -> do + requirePermission (Profile user) ReadOnly + fmap dbPGPKeyToPGPKey <$> (dbGetUserPrimaryKey user >>= liftDBEither) , 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 "" + { apply = newUser + , verifyEmail = \(Arg secret) -> voidU $ 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 >>= - getByID >>= fmap dbTokenToToken . fromMaybeFail "" + requirePermission (Profile user) ReadWrite >> makeNewToken args user , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user -> - requirePermission (Profile user) ReadWrite >> makeNewKey args user >>= - getByID >>= fmap dbKeyToPGPKey . fromMaybeFail "" + requirePermission (Profile user) ReadWrite >> makeNewKey args user , accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id , reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id } @@ -262,6 +190,33 @@ 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 + } 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) @@ -298,39 +253,6 @@ data Token m = Token , 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)) @@ -343,12 +265,51 @@ data Query m = Query } deriving (Generic, GQLType) data Mutation m = Mutation - { apply :: ApplicationData -> m (User m) + { apply :: ApplicationArgs -> 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) + , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m) , newToken :: NewTokenArgs -> m (Token m) - , newKey :: KeyData -> m (PGPKey m) + , newKey :: NewKeyArgs -> m (PGPKey m) , accept :: Arg "user" UserID -> m Unit , reject :: Arg "user" UserID -> m Unit } deriving (Generic, GQLType) + +dbUserToUser :: Monad 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 + } + +dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m +dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey + { id = dbPGPKeyId + , user = dbUserToUser <$> dbPGPKeyUser + , pgpKeyData = dbPGPKeyData + , expires = dbPGPKeyExpires + , uploaded = dbPGPKeyUploaded + , comment = dbPGPKeyComment + } + +dbTokenToToken :: Monad m => DBToken m -> Token m +dbTokenToToken DBToken {..} = Token + { id = dbTokenId + , user = dbUserToUser <$> dbTokenUser + , name = dbTokenName + , tokenData = dbTokenData + , comment = dbTokenComment + , issued = dbTokenIssued + , expires = dbTokenExpires + , permissions = dbTokenPermissions + } diff --git a/backend/src/Datarekisteri/Backend/DB.hs b/backend/src/Datarekisteri/Backend/DB.hs index cd24c54..f9c40b5 100644 --- a/backend/src/Datarekisteri/Backend/DB.hs +++ b/backend/src/Datarekisteri/Backend/DB.hs @@ -1,105 +1,24 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +{-# LANGUAGE NoImplicitPrelude #-} module Datarekisteri.Backend.DB where -import Data.ByteString (ByteString) -import Data.Text (Text) -import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings) -import Database.Persist (Entity, Key, entityKey, PersistEntity) -import Database.Persist.Sql (fromSqlKey, toSqlKey) -import Database.Persist.Postgresql.JSON (Value) -import Datarekisteri.Core.Types +import Relude + import Datarekisteri.Backend.Types +import Datarekisteri.Core.Types -mkPersist sqlSettings [persistUpperCase| -DBUser sql=users - registered Time - passwordCrypt PasswordHash - permissions Text - accepted (Maybe Time) - memberData Value sqltype=jsonb +dbGetUserEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email)) +dbGetUserEmail userID = do + userOrErr <- dbGetUser userID + case userOrErr of + Left err -> pure $ Left err + Right DBUser {..} -> Right <$> dbUserEmail - deriving (Show) - -DBEmail sql=emails - uid DBUserId - email Email sqltype=varchar(320) - vid (Maybe DBEmailVerificationId) sql=verification - - UniqueUserVerified uid vid - -- This enables using persistent functions to get unique verified emails. The real - -- constraint is stricter and doesn't allow having more than one null and one non-null - -- verification but it's too complicated for persistent to understand. - - UniqueEmail email - UniqueVerification vid - -DBEmailVerification sql=emailVerifications - secret Text sqltype=varchar(255) - expires Time - - UniqueVerificationSecret secret - -DBKey sql=keys - uid DBUserId - data ByteString - expires (Maybe Time) - uploaded Time - comment Text - isPrimaryEncryptionKey Bool - -DBToken sql=tokens - uid DBUserId - name (Maybe Text) - data Text - comment Text - issued Time - expires (Maybe Time) - permissions Text - - UniqueNameUid name uid - UniqueData data -|] - -entityToID :: FromDBKey a => Entity (DB a) -> a -entityToID = fromDBKey . entityKey - -class PersistEntity (DB a) => FromDBKey a where - type DB a - fromDBKey :: Key (DB a) -> a - -instance FromDBKey UserID where - type DB UserID = DBUser - fromDBKey = UserID . fromIntegral . fromSqlKey - -instance FromDBKey TokenID where - type DB TokenID = DBToken - fromDBKey = TokenID . fromIntegral . fromSqlKey - -instance FromDBKey KeyID where - type DB KeyID = DBKey - fromDBKey = KeyID . fromIntegral . fromSqlKey - -class FromDBKey a => ToDBKey a where - toDBKey :: a -> Key (DB a) - -instance ToDBKey UserID where - toDBKey (UserID x) = toSqlKey $ fromIntegral x - -instance ToDBKey KeyID where - toDBKey (KeyID x) = toSqlKey $ fromIntegral x - -instance ToDBKey TokenID where - toDBKey (TokenID x) = toSqlKey $ fromIntegral x +dbGetUserPendingEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email)) +dbGetUserPendingEmail userID = do + userOrErr <- dbGetUser userID + case userOrErr of + Left err -> pure $ Left err + Right DBUser {..} -> Right <$> dbUserPendingEmail diff --git a/backend/src/Datarekisteri/Backend/DB/Queries.hs b/backend/src/Datarekisteri/Backend/DB/Queries.hs deleted file mode 100644 index c351533..0000000 --- a/backend/src/Datarekisteri/Backend/DB/Queries.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Datarekisteri.Backend.DB.Queries where - -import Datarekisteri.Backend.DB as DB -import Datarekisteri.Backend.Types -import Datarekisteri.Core.Types -import Data.Text (Text) -import Database.Esqueleto.Experimental -import qualified Database.Persist as Persist (update, (=.)) -import qualified Database.Persist.Types as Persist (Update) -import Data.Maybe (listToMaybe) -import Data.Aeson (fromJSON, toJSON, Result(..)) -import Data.Time (nominalDay) - -getByID :: (MonadDB m, ToDBKey k, PersistEntityBackend (DB k) ~ SqlBackend) => k -> m (Maybe (Entity (DB k))) -getByID id = let key = toDBKey id in runQuery $ fmap (Entity key) <$> get key - -getUserByEmail :: MonadDB m => Email -> m (Maybe (Entity DBUser)) -getUserByEmail email = fmap listToMaybe $ runQuery $ select $ do - (dbUser :& dbEmail) <- from $ table @DBUser `crossJoin` table @DBEmail - where_ $ dbEmail ^. DBEmailEmail ==. val email &&. dbUser ^. DBUserId ==. dbEmail ^. DBEmailUid - -- There is only one row in DBEmail with a given email (unique constraint) and a DBEmail only - -- has one user id and there is only row in DBUser with a given user id (primary key). Thus - -- there is at most one combination of rows from DBEmail and DBUser that satisfy this query. - pure dbUser - -addUser :: MonadDB m => DBUser -> m UserID -addUser = fmap fromDBKey . runQuery . insert - -getKeys :: MonadDB m => UserID -> m [Entity DBKey] -getKeys user = runQuery $ select $ do - keys <- from $ table @DBKey - where_ $ keys ^. DBKeyUid ==. val (toDBKey user) - pure $ keys - -getPermissions :: MonadDB m => UserID -> m (Maybe Text) -getPermissions user = fmap (fmap dBUserPermissions) $ runQuery $ get (toDBKey user) - -setPermissions :: MonadDB m => UserID -> Text -> m () -setPermissions user txt = updateUserData user [DB.DBUserPermissions Persist.=. txt] [] >> return () - -getPrimaryKey :: MonadDB m => UserID -> m (Maybe (Entity DBKey)) -getPrimaryKey user = fmap listToMaybe $ runQuery $ select $ do - keys <- from $ table @DBKey - where_ $ keys ^. DBKeyIsPrimaryEncryptionKey &&. keys ^. DBKeyUid ==. val (toDBKey user) - pure $ keys - -getUserTokens :: MonadDB m => UserID -> m [Entity DBToken] -getUserTokens user = runQuery $ select $ do - tokens <- from $ table @DBToken - where_ $ tokens ^. DBTokenUid ==. val (toDBKey user) - pure $ tokens - -addToken :: MonadDB m => DBToken -> m TokenID -addToken = fmap fromDBKey . runQuery . insert - -getToken :: MonadDB m => Text -> m (Maybe (Entity DBToken)) -getToken = runQuery . getBy . UniqueData - -addKey :: MonadDB m => DBKey -> m KeyID -addKey = fmap fromDBKey . runQuery . insert - -getAllUsers :: MonadDB m => m [Entity DBUser] -getAllUsers = runQuery $ select $ do - users <- from $ table @DBUser - where_ $ isMember users - pure $ users - -applicants :: MonadDB m => m [Entity DBUser] -applicants = runQuery $ select $ do - users <- from $ table @DBUser - where_ $ isApplicant users - pure $ users - -isVerified :: SqlExpr (Entity DBEmail) -> SqlExpr (Value Bool) -isVerified email = isNothing (email ^. DBEmailVid) - -hasVerifiedEmail :: SqlExpr (Value DBUserId) -> SqlExpr (Value Bool) -hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do - emails <- from $ table @DBEmail - where_ $ emails ^. DBEmailUid ==. userId &&. isVerified emails - pure $ val True -- This is not used anywhere, there just isn't a PersistField instance for () - -isApplicant :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool) -isApplicant user = isNothing (user ^. DBUserAccepted) - &&. hasVerifiedEmail (user ^. DBUserId) - -isMember :: SqlExpr (Entity DBUser) -> SqlExpr (Value Bool) -isMember user = not_ $ isApplicant user - -verifyEmailSecret :: MonadDB m => Text -> m Bool -verifyEmailSecret secret = runQuery $ do - update $ \email -> do - set email [DBEmailVid =. val Nothing] - where_ $ (>. val (0 :: Int)) $ subSelectCount $ do - verification <- from $ table @DBEmailVerification - where_ $ email ^. DBEmailVid ==. just (verification ^. DBEmailVerificationId) - &&. verification ^. DBEmailVerificationSecret ==. val secret - fmap (> 0) $ deleteCount $ do - verification <- from (table @DBEmailVerification) - where_ $ verification ^. DBEmailVerificationSecret ==. val secret - -getUserEmail' :: MonadDB m => UserID -> Bool -> m (Maybe (Entity DBEmail)) -getUserEmail' user verified = fmap listToMaybe $ runQuery $ select $ do - email <- from $ table @DBEmail - where_ $ email ^. DBEmailUid ==. val (toDBKey user) - &&. isNothing (email ^. DBEmailVid) ==. val verified - pure email - -getUserEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail)) -getUserEmail user = getUserEmail' user True - -getUserPendingEmail :: MonadDB m => UserID -> m (Maybe (Entity DBEmail)) -getUserPendingEmail user = getUserEmail' user False - -addEmail :: MonadDB m => DBEmail -> m (Key DBEmail) -addEmail = runQuery . insert - -getExpireTime :: MonadTime m => m Time -getExpireTime = addTime (7 * nominalDay) <$> currentTime - -addEmailVerification :: (MonadDB m, MonadTime m) => Text -> m (Key DBEmailVerification) -addEmailVerification secret = do - expires <- getExpireTime - runQuery $ insert $ DBEmailVerification - { dBEmailVerificationSecret = secret - , dBEmailVerificationExpires = expires - } - -deleteExpiredEmails :: MonadDB m => Time -> m () -deleteExpiredEmails time = runQuery $ delete $ do - verification <- from $ table @DBEmailVerification - where_ $ verification ^. DBEmailVerificationExpires <=. val time - -deleteOrphanedVerifications :: MonadDB m => m () -deleteOrphanedVerifications = runQuery $ delete $ do - verification <- from $ table @DBEmailVerification - where_ $ (==. val (0 :: Int)) $ subSelectCount $ do - email <- from $ table @DBEmail - where_ $ email ^. DBEmailVid ==. just (verification ^. DBEmailVerificationId) - -deleteUsersWithoutEmail :: MonadDB m => m () -deleteUsersWithoutEmail = runQuery $ delete $ do - user <- from $ table @DBUser - where_ $ (==. val (0 :: Int)) $ subSelectCount $ do - email <- from $ table @DBEmail - where_ $ email ^. DBEmailUid ==. user ^. DBUserId - pure $ email ^. DBEmailId -- Not used anywhere - -updateEmail :: (MonadDB m, MonadTime m) => UserID -> Email -> Text -> m (Key DBEmail) -updateEmail user email secret = getExpireTime >>= \expires -> runQuery $ do - delete $ do - dbEmail <- from $ table @DBEmail - where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) &&. not_ (isVerified dbEmail) - verifiedEmail <- fmap listToMaybe $ select $ do - dbEmail <- from $ table @DBEmail - where_ $ dbEmail ^. DBEmailUid ==. val (toDBKey user) - &&. dbEmail ^. DBEmailEmail ==. val email - pure dbEmail - case verifiedEmail of - Just (Entity key _) -> pure key - Nothing -> do - verificationId <- insert DBEmailVerification - { dBEmailVerificationSecret = secret - , dBEmailVerificationExpires = expires - } - insert DBEmail - { dBEmailUid = toDBKey user - , dBEmailEmail = email - , dBEmailVid = Just verificationId - } - -markAsAccepted :: MonadDB m => UserID -> Time -> m Bool -markAsAccepted userID time = fmap (> 0) $ runQuery $ updateCount $ \user -> do - set user [DBUserAccepted =. just (val time)] - where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user - -deleteApplication :: MonadDB m => UserID -> m Bool -deleteApplication userID = fmap (> 0) $ runQuery $ deleteCount $ do - user <- from $ table @DBUser - where_ $ user ^. DBUserId ==. val (toDBKey userID) &&. isApplicant user - -updateUserData :: MonadDB m => UserID -> [Persist.Update DBUser] -> [UserUpdate] -> m UserID -updateUserData user updates memberDataUpdates = runQuery $ do - let key = toDBKey user - Just userData <- get key - let (Success memberData) = fromJSON $ dBUserMemberData userData :: Result MemberData - userUpdates = [DBUserMemberData Persist.=. (toJSON $ foldr updateData memberData memberDataUpdates)] - updateData (SetUserName x) memberData = memberData { name = x } - updateData (SetUserNickname x) memberData = memberData { nickname = x } - updateData (SetUserHomeplace x) memberData = memberData { homeplace = x } - updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x } - Persist.update key (userUpdates <> updates) - pure user - -data UserUpdate = SetUserName Text - | SetUserNickname (Maybe Text) - | SetUserHomeplace Text - | SetUserPhoneNumber PhoneNumber diff --git a/backend/src/Datarekisteri/Backend/Sql.hs b/backend/src/Datarekisteri/Backend/Sql.hs new file mode 100644 index 0000000..5715d42 --- /dev/null +++ b/backend/src/Datarekisteri/Backend/Sql.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Datarekisteri.Backend.Sql where + +import Relude + +import Data.Time (nominalDay) +import Datarekisteri.Backend.Sql.Types +import Datarekisteri.Backend.Sql.Queries (SqlM, UserUpdate(..)) +import qualified Datarekisteri.Backend.Sql.Queries as Sql +import Datarekisteri.Backend.Types +import Datarekisteri.Core.Types +import Database.Persist (Entity(..), (=.)) +import Data.Aeson (Result(..), fromJSON, toJSON) + +class Monad m => MonadSql m where + runQuery :: SqlM a -> m a + +dbUpdateUser :: MonadSql m => UpdateData -> m (DBEither (DBUser m)) +dbUpdateUser UpdateData {..} = do + let memberDataUpdates = catMaybes + [ SetUserName <$> name + , SetUserNickname . Just <$> nickname + , SetUserHomeplace <$> homeplace + , SetUserPhoneNumber <$> phoneNumber + ] + userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash + sqlUser <- runQuery $ do + Sql.updateUserData user userUpdates memberDataUpdates + case email of + Nothing -> pure () + Just newEmail -> do + Sql.deleteUnverifiedEmail user + maybeOldEmail <- fmap (sqlEmailEmail . entityVal) <$> Sql.getUserEmail user + when (maybe True (/= newEmail) maybeOldEmail) $ do + verificationID <- Sql.addEmailVerification verificationSecret updateTime + void $ Sql.addEmail SqlEmail + { sqlEmailUid = fromID user + , sqlEmailEmail = newEmail + , sqlEmailVid = Just verificationID + } + fromMaybe (error "Inconsistent DB at APIM dbUpdateUser!") <$> Sql.getUser user + pure $ Right $ sqlUserToDBUser user sqlUser + +dbAddUser :: MonadSql m => ApplicationData -> m (DBEither (DBUser m)) +dbAddUser ApplicationData {..} = runQuery $ do + userID <- Sql.addUser SqlUser + { sqlUserRegistered = registered + , sqlUserPasswordCrypt = passwordHash + , sqlUserPermissions = permissions + , sqlUserAccepted = Nothing + , sqlUserMemberData = toJSON $ MemberData {..} + } + verificationID <- Sql.addEmailVerification verificationSecret (addTime (7*nominalDay) registered) + void $ Sql.addEmail SqlEmail + { sqlEmailUid = fromID userID + , sqlEmailEmail = email + , sqlEmailVid = Just verificationID + } + Right . sqlUserToDBUser userID . fromMaybe (error "") <$> Sql.getUser userID + +dbAcceptApplication :: MonadSql m => UserID -> Time -> m (DBEither ()) +dbAcceptApplication userID time = do + marked <- runQuery $ Sql.markAsAccepted userID time + if marked + then pure $ Right () + else pure $ Left $ "No application with id " <> show userID <> " found!" + +dbRejectApplication :: MonadSql m => UserID -> m (DBEither ()) +dbRejectApplication userID = do + deleted <- runQuery $ Sql.deleteApplication userID + if deleted + then pure $ Right () + else pure $ Left $ "No application with id " <> show userID <> " found!" + +dbVerifyEmail :: MonadSql m => Text -> m (DBEither ()) +dbVerifyEmail secret = do + verified <- runQuery $ Sql.verifyEmailSecret secret + if verified + then pure $ Right () + else pure $ Left $ "Invalid verification secret" + +dbAddToken :: MonadSql m => NewTokenData -> m (DBEither (DBToken m)) +dbAddToken NewTokenData {..} = do + (sqlTokenID, sqlToken) <- runQuery $ do + tokenID <- Sql.addToken SqlToken + { sqlTokenUid = fromID user + , sqlTokenName = name + , sqlTokenData = tokenData + , sqlTokenComment = fromMaybe "" comment + , sqlTokenIssued = issued + , sqlTokenExpires = expires + , sqlTokenPermissions = permissions + } + token <- fromMaybe (error "Inconsistent DB at APIM dbAddToken!") <$> Sql.getToken tokenID + pure (tokenID, token) + pure $ Right $ sqlTokenToDBToken sqlTokenID sqlToken + +dbAddKey :: MonadSql m => NewKeyData -> m (DBEither (DBPGPKey m)) +dbAddKey NewKeyData {..} = do + (keyID, sqlKey) <- runQuery $ do + keyID <- Sql.addKey SqlKey + { sqlKeyUid = fromID user + , sqlKeyData = keyData + , sqlKeyExpires = expires + , sqlKeyUploaded = uploaded + , sqlKeyComment = fromMaybe "" comment + , sqlKeyIsPrimaryEncryptionKey = False + } + sqlKey <- fromMaybe (error "Inconsistent DB at APIM dbAddKey") <$> Sql.getKey keyID + pure (keyID, sqlKey) + pure $ Right $ sqlKeyToDBKey keyID sqlKey + +dbGetUser :: MonadSql m => UserID -> m (DBEither (DBUser m)) +dbGetUser userID = do + maybeUser <- runQuery $ Sql.getUser userID + pure $ case maybeUser of + Nothing -> Left $ "Invalid user ID" + Just sqlUser -> Right $ sqlUserToDBUser userID sqlUser + +dbGetUserByEmail :: MonadSql m => Email -> m (DBEither (DBUser m)) +dbGetUserByEmail email = do + maybeUser <- runQuery $ Sql.getUserByEmail email + pure $ case maybeUser of + Nothing -> Left $ "No user with such email" + Just userEntity -> Right $ entityToDBUser userEntity + +dbGetUsers :: MonadSql m => m [DBUser m] +dbGetUsers = map entityToDBUser <$> runQuery Sql.getAllUsers + +dbGetUserTokens :: MonadSql m => UserID -> m (DBEither [DBToken m]) +dbGetUserTokens userID = Right . map entityToDBToken <$> runQuery (Sql.getUserTokens userID) + +dbGetUserKeys :: MonadSql m => UserID -> m (DBEither [DBPGPKey m]) +dbGetUserKeys userID = Right . map entityToDBKey <$> runQuery (Sql.getKeys userID) + +dbGetUserPrimaryKey :: MonadSql m => UserID -> m (DBEither (Maybe (DBPGPKey m))) +dbGetUserPrimaryKey userID = Right . fmap entityToDBKey <$> runQuery (Sql.getPrimaryKey userID) + +dbGetApplications :: MonadSql m => m [DBUser m] +dbGetApplications = map entityToDBUser <$> runQuery Sql.getApplicants + +dbGetEmailVerificationSecret :: MonadSql m => UserID -> m (DBEither (Maybe Text)) +dbGetEmailVerificationSecret userID = fmap Right $ runQuery $ Sql.getEmailVerificationSecret userID + +dbGetTokenBySecret :: MonadSql m => Text -> m (DBEither (DBToken m)) +dbGetTokenBySecret secret = maybe (Left "Invalid secret") Right . fmap entityToDBToken <$> + runQuery (Sql.getTokenBySecret secret) + +entityToDBUser :: MonadSql m => Entity SqlUser -> DBUser m +entityToDBUser (Entity userKey sqlUser) = sqlUserToDBUser (toID userKey) sqlUser + +sqlUserToDBUser :: MonadSql m => UserID -> SqlUser -> DBUser m +sqlUserToDBUser userID SqlUser {..} = + let Success MemberData {..} = fromJSON sqlUserMemberData + in DBUser + { dbUserId = pure userID + , dbUserEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $ Sql.getUserEmail userID + , dbUserPendingEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $ + Sql.getUserPendingEmail userID + , dbUserName = pure name + , dbUserNickname = pure $ fromMaybe (fromMaybe (error "Invalid name in the database") $ + viaNonEmpty head $ words name) nickname + , dbUserBirthdate = pure birthdate + , dbUserHomeplace = pure homeplace + , dbUserApplication = pure application + , dbUserPhoneNumber = pure phoneNumber + , dbUserRegistered = pure sqlUserRegistered + , dbUserAccepted = pure sqlUserAccepted + , dbUserPermissions = pure sqlUserPermissions + , dbUserPasswordHash = pure sqlUserPasswordCrypt + } + +entityToDBToken :: MonadSql m => Entity SqlToken -> DBToken m +entityToDBToken (Entity tokenKey sqlToken) = sqlTokenToDBToken (toID tokenKey) sqlToken + +sqlTokenToDBToken :: MonadSql m => TokenID -> SqlToken -> DBToken m +sqlTokenToDBToken tokenID SqlToken {..} = DBToken + { dbTokenId = pure tokenID + , dbTokenUser = + let userID = toID sqlTokenUid + in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlTokenToDBToken!")) $ + runQuery $ Sql.getUser userID + , dbTokenName = pure sqlTokenName + , dbTokenData = pure sqlTokenData + , dbTokenComment = pure sqlTokenComment + , dbTokenIssued = pure sqlTokenIssued + , dbTokenExpires = pure sqlTokenExpires + , dbTokenPermissions = pure sqlTokenPermissions + } + +entityToDBKey :: MonadSql m => Entity SqlKey -> DBPGPKey m +entityToDBKey (Entity keyKey sqlKey) = sqlKeyToDBKey (toID keyKey) sqlKey + +sqlKeyToDBKey :: MonadSql m => KeyID -> SqlKey -> DBPGPKey m +sqlKeyToDBKey keyID SqlKey {..} = DBPGPKey + { dbPGPKeyId = pure keyID + , dbPGPKeyUser = + let userID = toID sqlKeyUid + in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlKeyToDBKey!")) $ + runQuery $ Sql.getUser userID + , dbPGPKeyData = pure $ base64Encode sqlKeyData + , dbPGPKeyExpires = pure sqlKeyExpires + , dbPGPKeyUploaded = pure sqlKeyUploaded + , dbPGPKeyComment = pure sqlKeyComment + } diff --git a/backend/src/Datarekisteri/Backend/Sql/Queries.hs b/backend/src/Datarekisteri/Backend/Sql/Queries.hs new file mode 100644 index 0000000..d1e84bc --- /dev/null +++ b/backend/src/Datarekisteri/Backend/Sql/Queries.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Datarekisteri.Backend.Sql.Queries where + +import Datarekisteri.Backend.Sql.Types +import Datarekisteri.Backend.Types (MemberData(..)) +import Datarekisteri.Core.Types +import Data.Text (Text) +import Database.Esqueleto.Experimental +import Control.Monad.Logger (LoggingT) +import qualified Database.Persist as Persist (update, (=.)) +import qualified Database.Persist.Types as Persist (Update) +import Data.Maybe (listToMaybe) +import Data.Aeson (fromJSON, toJSON, Result(..)) + +type SqlM a = SqlPersistT (LoggingT IO) a + +getUserByEmail :: Email -> SqlM (Maybe (Entity SqlUser)) +getUserByEmail email = fmap listToMaybe $ select $ do + (dbUser :& dbEmail) <- from $ table @SqlUser `crossJoin` table @SqlEmail + where_ $ dbEmail ^. SqlEmailEmail ==. val email &&. dbUser ^. SqlUserId ==. dbEmail ^. SqlEmailUid + -- There is only one row in SqlEmail with a given email (unique constraint) and a SqlEmail only + -- has one user id and there is only row in SqlUser with a given user id (primary key). Thus + -- there is at most one combination of rows from SqlEmail and SqlUser that satisfy this query. + pure dbUser + +addUser :: SqlUser -> SqlM UserID +addUser = fmap toID . insert + +getUser :: UserID -> SqlM (Maybe SqlUser) +getUser = get . fromID + +getKeys :: UserID -> SqlM [Entity SqlKey] +getKeys user = select $ do + keys <- from $ table @SqlKey + where_ $ keys ^. SqlKeyUid ==. val (fromID user) + pure $ keys + +getKey :: KeyID -> SqlM (Maybe SqlKey) +getKey = get . fromID + +getPermissions :: UserID -> SqlM (Maybe Text) +getPermissions user = fmap (fmap sqlUserPermissions) $ get $ fromID user + +setPermissions :: UserID -> Text -> SqlM () +setPermissions user txt = updateUserData user [SqlUserPermissions Persist.=. txt] [] >> return () + +getPrimaryKey :: UserID -> SqlM (Maybe (Entity SqlKey)) +getPrimaryKey user = fmap listToMaybe $ select $ do + keys <- from $ table @SqlKey + where_ $ keys ^. SqlKeyIsPrimaryEncryptionKey &&. keys ^. SqlKeyUid ==. val (fromID user) + pure $ keys + +getUserTokens :: UserID -> SqlM [Entity SqlToken] +getUserTokens user = select $ do + tokens <- from $ table @SqlToken + where_ $ tokens ^. SqlTokenUid ==. val (fromID user) + pure $ tokens + +addToken :: SqlToken -> SqlM TokenID +addToken = fmap toID . insert + +getToken :: TokenID -> SqlM (Maybe SqlToken) +getToken = get . fromID + +getTokenBySecret :: Text -> SqlM (Maybe (Entity SqlToken)) +getTokenBySecret = getBy . UniqueData + +addKey :: SqlKey -> SqlM KeyID +addKey = fmap toID . insert + +getAllUsers :: SqlM [Entity SqlUser] +getAllUsers = select $ do + users <- from $ table @SqlUser + where_ $ isMember users + pure $ users + +getApplicants :: SqlM [Entity SqlUser] +getApplicants = select $ do + users <- from $ table @SqlUser + where_ $ isApplicant users + pure $ users + +isVerified :: SqlExpr (Entity SqlEmail) -> SqlExpr (Value Bool) +isVerified email = isNothing $ email ^. SqlEmailVid + +hasVerifiedEmail :: SqlExpr (Value SqlUserId) -> SqlExpr (Value Bool) +hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do + emails <- from $ table @SqlEmail + where_ $ emails ^. SqlEmailUid ==. userId &&. isVerified emails + pure $ val True -- This is not used anywhere, there just isn't a PersistField instance for () + +isApplicant :: SqlExpr (Entity SqlUser) -> SqlExpr (Value Bool) +isApplicant user = isNothing (user ^. SqlUserAccepted) + &&. hasVerifiedEmail (user ^. SqlUserId) + +isMember :: SqlExpr (Entity SqlUser) -> SqlExpr (Value Bool) +isMember user = not_ $ isApplicant user + +verifyEmailSecret :: Text -> SqlM Bool +verifyEmailSecret secret = do + pendingEmail <- selectOne $ do + email <- from $ table @SqlEmail + where_ $ (>. val (0 :: Int)) $ subSelectCount $ do + verification <- from $ table @SqlEmailVerification + where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId) + &&. verification ^. SqlEmailVerificationSecret ==. val secret + pure email + case pendingEmail of + Nothing -> pure False + Just (Entity _ SqlEmail {..}) -> do + delete $ do + email <- from $ table @SqlEmail + where_ $ val sqlEmailUid ==. email ^. SqlEmailUid &&. isVerified email + update $ \email -> do + set email [SqlEmailVid =. val Nothing] + where_ $ (>. val (0 :: Int)) $ subSelectCount $ do + verification <- from $ table @SqlEmailVerification + where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId) + &&. verification ^. SqlEmailVerificationSecret ==. val secret + fmap (> 0) $ deleteCount $ do + verification <- from (table @SqlEmailVerification) + where_ $ verification ^. SqlEmailVerificationSecret ==. val secret + +getUserEmail' :: UserID -> Bool -> SqlM (Maybe (Entity SqlEmail)) +getUserEmail' user verified = fmap listToMaybe $ select $ do + email <- from $ table @SqlEmail + where_ $ email ^. SqlEmailUid ==. val (fromID user) + &&. isNothing (email ^. SqlEmailVid) ==. val verified + pure email + +getUserEmail :: UserID -> SqlM (Maybe (Entity SqlEmail)) +getUserEmail user = getUserEmail' user True + +getUserPendingEmail :: UserID -> SqlM (Maybe (Entity SqlEmail)) +getUserPendingEmail user = getUserEmail' user False + +addEmail :: SqlEmail -> SqlM (Key SqlEmail) +addEmail = insert + +addEmailVerification :: Text -> Time -> SqlM (Key SqlEmailVerification) +addEmailVerification secret expires = do + insert $ SqlEmailVerification + { sqlEmailVerificationSecret = secret + , sqlEmailVerificationExpires = expires + } + +getEmailVerificationSecret :: UserID -> SqlM (Maybe Text) +getEmailVerificationSecret userID = fmap (listToMaybe . fmap unValue) $ select $ do + verification <- from $ table @SqlEmailVerification + where_ $ (>. val (0 :: Int)) $ subSelectCount $ do + email <- from $ table @SqlEmail + where_ $ email ^. SqlEmailUid ==. val (fromID userID) &&. + email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId) + pure $ verification ^. SqlEmailVerificationSecret + +deleteExpiredEmails :: Time -> SqlM () +deleteExpiredEmails time = delete $ do + verification <- from $ table @SqlEmailVerification + where_ $ verification ^. SqlEmailVerificationExpires <=. val time + +deleteUnverifiedEmail :: UserID -> SqlM () +deleteUnverifiedEmail user = delete $ do + email <- from $ table @SqlEmail + where_ $ email ^. SqlEmailUid ==. val (fromID user) &&. not_ (isVerified email) + +deleteOrphanedVerifications :: SqlM () +deleteOrphanedVerifications = delete $ do + verification <- from $ table @SqlEmailVerification + where_ $ (==. val (0 :: Int)) $ subSelectCount $ do + email <- from $ table @SqlEmail + where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId) + +deleteUsersWithoutEmail :: SqlM () +deleteUsersWithoutEmail = delete $ do + user <- from $ table @SqlUser + where_ $ (==. val (0 :: Int)) $ subSelectCount $ do + email <- from $ table @SqlEmail + where_ $ email ^. SqlEmailUid ==. user ^. SqlUserId + pure $ email ^. SqlEmailId -- Not used anywhere + +updateEmail :: UserID -> Email -> Text -> Time -> SqlM (Key SqlEmail) +updateEmail user email secret expires = do + delete $ do + dbEmail <- from $ table @SqlEmail + where_ $ dbEmail ^. SqlEmailUid ==. val (fromID user) &&. not_ (isVerified dbEmail) + verifiedEmail <- fmap listToMaybe $ select $ do + dbEmail <- from $ table @SqlEmail + where_ $ dbEmail ^. SqlEmailUid ==. val (fromID user) + &&. dbEmail ^. SqlEmailEmail ==. val email + pure dbEmail + case verifiedEmail of + Just (Entity key _) -> pure key + Nothing -> do + verificationId <- insert SqlEmailVerification + { sqlEmailVerificationSecret = secret + , sqlEmailVerificationExpires = expires + } + insert SqlEmail + { sqlEmailUid = fromID user + , sqlEmailEmail = email + , sqlEmailVid = Just verificationId + } + +markAsAccepted :: UserID -> Time -> SqlM Bool +markAsAccepted userID time = fmap (> 0) $ updateCount $ \user -> do + set user [SqlUserAccepted =. just (val time)] + where_ $ user ^. SqlUserId ==. val (fromID userID) &&. isApplicant user + +deleteApplication :: UserID -> SqlM Bool +deleteApplication userID = fmap (> 0) $ deleteCount $ do + user <- from $ table @SqlUser + where_ $ user ^. SqlUserId ==. val (fromID userID) &&. isApplicant user + +updateUserData :: UserID -> [Persist.Update SqlUser] -> [UserUpdate] -> SqlM () +updateUserData user updates memberDataUpdates = do + let key = fromID user + Just userData <- get key + let Success memberData = fromJSON $ sqlUserMemberData userData :: Result MemberData + userUpdates = [SqlUserMemberData Persist.=. (toJSON $ foldr updateData memberData memberDataUpdates)] + updateData (SetUserName x) memberData = memberData { name = x } + updateData (SetUserNickname x) memberData = memberData { nickname = x } + updateData (SetUserHomeplace x) memberData = memberData { homeplace = x } + updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x } + Persist.update key (userUpdates <> updates) + +data UserUpdate = SetUserName Text + | SetUserNickname (Maybe Text) + | SetUserHomeplace Text + | SetUserPhoneNumber PhoneNumber diff --git a/backend/src/Datarekisteri/Backend/Sql/Types.hs b/backend/src/Datarekisteri/Backend/Sql/Types.hs new file mode 100644 index 0000000..14a068c --- /dev/null +++ b/backend/src/Datarekisteri/Backend/Sql/Types.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Datarekisteri.Backend.Sql.Types where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings) +import Database.Persist (Entity, Key, entityKey, PersistEntity) +import Database.Persist.Sql (fromSqlKey, toSqlKey) +import Database.Persist.Postgresql.JSON (Value) +import Datarekisteri.Core.Types +import Datarekisteri.Backend.Types + +mkPersist sqlSettings [persistUpperCase| +SqlUser sql=users + registered Time + passwordCrypt PasswordHash + permissions Text + accepted (Maybe Time) + memberData Value sqltype=jsonb + + deriving (Show) + +SqlEmail sql=emails + uid SqlUserId + email Email sqltype=varchar(320) + vid (Maybe SqlEmailVerificationId) sql=verification + + UniqueUserVerified uid vid + -- This enables using persistent functions to get unique verified emails. The real + -- constraint is stricter and doesn't allow having more than one null and one non-null + -- verification but it's too complicated for persistent to understand. + + UniqueEmail email + UniqueVerification vid + +SqlEmailVerification sql=emailVerifications + secret Text sqltype=varchar(255) + expires Time + + UniqueVerificationSecret secret + +SqlKey sql=keys + uid SqlUserId + data ByteString + expires (Maybe Time) + uploaded Time + comment Text + isPrimaryEncryptionKey Bool + +SqlToken sql=tokens + uid SqlUserId + name (Maybe Text) + data Text + comment Text + issued Time + expires (Maybe Time) + permissions Text + + UniqueNameUid name uid + UniqueData data +|] + +entityToID :: EntityID a => Entity (DB a) -> a +entityToID = toID . entityKey + +class PersistEntity (DB a) => EntityID a where + type DB a + toID :: Key (DB a) -> a + fromID :: a -> Key (DB a) + +instance EntityID UserID where + type DB UserID = SqlUser + toID = UserID . fromIntegral . fromSqlKey + fromID (UserID x) = toSqlKey $ fromIntegral x + +instance EntityID TokenID where + type DB TokenID = SqlToken + toID = TokenID . fromIntegral . fromSqlKey + fromID (TokenID x) = toSqlKey $ fromIntegral x + +instance EntityID KeyID where + type DB KeyID = SqlKey + toID = KeyID . fromIntegral . fromSqlKey + fromID (KeyID x) = toSqlKey $ fromIntegral x diff --git a/backend/src/Datarekisteri/Backend/Types.hs b/backend/src/Datarekisteri/Backend/Types.hs index 5a2dd97..0d3bbb8 100644 --- a/backend/src/Datarekisteri/Backend/Types.hs +++ b/backend/src/Datarekisteri/Backend/Types.hs @@ -1,11 +1,16 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -14,15 +19,14 @@ module Datarekisteri.Backend.Types where import Relude import Control.Monad.Except (throwError) -import Control.Monad.Logger (LoggingT) import Datarekisteri.Core.Types import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.ByteArray (ByteArray, ByteArrayAccess) import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation) -import Data.Morpheus.Types (MonadError, GQLError) +import Data.Morpheus.Types (MonadError, GQLError, GQLType) import Data.Time (getCurrentTime) import Database.Persist.Class (PersistField(..)) -import Database.Persist.Sql (PersistFieldSql(..), SqlBackend) +import Database.Persist.Sql (PersistFieldSql(..)) import Network.Mail.Mime (Mail, Address(..)) import "cryptonite" Crypto.Random (MonadRandom(..)) @@ -46,9 +50,99 @@ data MemberData = MemberData instance FromJSON MemberData instance ToJSON MemberData +data ApplicationData = ApplicationData + { email :: Email + , phoneNumber :: PhoneNumber + , password :: Text + , name :: Text + , nickname :: Maybe Text + , birthdate :: Date + , homeplace :: Text + , application :: Text + , registered :: Time + , verificationSecret :: Text + , passwordHash :: PasswordHash + , permissions :: Text + } deriving (Generic, Eq, Show) + +data UpdateData = UpdateData + { email :: Maybe Email + , phoneNumber :: Maybe PhoneNumber + , passwordHash :: Maybe PasswordHash + , name :: Maybe Text + , nickname :: Maybe Text + , homeplace :: Maybe Text + , user :: UserID + , updateTime :: Time + , verificationSecret :: Text + } deriving (Generic, Eq, Show) + +data NewKeyData = NewKeyData + { comment :: Maybe Text + , keyData :: ByteString + , expires :: Maybe Time + , uploaded :: Time + , user :: UserID + } + deriving (Generic, Eq, Show) + +newtype Cursor = Cursor Text + deriving (Generic, Eq, Show) + deriving anyclass GQLType + +data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) } + deriving (Generic, GQLType) + +data NewTokenData = NewTokenData + { comment :: Maybe Text + , name :: Maybe Text + , permissions :: Text + , tokenData :: Text + , issued :: Time + , expires :: Maybe Time + , user :: UserID + } + deriving (Generic, Eq, Show) + newtype PasswordHash = PasswordHash ByteString - deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray, - PersistField, PersistFieldSql) + deriving newtype (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, + ByteArray, PersistField, PersistFieldSql) + +data DBUser m = DBUser + { dbUserId :: m UserID + , dbUserEmail :: m (Maybe Email) + , dbUserPendingEmail :: m (Maybe Email) + , dbUserName :: m Text + , dbUserNickname :: m Text + , dbUserPhoneNumber :: m PhoneNumber + , dbUserBirthdate :: m Date + , dbUserHomeplace :: m Text + , dbUserRegistered :: m Time + , dbUserAccepted :: m (Maybe Time) + , dbUserPermissions :: m Text + , dbUserApplication :: m Text + , dbUserPasswordHash :: m PasswordHash + } + +data DBPGPKey m = DBPGPKey + { dbPGPKeyId :: m KeyID + , dbPGPKeyUser :: m (DBUser m) + , dbPGPKeyData :: m Base64 + , dbPGPKeyExpires :: m (Maybe Time) + , dbPGPKeyUploaded :: m Time + , dbPGPKeyComment :: m Text + } + +data DBToken m = DBToken + { dbTokenId :: m TokenID + , dbTokenUser :: m (DBUser m) + , dbTokenName :: m (Maybe Text) + , dbTokenData :: m Text + , dbTokenComment :: m Text + , dbTokenIssued :: m Time + , dbTokenExpires :: m (Maybe Time) + , dbTokenPermissions :: m Text + } class Monad m => MonadTime m where currentTime :: m Time @@ -56,11 +150,25 @@ class Monad m => MonadTime m where instance MonadTime IO where currentTime = Time <$> getCurrentTime +type DBEither a = Either String a + class Monad m => MonadDB m where - runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a - -- TODO refactor so that it is possible to define a IO-less db, for safety and testability. - -- Is there a way to do this that doesn't require moving all db calls to the class? - -- Probably not :( + dbUpdateUser :: UpdateData -> m (DBEither (DBUser m)) + dbAddUser :: ApplicationData -> m (DBEither (DBUser m)) + dbAcceptApplication :: UserID -> Time -> m (DBEither ()) + dbRejectApplication :: UserID -> m (DBEither ()) + dbVerifyEmail :: Text -> m (DBEither ()) + dbAddToken :: NewTokenData -> m (DBEither (DBToken m)) + dbAddKey :: NewKeyData -> m (DBEither (DBPGPKey m)) + dbGetUser :: UserID -> m (DBEither (DBUser m)) + dbGetUserByEmail :: Email -> m (DBEither (DBUser m)) -- XXX should this be Maybe instead + dbGetUsers :: m [DBUser m] + dbGetUserTokens :: UserID -> m (DBEither [DBToken m]) + dbGetUserKeys :: UserID -> m (DBEither [DBPGPKey m]) + dbGetUserPrimaryKey :: UserID -> m (DBEither (Maybe (DBPGPKey m))) + dbGetApplications :: m [DBUser m] + dbGetTokenBySecret :: Text -> m (DBEither (DBToken m)) + dbGetEmailVerificationSecret :: UserID -> m (DBEither (Maybe Text)) class Monad m => MonadEmail m where sendEmail :: Mail -> m () @@ -76,7 +184,22 @@ class Monad m => MonadPermissions m where toPermissions :: Text -> m (Maybe Text) instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where - runQuery = lift . runQuery + dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser + dbAddUser = fmap (fmap liftUser) . lift . dbAddUser + dbAcceptApplication user = lift . dbAcceptApplication user + dbRejectApplication = lift . dbRejectApplication + dbVerifyEmail = lift . dbVerifyEmail + dbAddToken = fmap (fmap liftToken) . lift . dbAddToken + dbAddKey = fmap (fmap liftKey) . lift . dbAddKey + dbGetUser = fmap (fmap liftUser) . lift . dbGetUser + dbGetUserByEmail = fmap (fmap liftUser) . lift . dbGetUserByEmail + dbGetUsers = fmap (map liftUser) $ lift $ dbGetUsers + dbGetUserTokens = fmap (fmap (map liftToken)) . lift . dbGetUserTokens + dbGetUserKeys = fmap (fmap (map liftKey)) . lift . dbGetUserKeys + dbGetUserPrimaryKey = fmap (fmap (fmap liftKey)) . lift . dbGetUserPrimaryKey + dbGetApplications = fmap (map liftUser) $ lift $ dbGetApplications + dbGetEmailVerificationSecret = lift . dbGetEmailVerificationSecret + dbGetTokenBySecret = fmap (fmap liftToken) . lift . dbGetTokenBySecret instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where currentUser = lift currentUser @@ -96,3 +219,42 @@ instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where currentTime = lift currentTime + +liftUser :: (MonadTrans t, Monad m) => DBUser m -> DBUser (t m) +liftUser DBUser {..} = DBUser + { dbUserId = lift dbUserId + , dbUserEmail = lift dbUserEmail + , dbUserPendingEmail = lift dbUserPendingEmail + , dbUserName = lift dbUserName + , dbUserNickname = lift dbUserNickname + , dbUserPhoneNumber = lift dbUserPhoneNumber + , dbUserBirthdate = lift dbUserBirthdate + , dbUserHomeplace = lift dbUserHomeplace + , dbUserRegistered = lift dbUserRegistered + , dbUserAccepted = lift dbUserAccepted + , dbUserPermissions = lift dbUserPermissions + , dbUserApplication = lift dbUserApplication + , dbUserPasswordHash = lift dbUserPasswordHash + } + +liftToken :: (MonadTrans t, Monad m, Monad (t m)) => DBToken m -> DBToken (t m) +liftToken DBToken {..} = DBToken + { dbTokenId = lift dbTokenId + , dbTokenUser = fmap liftUser $ lift dbTokenUser + , dbTokenName = lift dbTokenName + , dbTokenData = lift dbTokenData + , dbTokenComment = lift dbTokenComment + , dbTokenIssued = lift dbTokenIssued + , dbTokenExpires = lift dbTokenExpires + , dbTokenPermissions = lift dbTokenPermissions + } + +liftKey :: (MonadTrans t, Monad m, Monad (t m)) => DBPGPKey m -> DBPGPKey (t m) +liftKey DBPGPKey {..} = DBPGPKey + { dbPGPKeyId = lift dbPGPKeyId + , dbPGPKeyUser = fmap liftUser $ lift dbPGPKeyUser + , dbPGPKeyData = lift dbPGPKeyData + , dbPGPKeyExpires = lift dbPGPKeyExpires + , dbPGPKeyUploaded = lift dbPGPKeyUploaded + , dbPGPKeyComment = lift dbPGPKeyComment + } diff --git a/backend/src/Datarekisteri/CLI.hs b/backend/src/Datarekisteri/CLI.hs index 1e4d224..04fcf7f 100644 --- a/backend/src/Datarekisteri/CLI.hs +++ b/backend/src/Datarekisteri/CLI.hs @@ -12,8 +12,9 @@ import "cryptonite" Crypto.Random (MonadRandom(..)) import Control.Monad.Logger (runStderrLoggingT) import Data.Aeson (toJSON) import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn) -import Datarekisteri.Backend.DB -import Datarekisteri.Backend.DB.Queries +import qualified Datarekisteri.Backend.Sql.Queries as Sql +import Datarekisteri.Backend.Sql (MonadSql, runQuery) +import Datarekisteri.Backend.Sql.Types import Datarekisteri.Backend.Types import Datarekisteri.Backend.Utils import Datarekisteri.Core.Types @@ -33,36 +34,37 @@ addUserMain :: AddUserOpts -> CLIM () addUserMain AddUserOpts {..} = do time <- currentTime passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword - userID <- addUser $ DBUser - { dBUserRegistered = time - , dBUserPasswordCrypt = passwordHash - , dBUserPermissions = show addUserPermissions - , dBUserAccepted = Just time - , dBUserMemberData = toJSON $ MemberData - { nickname = addUserNickname - , name = addUserName - , birthdate = addUserBirthdate - , homeplace = addUserHomeplace - , application = addUserApplication - , phoneNumber = addUserPhoneNumber + runQuery $ do + userID <- Sql.addUser $ SqlUser + { sqlUserRegistered = time + , sqlUserPasswordCrypt = passwordHash + , sqlUserPermissions = show addUserPermissions + , sqlUserAccepted = Just time + , sqlUserMemberData = toJSON $ MemberData + { nickname = addUserNickname + , name = addUserName + , birthdate = addUserBirthdate + , homeplace = addUserHomeplace + , application = addUserApplication + , phoneNumber = addUserPhoneNumber + } } - } - _ <- addEmail $ DBEmail - { dBEmailUid = toDBKey userID - , dBEmailEmail = addUserEmail - , dBEmailVid = Nothing - } - pure () + _ <- Sql.addEmail $ SqlEmail + { sqlEmailUid = fromID userID + , sqlEmailEmail = addUserEmail + , sqlEmailVid = Nothing + } + pure () gcEmailsMain :: CLIM () gcEmailsMain = do time <- currentTime - deleteExpiredEmails time - deleteOrphanedVerifications + runQuery $ do + Sql.deleteExpiredEmails time + Sql.deleteOrphanedVerifications gcApplicationsMain :: CLIM () -gcApplicationsMain = do - deleteUsersWithoutEmail +gcApplicationsMain = runQuery $ Sql.deleteUsersWithoutEmail gcAllMain :: CLIM () gcAllMain = do @@ -124,7 +126,7 @@ newtype CLIM a = CLIM (ReaderT String IO a) instance MonadTime CLIM where currentTime = liftIO currentTime -instance MonadDB CLIM where +instance MonadSql CLIM where runQuery query = do dbUrl <- ask liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query