Compare commits

...

8 Commits

29 changed files with 1157 additions and 693 deletions

1
.gitignore vendored
View File

@ -1 +1,2 @@
**/db/schema.sql
**/client_session_key.aes

View File

@ -30,6 +30,7 @@
ghc-base64
ghc-cryptonite
ghc-datarekisteri-core
ghc-data-default
ghc-echo
ghc-email-validate
ghc-esqueleto

View File

@ -1,6 +1,6 @@
import Data.Morpheus.Types (render, App)
import Server.API (coreApp)
import Datarekisteri.Backend.API (coreApp)
import qualified Data.ByteString.Lazy.Char8 as C8
import Server (APIM)
import Datarekisteri.Backend (APIM)
main = C8.putStrLn $ render (coreApp :: App () APIM)

View File

@ -16,8 +16,10 @@ executable datarekisteri-backend
base64,
cryptonite,
datarekisteri-core,
data-default,
email-validate,
esqueleto,
http-types,
memory,
mime-mail,
monad-logger,
@ -41,11 +43,14 @@ executable datarekisteri-backend
wai-cors,
wai-extra,
directory
main-is: Datarekisteri/Backend.hs
main-is: Main.hs
other-modules:
Datarekisteri.Backend,
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 +87,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

View File

@ -5,31 +5,42 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Backend where
import Relude
import "cryptonite" Crypto.Random (MonadRandom(..))
import qualified "base64" Data.ByteString.Base64 as B64
import Control.Monad.Except (catchError)
import Control.Monad.Logger (runStderrLoggingT)
import Data.Default (def)
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 Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils (checkPassword)
import Network.Wai.Middleware.Cors (CorsResourcePolicy(..), cors)
import Network.Wai.Middleware.Gzip (gzip)
import System.Directory (findExecutable)
import System.Process (callProcess)
import Options.Applicative hiding (header)
import qualified Options.Applicative as O
import Options.Applicative hiding (Success, header)
import Web.Scotty.Trans hiding (readEither)
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
import Datarekisteri.Backend.Sql (MonadSql)
import Datarekisteri.Backend.Utils (checkPassword)
import qualified Datarekisteri.Backend.Sql as Sql
import Datarekisteri.Backend.API
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
import Paths_datarekisteri_backend
main :: IO ()
@ -101,10 +112,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 +139,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 +176,26 @@ 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
dbGetApplications = Sql.dbGetApplications
dbGetEmailVerificationSecret = Sql.dbGetEmailVerificationSecret
dbGetTokenBySecret = Sql.dbGetTokenBySecret
instance MonadEmail APIM where
sendEmail email = do
@ -200,3 +234,6 @@ runAPIM config (APIM m) = runReaderT m RequestState
, statePermissions = fromList []
, stateConfig = config
}
fromMaybeFail status err Nothing = raiseStatus status err
fromMaybeFail _ _ (Just x) = pure x

View File

@ -8,9 +8,9 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
@ -18,24 +18,23 @@
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 qualified "base64" Data.ByteString.Base64 as B64
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 qualified Data.Text as T
import Datarekisteri.Backend.Email
import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Data.Text as T (null, chunksOf, intercalate)
import Datarekisteri.Core.Types
-- General functions, maybe migrate to Utils or API.Utils
@ -45,210 +44,133 @@ 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
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
updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB 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"
isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
when (isMember && isJust application) $ throwError "Members can't update their applications"
passwordHash <- sequence $ hashPassword <$> password
updateTime <- currentTime
verificationSecret <- genVerificationSecret
emailKey <- updateEmail user email' verificationSecret
sendVerificationSecret emailKey
return user
pure UpdateData {..}
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
MonadError GQLError m, MonadTime m, MonadPermissions m) => 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
--, 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
(Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
, 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 +184,34 @@ 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
, application :: 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)
@ -276,11 +226,13 @@ data User m = User
, permissions :: m Text
, isMember :: m Bool
, application :: m Text
, tokens :: m [Token m]
, keys :: m [PGPKey m]
, primaryKey :: m (Maybe (PGPKey m))
} deriving (Generic, GQLType)
data PGPKey m = PGPKey
{ id :: m KeyID
, user :: m (User m)
, pgpKeyData :: m Base64
, expires :: m (Maybe Time)
, uploaded :: m Time
@ -289,7 +241,6 @@ data PGPKey m = PGPKey
data Token m = Token
{ id :: m TokenID
, user :: m (User m)
, name :: m (Maybe Text)
, tokenData :: m Text
, comment :: m Text
@ -298,57 +249,60 @@ 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))
, applications :: m [User m]
, tokens :: Arg "user" (Maybe UserID) -> m [Token m]
, keys :: Arg "user" (Maybe UserID) -> m [PGPKey m]
, permissions :: m Text
--, key :: Arg "id" KeyID -> m (PGPKey m)
, primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
} deriving (Generic, GQLType)
data Mutation m = Mutation
{ apply :: ApplicationData -> m (User m)
{ 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 :: (MonadPermissions m, MonadError GQLError 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
, tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
, keys = map dbPGPKeyToPGPKey <$> dbUserKeys
, primaryKey = fmap dbPGPKeyToPGPKey <$> dbUserPrimaryKey
}
dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
{ id = dbPGPKeyId
, pgpKeyData = dbPGPKeyData
, expires = dbPGPKeyExpires
, uploaded = dbPGPKeyUploaded
, comment = dbPGPKeyComment
}
dbTokenToToken :: Monad m => DBToken m -> Token m
dbTokenToToken DBToken {..} = Token
{ id = dbTokenId
, name = dbTokenName
, tokenData = dbTokenData
, comment = dbTokenComment
, issued = dbTokenIssued
, expires = dbTokenExpires
, permissions = dbTokenPermissions
}

View File

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

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

@ -2,11 +2,12 @@
module Datarekisteri.Backend.Email where
import Datarekisteri.Backend.Types
import Data.Text (Text)
import Data.Text.Lazy (fromStrict)
import Network.Mail.Mime (Address(..), simpleMail')
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
import Network.Mail.Mime
sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m ()
sendDatarekisteriEmail subject content to = do

View File

@ -0,0 +1,212 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Backend.Sql where
import Relude
import Data.Aeson (Result(..), fromJSON, toJSON)
import Data.Time (nominalDay)
import Database.Persist (Entity(..), (=.))
import Datarekisteri.Backend.Sql.Queries (SqlM, UserUpdate(..))
import qualified Datarekisteri.Backend.Sql.Queries as Sql
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types
import Datarekisteri.Core.Types
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
, SetUserApplication <$> application
]
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
, dbUserTokens = fmap (map entityToDBToken) $ runQuery $ Sql.getUserTokens userID
, dbUserKeys = fmap (map entityToDBKey) $ runQuery $ Sql.getKeys userID
, dbUserPrimaryKey = fmap (fmap entityToDBKey) $ runQuery $ Sql.getPrimaryKey userID
}
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
, dbPGPKeyData = pure $ base64Encode sqlKeyData
, dbPGPKeyExpires = pure sqlKeyExpires
, dbPGPKeyUploaded = pure sqlKeyUploaded
, dbPGPKeyComment = pure sqlKeyComment
}

View File

@ -0,0 +1,239 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Datarekisteri.Backend.Sql.Queries where
import Control.Monad.Logger (LoggingT)
import Data.Aeson (fromJSON, toJSON, Result(..))
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Database.Persist as Persist
import Database.Esqueleto.Experimental
import Datarekisteri.Backend.Types (MemberData(..))
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Core.Types
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 }
updateData (SetUserApplication x) memberData = memberData { application = x }
Persist.update key (userUpdates <> updates)
data UserUpdate = SetUserName Text
| SetUserNickname (Maybe Text)
| SetUserHomeplace Text
| SetUserPhoneNumber PhoneNumber
| SetUserApplication Text

View File

@ -0,0 +1,98 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Datarekisteri.Backend.Sql.Types where
import Data.ByteString (ByteString)
import Data.Text (Text)
import Database.Persist (Entity, Key, entityKey, PersistEntity)
import Database.Persist.Postgresql.JSON (Value)
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
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 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 #-}
@ -13,18 +18,19 @@ module Datarekisteri.Backend.Types where
import Relude
import "cryptonite" Crypto.Random (MonadRandom(..))
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(..))
import Datarekisteri.Core.Types
forward :: Monad m => [a] -> m [Maybe a]
forward = pure . map Just
@ -46,9 +52,102 @@ 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
, application :: 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
, dbUserTokens :: m [DBToken m]
, dbUserKeys :: m [DBPGPKey m]
, dbUserPrimaryKey :: m (Maybe (DBPGPKey m))
}
data DBPGPKey m = DBPGPKey
{ dbPGPKeyId :: m KeyID
, 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 +155,22 @@ 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]
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 +186,19 @@ 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
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 +218,44 @@ 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, Monad (t 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
, dbUserTokens = map liftToken <$> lift dbUserTokens
, dbUserKeys = map liftKey <$> lift dbUserKeys
, dbUserPrimaryKey = fmap liftKey <$> lift dbUserPrimaryKey
}
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
, dbPGPKeyData = lift dbPGPKeyData
, dbPGPKeyExpires = lift dbPGPKeyExpires
, dbPGPKeyUploaded = lift dbPGPKeyUploaded
, dbPGPKeyComment = lift dbPGPKeyComment
}

View File

@ -2,12 +2,15 @@
module Datarekisteri.Backend.Utils where
import "cryptonite" Crypto.Random (MonadRandom)
import Data.ByteArray.Encoding (convertToBase, Base(..))
import Data.ByteString (ByteString)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
import "cryptonite" Crypto.Random (MonadRandom)
import Datarekisteri.Backend.Types
base32 :: ByteString -> Text

View File

@ -12,13 +12,18 @@ 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 System.IO.Echo (withoutInputEcho)
import Options.Applicative
import Datarekisteri.Backend.Sql (MonadSql, runQuery)
import qualified Datarekisteri.Backend.Sql.Queries as Sql
import Datarekisteri.Backend.Sql.Types
import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils
import Datarekisteri.Core.Types
import Options.Applicative
import System.IO.Echo (withoutInputEcho)
main :: IO ()
main = do
@ -33,12 +38,13 @@ 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
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
@ -47,22 +53,21 @@ addUserMain AddUserOpts {..} = do
, phoneNumber = addUserPhoneNumber
}
}
_ <- addEmail $ DBEmail
{ dBEmailUid = toDBKey userID
, dBEmailEmail = addUserEmail
, dBEmailVid = Nothing
void $ 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 +129,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

4
backend/src/Main.hs Normal file
View File

@ -0,0 +1,4 @@
import qualified Datarekisteri.Backend as Backend
main :: IO ()
main = Backend.main

View File

@ -1,14 +1,17 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Core.Types where
import Relude
import qualified "base64" Data.ByteString.Base64 as B64
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Char (isSpace)
import Data.Morpheus.Server.Types (SCALAR)
@ -21,7 +24,6 @@ import Database.Persist.PersistValue (PersistValue(..))
import Database.Persist.Sql (PersistFieldSql(..))
import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64, decodeBase64)
import qualified Data.Text as T
base64Encode :: ByteString -> Base64

View File

@ -21,7 +21,6 @@ enum Unit {
type PGPKey {
id: KeyID!
user: User!
pgpKeyData: Base64!
expires: Time
uploaded: Time!
@ -30,7 +29,6 @@ type PGPKey {
type Token {
id: TokenID!
user: User!
name: String
tokenData: String!
comment: String!
@ -53,23 +51,23 @@ type User {
permissions: String!
isMember: Boolean!
application: String!
tokens: [Token!]!
keys: [PGPKey!]!
primaryKey: PGPKey
}
type Query {
users: [User!]!
user(id: UserID): User
applications: [User!]!
tokens(user: UserID): [Token!]!
keys(user: UserID): [PGPKey!]!
permissions: String!
primaryKey(user: UserID): PGPKey
}
type Mutation {
apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
verifyEmail(secret: String!): Unit!
resendVerificationEmail(user: UserID): Unit!
update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, user: UserID): User!
update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User!
newToken(comment: String, name: String, permissions: String): Token!
newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
accept(user: UserID!): Unit!

View File

@ -1,26 +1,27 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Relude hiding (get)
import Yesod
import Yesod.Auth
import System.Directory (createDirectoryIfMissing)
import Yesod.Static (static, Static)
import Yesod (mkYesodDispatch, warp)
import Yesod.Auth (getAuth)
import Options.Applicative
import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.Handlers
import Datarekisteri.Frontend.Auth ()
import Yesod.Static (static, Static)
import Options.Applicative
import System.Directory (createDirectoryIfMissing)
mkYesodDispatch "DataIdClient" resourcesDataIdClient

View File

@ -13,9 +13,10 @@ module Datarekisteri.Frontend.ApiRequests where
import Relude
import Data.Morpheus.Client
import Yesod hiding (Header)
import Yesod.Auth
import Data.Aeson (ToJSON, FromJSON)
import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders)
import Yesod (HandlerFor, getYesod, liftHandler)
import Yesod.Auth (YesodAuth, AuthId, requireAuthId, maybeAuthId)
type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
-- From Data.Morpheus.Client.Fetch.RequestType

View File

@ -1,12 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -14,11 +14,11 @@ module Datarekisteri.Frontend.Auth where
import Relude
import Datarekisteri.Core.Types
import Data.Morpheus.Client
import qualified "base64" Data.ByteString.Base64 as B64
import Yesod
import Yesod.Auth
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
import qualified Yesod.Auth.Message as Msg
pluginName = "externalBasic"

View File

@ -1,5 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -8,14 +8,16 @@ module Datarekisteri.Frontend.FormFields where
import Relude
import Yesod
import Datarekisteri.Frontend.Types
import Datarekisteri.Core.Types
import Datarekisteri.Frontend.Types
emailField :: Field Handler Email
emailField = Field
{ fieldParse = \rawValues _ ->
case rawValues of
[] -> pure $ Right Nothing
[""] -> pure $ Right Nothing
[x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x
_ -> pure $ Left $ "Expected one value"
, fieldView = \id name otherAttributes result isRequired ->
@ -41,6 +43,9 @@ telephoneField = Field
, fieldEnctype = UrlEncoded
}
textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
Textarea textareaField
verifiedPasswordField :: Field Handler Text
verifiedPasswordField = Field
{ fieldParse = \rawValues _ ->

View File

@ -1,31 +1,33 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Datarekisteri.Frontend.Handlers
( module Datarekisteri.Frontend.Handlers.Profile
, module Datarekisteri.Frontend.Handlers.Apply
, module Datarekisteri.Frontend.Handlers.Applications
, module Datarekisteri.Frontend.Handlers.VerifyEmail
, module Datarekisteri.Frontend.Handlers.Apply
, module Datarekisteri.Frontend.Handlers.Members
, module Datarekisteri.Frontend.Handlers.VerifyEmail
, getHomeR
) where
import Relude
import Yesod
import Yesod.Auth
import Datarekisteri.Frontend.Handlers.Profile
import Datarekisteri.Frontend.Handlers.Apply
import Datarekisteri.Frontend.Handlers.Applications
import Datarekisteri.Frontend.Handlers.VerifyEmail
import Datarekisteri.Frontend.Handlers.Members
import Datarekisteri.Frontend.Types
import Yesod
import Yesod.Auth
getHomeR :: Handler Html
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)

View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -14,15 +14,17 @@ module Datarekisteri.Frontend.Handlers.Applications where
import Relude hiding (id)
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types
import Data.Morpheus.Client
import Datarekisteri.Core.Types hiding (Applications)
import Data.Maybe (fromJust)
import Data.Time (Day)
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod hiding (emailField)
import Yesod.Auth
import Datarekisteri.Core.Types hiding (Applications)
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.FormFields
import Data.Time (Day)
import Data.Maybe (fromJust)
import Datarekisteri.Frontend.Types
declareLocalTypesInline "schema.gql" [raw|
query Applications {

View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -14,14 +14,16 @@ module Datarekisteri.Frontend.Handlers.Apply where
import Relude hiding (id)
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types
import Data.Morpheus.Client
import Datarekisteri.Core.Types
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Data.Time (Day)
import Yesod hiding (emailField)
import Yesod.Auth
import Datarekisteri.Core.Types
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.FormFields
import Data.Time (Day)
import Datarekisteri.Frontend.Types
declareLocalTypesInline "schema.gql" [raw|
mutation Apply($name: String!, $nickname: String, $homeplace: String!,
@ -46,8 +48,6 @@ applyForm = renderDivs $ ApplyArgs
where dayField' :: Field Handler Date
dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
(\(Date x) -> x) dayField
textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
Textarea textareaField
nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}

View File

@ -12,12 +12,14 @@ module Datarekisteri.Frontend.Handlers.Members where
import Relude hiding (id)
import Data.Morpheus.Client
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod
import Yesod.Auth
import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Core.Types
import Yesod
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw|
query MembersPage {

View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -14,14 +14,16 @@ module Datarekisteri.Frontend.Handlers.Profile where
import Relude hiding (id)
import Data.Maybe (fromJust)
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod hiding (emailField)
import Yesod.Auth
import Datarekisteri.Core.Types
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.FormFields
import Data.Morpheus.Client
import Datarekisteri.Core.Types
import Data.Maybe (fromJust)
import Yesod hiding (emailField)
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw|
query ProfilePage($id: UserID) {
@ -35,14 +37,15 @@ query ProfilePage($id: UserID) {
birthdate
phoneNumber
isMember
application
}
permissions
}
|]
declareLocalTypesInline "schema.gql" [raw|
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber) {
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber, $application: String) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber, application: $application) {
id
}
}
@ -71,9 +74,12 @@ profileForm userID user extraHtml = do
(maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user)
(applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus"
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in application) user)
let profileUpdateRes = UpdateProfileArgs userID <$>
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
canUpdateApplication = maybe False (\x -> let ProfilePageUser {..} = x in not isMember) user
inputField FieldView {..} = [whamlet|
<label for="#{fvId}">
^{fvLabel}
@ -91,6 +97,8 @@ profileForm userID user extraHtml = do
<a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
odottaa vahvistusta. #
<a href="@{VerifyEmailR}">Siirry vahvistamaan
$if canUpdateApplication
^{inputField applicationView}
|]
return (profileUpdateRes, widget)

View File

@ -1,11 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
@ -13,12 +13,14 @@ module Datarekisteri.Frontend.Handlers.VerifyEmail where
import Relude
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Yesod
import Yesod.Auth
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types
import Datarekisteri.Core.Types
import Data.Morpheus.Client
import Yesod
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw|
mutation VerifyEmail($secret: String!) {

View File

@ -16,20 +16,22 @@
module Datarekisteri.Frontend.Types where
import Relude hiding (id)
import Relude.Extra.Foldable1 (maximum1)
import Yesod
import Yesod.Core.Handler (getCurrentRoute)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Auth
import Yesod.Static
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
import Data.Map (findWithDefault)
import Data.Morpheus.Client (raw, declareLocalTypesInline)
import Data.Time (getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Datarekisteri.Frontend.Auth
import Relude.Extra.Foldable1 (maximum1)
import Yesod.Core.Handler (getCurrentRoute)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod
import Yesod.Auth
import Yesod.Static
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
import Datarekisteri.Frontend.ApiRequests
import Data.Morpheus.Client
import Data.Map (findWithDefault)
import Datarekisteri.Frontend.Auth
data DataIdClient = DataIdClient
{ getStatic :: Static