Abstract SQL table structure from database queries

This commit is contained in:
Saku Laesvuori 2023-10-02 17:45:56 +03:00
parent d2f1b07922
commit 3942d547e0
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
10 changed files with 984 additions and 570 deletions

View File

@ -18,6 +18,7 @@ executable datarekisteri-backend
datarekisteri-core, datarekisteri-core,
email-validate, email-validate,
esqueleto, esqueleto,
http-types,
memory, memory,
mime-mail, mime-mail,
monad-logger, monad-logger,
@ -45,7 +46,9 @@ executable datarekisteri-backend
other-modules: other-modules:
Datarekisteri.Backend.API, Datarekisteri.Backend.API,
Datarekisteri.Backend.DB, Datarekisteri.Backend.DB,
Datarekisteri.Backend.DB.Queries, Datarekisteri.Backend.Sql,
Datarekisteri.Backend.Sql.Types,
Datarekisteri.Backend.Sql.Queries,
Datarekisteri.Backend.Email, Datarekisteri.Backend.Email,
Datarekisteri.Backend.Types, Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils, Datarekisteri.Backend.Utils,
@ -82,8 +85,9 @@ executable datarekisteri-cli
time time
main-is: Datarekisteri/CLI.hs main-is: Datarekisteri/CLI.hs
other-modules: other-modules:
Datarekisteri.Backend.DB, Datarekisteri.Backend.Sql,
Datarekisteri.Backend.DB.Queries, Datarekisteri.Backend.Sql.Types,
Datarekisteri.Backend.Sql.Queries,
Datarekisteri.Backend.Types, Datarekisteri.Backend.Types,
Datarekisteri.Backend.Utils, Datarekisteri.Backend.Utils,
hs-source-dirs: src hs-source-dirs: src

View File

@ -9,24 +9,25 @@ import Relude
import "cryptonite" Crypto.Random (MonadRandom(..)) import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT) import Control.Monad.Logger (runStderrLoggingT)
import Control.Monad.Except (catchError)
import Data.Map (findWithDefault) import Data.Map (findWithDefault)
import Data.Text (toLower, breakOn, stripPrefix) import Data.Text (toLower, breakOn, stripPrefix)
import Database.Persist (entityVal)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn) import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Network.HTTP.Types.Status (status500, status401)
import Network.Mail.Mime (renderSendMailCustom, Address(..)) import Network.Mail.Mime (renderSendMailCustom, Address(..))
import Network.Wai (Application) import Network.Wai (Application)
import Network.Wai.Handler.Warp (Port, run) import Network.Wai.Handler.Warp (Port, run)
import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Gzip
import Datarekisteri.Backend.API import Datarekisteri.Backend.API
import Datarekisteri.Backend.DB import qualified Datarekisteri.Backend.Sql as Sql
import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken) import Datarekisteri.Backend.Sql (MonadSql)
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils (checkPassword) import Datarekisteri.Backend.Utils (checkPassword)
import System.Directory (findExecutable) import System.Directory (findExecutable)
import System.Process (callProcess) import System.Process (callProcess)
import Options.Applicative hiding (header) import Options.Applicative hiding (Success, header)
import qualified Options.Applicative as O import qualified Options.Applicative as O
import Web.Scotty.Trans hiding (readEither) import Web.Scotty.Trans hiding (readEither)
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64) 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 :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
authBearer Nothing m = m authBearer Nothing m = m
authBearer (Just (BearerToken bearer)) m = do authBearer (Just (BearerToken bearer)) m = do
token <- lift $ getToken bearer let getUserPermissions = do
let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal 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 flip local m $ \state -> state
{ stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token { stateCurrentUser = user
, statePermissions = permissions , statePermissions = permissions
} }
@ -123,21 +129,23 @@ parseBasic txt = do
authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
authBasic Nothing m = m authBasic Nothing m = m
authBasic (Just basic) m = do authBasic (Just basic) m = do
user <- verifyBasic basic DBUser {..} <- verifyBasic basic
permissions <- maybe (pure mempty) permissions <- readPermission <$> lift dbUserPermissions >>=
(fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user fromMaybeFail status500 "Internal server error"
userID <- lift dbUserId
flip local m $ \state -> state flip local m $ \state -> state
{ stateCurrentUser = user { stateCurrentUser = Just userID
, statePermissions = permissions , statePermissions = permissions
} }
-- TODO Refact, no need to convert to id and rerequest permissions verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
verifyBasic BasicAuth {..} = do verifyBasic BasicAuth {..} = do
user <- lift $ getUserByEmail emailAddress Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress
if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user correctPassword <- checkPassword password <$> lift dbUserPasswordHash
then pure $ entityToID <$> user if correctPassword
else pure Nothing 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) newtype APIM a = APIM (ReaderT RequestState IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState) deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
@ -158,10 +166,29 @@ data Config = Config
instance MonadTime APIM where instance MonadTime APIM where
currentTime = liftIO currentTime currentTime = liftIO currentTime
instance MonadDB APIM where instance MonadSql APIM where
runQuery query = do runQuery query = do
dbUrl <- asks $ configDbUrl . stateConfig dbUrl <- fmap encodeUtf8 $ asks $ configDbUrl . stateConfig
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query 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 instance MonadEmail APIM where
sendEmail email = do sendEmail email = do
@ -200,3 +227,6 @@ runAPIM config (APIM m) = runReaderT m RequestState
, statePermissions = fromList [] , statePermissions = fromList []
, stateConfig = config , stateConfig = config
} }
fromMaybeFail status err Nothing = raiseStatus status err
fromMaybeFail _ _ (Just x) = pure x

View File

@ -18,21 +18,17 @@
module Datarekisteri.Backend.API (coreApp, runApp, resolver) where 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 "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
import Control.Monad.Except (MonadError, throwError) import Control.Monad.Except (MonadError, throwError, catchError)
import Data.Aeson (fromJSON, Result(..), toJSON)
import Data.Maybe (fromJust)
import Data.Morpheus.Server (deriveApp, runApp) import Data.Morpheus.Server (deriveApp, runApp)
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined) import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App) import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
import Database.Persist (Entity, entityVal, entityKey, get, (=.))
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail) import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.Utils import Datarekisteri.Backend.Utils
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64) import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Data.Text as T (null, chunksOf, intercalate) 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 :: MonadError GQLError m => GQLError -> Maybe a -> m a
fromMaybeFail txt = maybe (throwError txt) pure fromMaybeFail txt = maybe (throwError txt) pure
void :: Monad m => m a -> m Unit voidU :: Monad m => m a -> m Unit
void m = m >> pure Unit voidU m = m >> pure Unit
when :: Monad m => Bool -> m a -> m Unit liftDBEither :: MonadError GQLError m => DBEither a -> m a
when b m = if b then void m else pure Unit liftDBEither = either (throwError . fromString) pure
dbUserToUser :: MonadDB m => Entity DBUser -> User m applicationArgsToData :: (MonadTime m, MonadRandom m, MonadPermissions m, MonadError GQLError m) =>
dbUserToUser user = let id = entityToID user ApplicationArgs -> m ApplicationData
DBUser {..} = entityVal user applicationArgsToData ApplicationArgs {..} = do
Success (MemberData {..}) = fromJSON dBUserMemberData registered <- currentTime
-- XXX: Explodes if database doesn't contain needed data verificationSecret <- genVerificationSecret
in User
{ id = pure id
, email = fmap (dBEmailEmail . entityVal) <$> getUserEmail id
, pendingEmail = fmap (dBEmailEmail . entityVal) <$> getUserPendingEmail id
, phoneNumber = pure phoneNumber
, name = pure name
, nickname = pure $ fromMaybe (error "db contains empty name") $
maybe (viaNonEmpty head $ words $ name) Just nickname
, birthdate = pure birthdate
, homeplace = pure homeplace
, registered = pure dBUserRegistered
, accepted = pure dBUserAccepted
, isMember = pure $ isJust dBUserAccepted
, permissions = pure dBUserPermissions
, application = pure application
}
dbKeyToPGPKey :: (MonadDB m, MonadError GQLError m) => Entity DBKey -> PGPKey m
dbKeyToPGPKey key = let id = entityToID key
DBKey {..} = entityVal key
in PGPKey
{ id = pure id
, user = getByID (fromDBKey dBKeyUid :: UserID)
>>= fmap dbUserToUser . fromMaybeFail ""
, pgpKeyData = pure $ base64Encode dBKeyData
, expires = pure dBKeyExpires
, uploaded = pure dBKeyUploaded
, comment = pure dBKeyComment
}
dbTokenToToken :: (MonadDB m, MonadError GQLError m) => Entity DBToken -> Token m
dbTokenToToken token = let id = entityToID token
DBToken {..} = entityVal token
in Token
{ id = pure id
, user = getByID (fromDBKey dBTokenUid :: UserID)
>>= fmap dbUserToUser . fromMaybeFail ""
, name = pure dBTokenName
, tokenData = pure dBTokenData
, comment = pure dBTokenComment
, issued = pure dBTokenIssued
, expires = pure dBTokenExpires
, permissions = pure dBTokenPermissions
}
newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
ApplicationData -> m UserID
newUser (ApplicationData {..}) = do
time <- currentTime
secret <- genVerificationSecret
passwordHash <- hashPassword password passwordHash <- hashPassword password
permissions <- defaultPermissions permissions <- defaultPermissions
when (T.null name) $ throwError "Name must not be empty" when (T.null name) $ throwError "Name must not be empty"
when (T.null password) $ throwError "Password must not be empty" when (T.null password) $ throwError "Password must not be empty"
when (T.null homeplace) $ throwError "Homeplace 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, ..} pure ApplicationData {..}
user <- addUser $ DBUser
{ dBUserRegistered = time newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
, dBUserPasswordCrypt = passwordHash ApplicationArgs -> m (User m)
, dBUserPermissions = permissions newUser args = do
, dBUserAccepted = Nothing applicationData <- applicationArgsToData args
, dBUserMemberData = toJSON memberData user <- dbAddUser applicationData >>= liftDBEither
} sendVerificationSecret user >>= flip unless (throwError "Sending email verification failed!")
verification <- addEmailVerification secret return $ dbUserToUser user
email <- addEmail $ DBEmail
{ dBEmailUid = toDBKey user
, dBEmailEmail = email
, dBEmailVid = Just verification
}
sendVerificationSecret email
return user
genVerificationSecret :: MonadRandom m => m Text genVerificationSecret :: MonadRandom m => m Text
genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10 genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => DBUser m -> m Bool
sendVerificationSecret email = void $ do sendVerificationSecret DBUser {..} = do
maybeDBEmail <- runQuery $ get email secret <- dbUserId >>= dbGetEmailVerificationSecret >>= liftDBEither
case maybeDBEmail of pendingEmail <- dbUserPendingEmail
Nothing -> pure Unit case (secret, pendingEmail) of
Just dbEmail -> do (Just secret', Just pendingEmail') ->
case dBEmailVid dbEmail of sendVerificationEmail secret' pendingEmail' >> pure True
Nothing -> pure Unit _ -> pure False
Just dbVerificationId -> do
secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m) =>
let email = dBEmailEmail dbEmail UpdateArgs -> UserID -> m UpdateData
void $ sendVerificationEmail secret email 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) => updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
UserID -> UpdateData -> m UserID UserID -> UpdateArgs -> m (User m)
updateUser user (UpdateData {..}) = do updateUser user args = do
hash <- sequence $ hashPassword <$> password updateData@(UpdateData {..}) <- updateArgsToData args user
-- TODO: assert stuff valid updatedUser <- dbUpdateUser updateData >>= liftDBEither
user <- updateUserData user when (isJust email) $ void $ sendVerificationSecret updatedUser
(catMaybes [(DBUserPasswordCrypt =.) <$> hash]) pure $ dbUserToUser updatedUser
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber]) newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) =>
case email of NewTokenArgs -> UserID -> m NewTokenData
Nothing -> pure Unit newTokenArgsToData NewTokenArgs {..} user = do
Just email' -> do tokenData <- B64.encodeBase64 <$> getRandomBytes 128
verificationSecret <- genVerificationSecret issued <- currentTime
emailKey <- updateEmail user email' verificationSecret permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
sendVerificationSecret emailKey let expires = Nothing
return user pure NewTokenData {..}
makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) => makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
NewTokenArgs -> UserID -> m TokenID NewTokenArgs -> UserID -> m (Token m)
makeNewToken (NewTokenArgs {..}) user = do makeNewToken args user = do
tokenData <- B64.encodeBase64 <$> getRandomBytes 128 tokenData <- newTokenArgsToData args user
time <- currentTime fmap dbTokenToToken $ dbAddToken tokenData >>= liftDBEither
permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
addToken $ DBToken newKeyArgsToData :: (MonadTime m, MonadError GQLError m) => NewKeyArgs -> UserID -> m NewKeyData
{ dBTokenUid = toDBKey user newKeyArgsToData NewKeyArgs {..} user = do
, dBTokenName = name uploaded <- currentTime
, dBTokenData = tokenData keyData <- maybe (throwError "Invalid base64") pure $ base64Decode keyData
, dBTokenComment = fromMaybe "" comment pure NewKeyData {..}
, dBTokenIssued = time
, dBTokenExpires = Nothing
, dBTokenPermissions = permissions
}
makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) => makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
KeyData -> UserID -> m KeyID NewKeyArgs -> UserID -> m (PGPKey m)
makeNewKey (KeyData {..}) user = do makeNewKey args user = do
time <- currentTime newKeyData <- newKeyArgsToData args user
keyData' <- fromMaybeFail "" $ base64Decode keyData fmap dbPGPKeyToPGPKey $ dbAddKey newKeyData >>= liftDBEither
addKey $ DBKey
{ dBKeyUid = toDBKey user
, dBKeyData = keyData'
, dBKeyExpires = expires
, dBKeyUploaded = time
, dBKeyComment = fromMaybe "" comment
, dBKeyIsPrimaryEncryptionKey = True
}
acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
acceptApplication user = void $ do acceptApplication user = voidU $ do
maybeEmail <- getUserEmail user maybeEmail <- dbGetUserEmail user >>= liftDBEither
case maybeEmail of case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!" Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do Just email -> do
time <- currentTime time <- currentTime
applicationAccepted <- markAsAccepted user time dbAcceptApplication user time >>= liftDBEither
when applicationAccepted $ sendApplicationAcceptedEmail email
sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
rejectApplication user = void $ do rejectApplication user = voidU $ do
maybeEmail <- getUserEmail user maybeEmail <- dbGetUserEmail user >>= liftDBEither
case maybeEmail of case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!" Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do Just email -> do
applicationDeleted <- deleteApplication user dbRejectApplication user
when applicationDeleted $ sendApplicationRejectedEmail email
sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
resolveQuery = Query 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 >> , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
fmap dbUserToUser <$> getByID user (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
, tokens = \(Arg id) -> targetUser id >>= \user -> , tokens = \(Arg id) -> targetUser id >>= \user -> do
requirePermission (Tokens user) ReadOnly >> map dbTokenToToken <$> getUserTokens user requirePermission (Tokens user) ReadOnly
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> applicants map dbTokenToToken <$> (dbGetUserTokens user >>= liftDBEither)
, keys = \(Arg id) -> targetUser id >>= \user -> , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
requirePermission (Profile user) ReadOnly >> map dbKeyToPGPKey <$> getKeys user , keys = \(Arg id) -> targetUser id >>= \user -> do
requirePermission (Profile user) ReadOnly
map dbPGPKeyToPGPKey <$> (dbGetUserKeys user >>= liftDBEither)
--, key = \(Arg id) -> resolve (pure id) --, key = \(Arg id) -> resolve (pure id)
-- TODO is this actually useful -- TODO is this actually useful
, primaryKey = \(Arg id) -> targetUser id >>= \user -> , primaryKey = \(Arg id) -> targetUser id >>= \user -> do
requirePermission (Profile user) ReadOnly >> getPrimaryKey user >>= pure . fmap dbKeyToPGPKey requirePermission (Profile user) ReadOnly
fmap dbPGPKeyToPGPKey <$> (dbGetUserPrimaryKey user >>= liftDBEither)
, permissions = currentPermissions , permissions = currentPermissions
} }
resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m, resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
resolveMutation = Mutation resolveMutation = Mutation
{ apply = \x -> do { apply = newUser
userID <- newUser x , verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret
maybeUser <- getByID userID , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
user <- fromMaybeFail "" maybeUser maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
pure $ dbUserToUser user , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
, verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret" requirePermission (Profile user) ReadWrite >> updateUser user updateArgs
, resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
maybe (pure Unit) (sendVerificationSecret . entityKey)
, update = \updateData (Arg id) -> targetUser id >>= \user ->
requirePermission (Profile user) ReadWrite >>
updateUser user updateData >> getByID user >>= fmap dbUserToUser . fromMaybeFail ""
, newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user -> , newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
requirePermission (Profile user) ReadWrite >> makeNewToken args user >>= requirePermission (Profile user) ReadWrite >> makeNewToken args user
getByID >>= fmap dbTokenToToken . fromMaybeFail ""
, newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user -> , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
requirePermission (Profile user) ReadWrite >> makeNewKey args user >>= requirePermission (Profile user) ReadWrite >> makeNewKey args user
getByID >>= fmap dbKeyToPGPKey . fromMaybeFail ""
, accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id , accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id
, reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication 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 MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation } 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 data User m = User
{ id :: m UserID { id :: m UserID
, email :: m (Maybe Email) , email :: m (Maybe Email)
@ -298,39 +253,6 @@ data Token m = Token
, permissions :: m Text , permissions :: m Text
} deriving (Generic, GQLType) } 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 data Query m = Query
{ users :: m [User m] { users :: m [User m]
, user :: Arg "id" (Maybe UserID) -> m (Maybe (User m)) , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
@ -343,12 +265,51 @@ data Query m = Query
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
data Mutation m = Mutation data Mutation m = Mutation
{ apply :: ApplicationData -> m (User m) { apply :: ApplicationArgs -> m (User m)
, verifyEmail :: Arg "secret" Text -> m Unit , verifyEmail :: Arg "secret" Text -> m Unit
, resendVerificationEmail :: Arg "user" (Maybe UserID) -> 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) , newToken :: NewTokenArgs -> m (Token m)
, newKey :: KeyData -> m (PGPKey m) , newKey :: NewKeyArgs -> m (PGPKey m)
, accept :: Arg "user" UserID -> m Unit , accept :: Arg "user" UserID -> m Unit
, reject :: Arg "user" UserID -> m Unit , reject :: Arg "user" UserID -> m Unit
} deriving (Generic, GQLType) } 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
}

View File

@ -1,105 +1,24 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Datarekisteri.Backend.DB where module Datarekisteri.Backend.DB where
import Data.ByteString (ByteString) import Relude
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 import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
mkPersist sqlSettings [persistUpperCase| dbGetUserEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
DBUser sql=users dbGetUserEmail userID = do
registered Time userOrErr <- dbGetUser userID
passwordCrypt PasswordHash case userOrErr of
permissions Text Left err -> pure $ Left err
accepted (Maybe Time) Right DBUser {..} -> Right <$> dbUserEmail
memberData Value sqltype=jsonb
deriving (Show) dbGetUserPendingEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
dbGetUserPendingEmail userID = do
DBEmail sql=emails userOrErr <- dbGetUser userID
uid DBUserId case userOrErr of
email Email sqltype=varchar(320) Left err -> pure $ Left err
vid (Maybe DBEmailVerificationId) sql=verification Right DBUser {..} -> Right <$> dbUserPendingEmail
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

View File

@ -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

View File

@ -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
}

View File

@ -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

View File

@ -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

View File

@ -1,11 +1,16 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
@ -14,15 +19,14 @@ module Datarekisteri.Backend.Types where
import Relude import Relude
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Control.Monad.Logger (LoggingT)
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.ByteArray (ByteArray, ByteArrayAccess) import Data.ByteArray (ByteArray, ByteArrayAccess)
import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation) 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 Data.Time (getCurrentTime)
import Database.Persist.Class (PersistField(..)) import Database.Persist.Class (PersistField(..))
import Database.Persist.Sql (PersistFieldSql(..), SqlBackend) import Database.Persist.Sql (PersistFieldSql(..))
import Network.Mail.Mime (Mail, Address(..)) import Network.Mail.Mime (Mail, Address(..))
import "cryptonite" Crypto.Random (MonadRandom(..)) import "cryptonite" Crypto.Random (MonadRandom(..))
@ -46,9 +50,99 @@ data MemberData = MemberData
instance FromJSON MemberData instance FromJSON MemberData
instance ToJSON 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 newtype PasswordHash = PasswordHash ByteString
deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray, deriving newtype (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess,
PersistField, PersistFieldSql) 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 class Monad m => MonadTime m where
currentTime :: m Time currentTime :: m Time
@ -56,11 +150,25 @@ class Monad m => MonadTime m where
instance MonadTime IO where instance MonadTime IO where
currentTime = Time <$> getCurrentTime currentTime = Time <$> getCurrentTime
type DBEither a = Either String a
class Monad m => MonadDB m where class Monad m => MonadDB m where
runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a dbUpdateUser :: UpdateData -> m (DBEither (DBUser m))
-- TODO refactor so that it is possible to define a IO-less db, for safety and testability. dbAddUser :: ApplicationData -> m (DBEither (DBUser m))
-- Is there a way to do this that doesn't require moving all db calls to the class? dbAcceptApplication :: UserID -> Time -> m (DBEither ())
-- Probably not :( 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 class Monad m => MonadEmail m where
sendEmail :: Mail -> m () sendEmail :: Mail -> m ()
@ -76,7 +184,22 @@ class Monad m => MonadPermissions m where
toPermissions :: Text -> m (Maybe Text) toPermissions :: Text -> m (Maybe Text)
instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where 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 instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where
currentUser = lift currentUser 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 instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
currentTime = lift currentTime 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
}

View File

@ -12,8 +12,9 @@ import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT) import Control.Monad.Logger (runStderrLoggingT)
import Data.Aeson (toJSON) import Data.Aeson (toJSON)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn) import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Datarekisteri.Backend.DB import qualified Datarekisteri.Backend.Sql.Queries as Sql
import Datarekisteri.Backend.DB.Queries import Datarekisteri.Backend.Sql (MonadSql, runQuery)
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils import Datarekisteri.Backend.Utils
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
@ -33,12 +34,13 @@ addUserMain :: AddUserOpts -> CLIM ()
addUserMain AddUserOpts {..} = do addUserMain AddUserOpts {..} = do
time <- currentTime time <- currentTime
passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword
userID <- addUser $ DBUser runQuery $ do
{ dBUserRegistered = time userID <- Sql.addUser $ SqlUser
, dBUserPasswordCrypt = passwordHash { sqlUserRegistered = time
, dBUserPermissions = show addUserPermissions , sqlUserPasswordCrypt = passwordHash
, dBUserAccepted = Just time , sqlUserPermissions = show addUserPermissions
, dBUserMemberData = toJSON $ MemberData , sqlUserAccepted = Just time
, sqlUserMemberData = toJSON $ MemberData
{ nickname = addUserNickname { nickname = addUserNickname
, name = addUserName , name = addUserName
, birthdate = addUserBirthdate , birthdate = addUserBirthdate
@ -47,22 +49,22 @@ addUserMain AddUserOpts {..} = do
, phoneNumber = addUserPhoneNumber , phoneNumber = addUserPhoneNumber
} }
} }
_ <- addEmail $ DBEmail _ <- Sql.addEmail $ SqlEmail
{ dBEmailUid = toDBKey userID { sqlEmailUid = fromID userID
, dBEmailEmail = addUserEmail , sqlEmailEmail = addUserEmail
, dBEmailVid = Nothing , sqlEmailVid = Nothing
} }
pure () pure ()
gcEmailsMain :: CLIM () gcEmailsMain :: CLIM ()
gcEmailsMain = do gcEmailsMain = do
time <- currentTime time <- currentTime
deleteExpiredEmails time runQuery $ do
deleteOrphanedVerifications Sql.deleteExpiredEmails time
Sql.deleteOrphanedVerifications
gcApplicationsMain :: CLIM () gcApplicationsMain :: CLIM ()
gcApplicationsMain = do gcApplicationsMain = runQuery $ Sql.deleteUsersWithoutEmail
deleteUsersWithoutEmail
gcAllMain :: CLIM () gcAllMain :: CLIM ()
gcAllMain = do gcAllMain = do
@ -124,7 +126,7 @@ newtype CLIM a = CLIM (ReaderT String IO a)
instance MonadTime CLIM where instance MonadTime CLIM where
currentTime = liftIO currentTime currentTime = liftIO currentTime
instance MonadDB CLIM where instance MonadSql CLIM where
runQuery query = do runQuery query = do
dbUrl <- ask dbUrl <- ask
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query