Compare commits
8 Commits
d2f1b07922
...
b3737b312b
Author | SHA1 | Date |
---|---|---|
Saku Laesvuori | b3737b312b | |
Saku Laesvuori | 3816c15ce6 | |
Saku Laesvuori | 1074b6a2d5 | |
Saku Laesvuori | cd3e45a045 | |
Saku Laesvuori | dfbdb0cf99 | |
Saku Laesvuori | c85f093a60 | |
Saku Laesvuori | 4ef8890a19 | |
Saku Laesvuori | 3942d547e0 |
|
@ -1 +1,2 @@
|
||||||
**/db/schema.sql
|
**/db/schema.sql
|
||||||
|
**/client_session_key.aes
|
||||||
|
|
|
@ -30,6 +30,7 @@
|
||||||
ghc-base64
|
ghc-base64
|
||||||
ghc-cryptonite
|
ghc-cryptonite
|
||||||
ghc-datarekisteri-core
|
ghc-datarekisteri-core
|
||||||
|
ghc-data-default
|
||||||
ghc-echo
|
ghc-echo
|
||||||
ghc-email-validate
|
ghc-email-validate
|
||||||
ghc-esqueleto
|
ghc-esqueleto
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
import Data.Morpheus.Types (render, App)
|
import Data.Morpheus.Types (render, App)
|
||||||
import Server.API (coreApp)
|
import Datarekisteri.Backend.API (coreApp)
|
||||||
import qualified Data.ByteString.Lazy.Char8 as C8
|
import qualified Data.ByteString.Lazy.Char8 as C8
|
||||||
import Server (APIM)
|
import Datarekisteri.Backend (APIM)
|
||||||
|
|
||||||
main = C8.putStrLn $ render (coreApp :: App () APIM)
|
main = C8.putStrLn $ render (coreApp :: App () APIM)
|
||||||
|
|
|
@ -16,8 +16,10 @@ executable datarekisteri-backend
|
||||||
base64,
|
base64,
|
||||||
cryptonite,
|
cryptonite,
|
||||||
datarekisteri-core,
|
datarekisteri-core,
|
||||||
|
data-default,
|
||||||
email-validate,
|
email-validate,
|
||||||
esqueleto,
|
esqueleto,
|
||||||
|
http-types,
|
||||||
memory,
|
memory,
|
||||||
mime-mail,
|
mime-mail,
|
||||||
monad-logger,
|
monad-logger,
|
||||||
|
@ -41,11 +43,14 @@ executable datarekisteri-backend
|
||||||
wai-cors,
|
wai-cors,
|
||||||
wai-extra,
|
wai-extra,
|
||||||
directory
|
directory
|
||||||
main-is: Datarekisteri/Backend.hs
|
main-is: Main.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Datarekisteri.Backend,
|
||||||
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 +87,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
|
||||||
|
|
|
@ -5,31 +5,42 @@
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
module Datarekisteri.Backend where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
import "cryptonite" Crypto.Random (MonadRandom(..))
|
import "cryptonite" Crypto.Random (MonadRandom(..))
|
||||||
|
import qualified "base64" Data.ByteString.Base64 as B64
|
||||||
|
|
||||||
|
import Control.Monad.Except (catchError)
|
||||||
import Control.Monad.Logger (runStderrLoggingT)
|
import Control.Monad.Logger (runStderrLoggingT)
|
||||||
|
import Data.Default (def)
|
||||||
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 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 (CorsResourcePolicy(..), cors)
|
||||||
import Network.Wai.Middleware.Gzip
|
import Network.Wai.Middleware.Gzip (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 System.Directory (findExecutable)
|
import System.Directory (findExecutable)
|
||||||
import System.Process (callProcess)
|
import System.Process (callProcess)
|
||||||
import Options.Applicative hiding (header)
|
|
||||||
import qualified Options.Applicative as O
|
import qualified Options.Applicative as O
|
||||||
|
|
||||||
|
import Options.Applicative hiding (Success, header)
|
||||||
import Web.Scotty.Trans hiding (readEither)
|
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
|
import Paths_datarekisteri_backend
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -101,10 +112,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 +139,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 +176,26 @@ 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
|
||||||
|
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 +234,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
|
||||||
|
|
|
@ -8,9 +8,9 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
{-# LANGUAGE PackageImports #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
|
|
||||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
@ -18,24 +18,23 @@
|
||||||
|
|
||||||
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 qualified "base64" Data.ByteString.Base64 as B64
|
||||||
import Data.Aeson (fromJSON, Result(..), toJSON)
|
|
||||||
import Data.Maybe (fromJust)
|
import Control.Monad.Except (MonadError, throwError, catchError)
|
||||||
import Data.Morpheus.Server (deriveApp, runApp)
|
import Data.Morpheus.Server (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 qualified Data.Text as T
|
||||||
|
|
||||||
|
import Datarekisteri.Backend.Email
|
||||||
import Datarekisteri.Backend.DB
|
import Datarekisteri.Backend.DB
|
||||||
import Datarekisteri.Backend.DB.Queries
|
|
||||||
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
|
|
||||||
import Datarekisteri.Backend.Types
|
import Datarekisteri.Backend.Types
|
||||||
import Datarekisteri.Backend.Utils
|
import Datarekisteri.Backend.Utils
|
||||||
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
|
import Datarekisteri.Core.Types
|
||||||
import qualified Data.Text as T (null, chunksOf, intercalate)
|
|
||||||
|
|
||||||
-- General functions, maybe migrate to Utils or API.Utils
|
-- 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 :: 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
|
|
||||||
let email = dBEmailEmail dbEmail
|
|
||||||
void $ sendVerificationEmail secret email
|
|
||||||
|
|
||||||
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
|
updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
|
||||||
UserID -> UpdateData -> m UserID
|
UpdateArgs -> UserID -> m UpdateData
|
||||||
updateUser user (UpdateData {..}) = do
|
updateArgsToData UpdateArgs {..} user = do
|
||||||
hash <- sequence $ hashPassword <$> password
|
when (maybe False T.null name) $ throwError "Name must not be empty"
|
||||||
-- TODO: assert stuff valid
|
when (maybe False T.null password) $ throwError "Password must not be empty"
|
||||||
user <- updateUserData user
|
when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
|
||||||
(catMaybes [(DBUserPasswordCrypt =.) <$> hash])
|
isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
|
||||||
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
|
when (isMember && isJust application) $ throwError "Members can't update their applications"
|
||||||
SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
|
passwordHash <- sequence $ hashPassword <$> password
|
||||||
case email of
|
updateTime <- currentTime
|
||||||
Nothing -> pure Unit
|
|
||||||
Just email' -> do
|
|
||||||
verificationSecret <- genVerificationSecret
|
verificationSecret <- genVerificationSecret
|
||||||
emailKey <- updateEmail user email' verificationSecret
|
pure UpdateData {..}
|
||||||
sendVerificationSecret emailKey
|
|
||||||
return user
|
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) =>
|
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 ->
|
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
|
||||||
requirePermission (Tokens user) ReadOnly >> map dbTokenToToken <$> getUserTokens user
|
|
||||||
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> applicants
|
|
||||||
, keys = \(Arg id) -> targetUser id >>= \user ->
|
|
||||||
requirePermission (Profile user) ReadOnly >> map dbKeyToPGPKey <$> getKeys user
|
|
||||||
--, key = \(Arg id) -> resolve (pure id)
|
|
||||||
-- TODO is this actually useful
|
|
||||||
, primaryKey = \(Arg id) -> targetUser id >>= \user ->
|
|
||||||
requirePermission (Profile user) ReadOnly >> getPrimaryKey user >>= pure . fmap dbKeyToPGPKey
|
|
||||||
, permissions = currentPermissions
|
, 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 +184,34 @@ 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
|
||||||
|
, 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
|
data User m = User
|
||||||
{ id :: m UserID
|
{ id :: m UserID
|
||||||
, email :: m (Maybe Email)
|
, email :: m (Maybe Email)
|
||||||
|
@ -276,11 +226,13 @@ data User m = User
|
||||||
, permissions :: m Text
|
, permissions :: m Text
|
||||||
, isMember :: m Bool
|
, isMember :: m Bool
|
||||||
, application :: m Text
|
, application :: m Text
|
||||||
|
, tokens :: m [Token m]
|
||||||
|
, keys :: m [PGPKey m]
|
||||||
|
, primaryKey :: m (Maybe (PGPKey m))
|
||||||
} deriving (Generic, GQLType)
|
} deriving (Generic, GQLType)
|
||||||
|
|
||||||
data PGPKey m = PGPKey
|
data PGPKey m = PGPKey
|
||||||
{ id :: m KeyID
|
{ id :: m KeyID
|
||||||
, user :: m (User m)
|
|
||||||
, pgpKeyData :: m Base64
|
, pgpKeyData :: m Base64
|
||||||
, expires :: m (Maybe Time)
|
, expires :: m (Maybe Time)
|
||||||
, uploaded :: m Time
|
, uploaded :: m Time
|
||||||
|
@ -289,7 +241,6 @@ data PGPKey m = PGPKey
|
||||||
|
|
||||||
data Token m = Token
|
data Token m = Token
|
||||||
{ id :: m TokenID
|
{ id :: m TokenID
|
||||||
, user :: m (User m)
|
|
||||||
, name :: m (Maybe Text)
|
, name :: m (Maybe Text)
|
||||||
, tokenData :: m Text
|
, tokenData :: m Text
|
||||||
, comment :: m Text
|
, comment :: m Text
|
||||||
|
@ -298,57 +249,60 @@ 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))
|
||||||
, applications :: m [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
|
, permissions :: m Text
|
||||||
--, key :: Arg "id" KeyID -> m (PGPKey m)
|
|
||||||
, primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
|
|
||||||
} 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 :: (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
|
||||||
|
}
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
|
@ -2,11 +2,12 @@
|
||||||
|
|
||||||
module Datarekisteri.Backend.Email where
|
module Datarekisteri.Backend.Email where
|
||||||
|
|
||||||
import Datarekisteri.Backend.Types
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Lazy (fromStrict)
|
import Data.Text.Lazy (fromStrict)
|
||||||
|
import Network.Mail.Mime (Address(..), simpleMail')
|
||||||
|
|
||||||
|
import Datarekisteri.Backend.Types
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
import Network.Mail.Mime
|
|
||||||
|
|
||||||
sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m ()
|
sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m ()
|
||||||
sendDatarekisteriEmail subject content to = do
|
sendDatarekisteriEmail subject content to = do
|
||||||
|
|
|
@ -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
|
||||||
|
}
|
|
@ -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
|
|
@ -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
|
|
@ -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 #-}
|
||||||
|
|
||||||
|
@ -13,18 +18,19 @@ module Datarekisteri.Backend.Types where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
|
import "cryptonite" Crypto.Random (MonadRandom(..))
|
||||||
|
|
||||||
import Control.Monad.Except (throwError)
|
import Control.Monad.Except (throwError)
|
||||||
import Control.Monad.Logger (LoggingT)
|
|
||||||
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 Datarekisteri.Core.Types
|
||||||
|
|
||||||
forward :: Monad m => [a] -> m [Maybe a]
|
forward :: Monad m => [a] -> m [Maybe a]
|
||||||
forward = pure . map Just
|
forward = pure . map Just
|
||||||
|
@ -46,9 +52,102 @@ 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
|
||||||
|
, 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
|
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
|
||||||
|
, 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
|
class Monad m => MonadTime m where
|
||||||
currentTime :: m Time
|
currentTime :: m Time
|
||||||
|
@ -56,11 +155,22 @@ 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]
|
||||||
|
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 +186,19 @@ 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
|
||||||
|
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 +218,44 @@ 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, 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
|
||||||
|
}
|
||||||
|
|
|
@ -2,12 +2,15 @@
|
||||||
|
|
||||||
module Datarekisteri.Backend.Utils where
|
module Datarekisteri.Backend.Utils where
|
||||||
|
|
||||||
|
import "cryptonite" Crypto.Random (MonadRandom)
|
||||||
|
|
||||||
import Data.ByteArray.Encoding (convertToBase, Base(..))
|
import Data.ByteArray.Encoding (convertToBase, Base(..))
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
|
|
||||||
import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
|
import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
|
||||||
import "cryptonite" Crypto.Random (MonadRandom)
|
|
||||||
import Datarekisteri.Backend.Types
|
import Datarekisteri.Backend.Types
|
||||||
|
|
||||||
base32 :: ByteString -> Text
|
base32 :: ByteString -> Text
|
||||||
|
|
|
@ -12,13 +12,18 @@ 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 System.IO.Echo (withoutInputEcho)
|
||||||
import Datarekisteri.Backend.DB.Queries
|
|
||||||
|
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.Types
|
||||||
import Datarekisteri.Backend.Utils
|
import Datarekisteri.Backend.Utils
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
import Options.Applicative
|
|
||||||
import System.IO.Echo (withoutInputEcho)
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
|
@ -33,12 +38,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 +53,21 @@ addUserMain AddUserOpts {..} = do
|
||||||
, phoneNumber = addUserPhoneNumber
|
, phoneNumber = addUserPhoneNumber
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
_ <- addEmail $ DBEmail
|
void $ Sql.addEmail $ SqlEmail
|
||||||
{ dBEmailUid = toDBKey userID
|
{ sqlEmailUid = fromID userID
|
||||||
, dBEmailEmail = addUserEmail
|
, sqlEmailEmail = addUserEmail
|
||||||
, dBEmailVid = Nothing
|
, sqlEmailVid = Nothing
|
||||||
}
|
}
|
||||||
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 +129,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
|
||||||
|
|
|
@ -0,0 +1,4 @@
|
||||||
|
import qualified Datarekisteri.Backend as Backend
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = Backend.main
|
|
@ -1,14 +1,17 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
{-# LANGUAGE PackageImports #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Datarekisteri.Core.Types where
|
module Datarekisteri.Core.Types where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
|
import qualified "base64" Data.ByteString.Base64 as B64
|
||||||
|
|
||||||
import Data.Aeson (ToJSON(..), FromJSON(..))
|
import Data.Aeson (ToJSON(..), FromJSON(..))
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.Morpheus.Server.Types (SCALAR)
|
import Data.Morpheus.Server.Types (SCALAR)
|
||||||
|
@ -21,7 +24,6 @@ import Database.Persist.PersistValue (PersistValue(..))
|
||||||
import Database.Persist.Sql (PersistFieldSql(..))
|
import Database.Persist.Sql (PersistFieldSql(..))
|
||||||
import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
|
import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
|
||||||
|
|
||||||
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64, decodeBase64)
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
base64Encode :: ByteString -> Base64
|
base64Encode :: ByteString -> Base64
|
||||||
|
|
|
@ -21,7 +21,6 @@ enum Unit {
|
||||||
|
|
||||||
type PGPKey {
|
type PGPKey {
|
||||||
id: KeyID!
|
id: KeyID!
|
||||||
user: User!
|
|
||||||
pgpKeyData: Base64!
|
pgpKeyData: Base64!
|
||||||
expires: Time
|
expires: Time
|
||||||
uploaded: Time!
|
uploaded: Time!
|
||||||
|
@ -30,7 +29,6 @@ type PGPKey {
|
||||||
|
|
||||||
type Token {
|
type Token {
|
||||||
id: TokenID!
|
id: TokenID!
|
||||||
user: User!
|
|
||||||
name: String
|
name: String
|
||||||
tokenData: String!
|
tokenData: String!
|
||||||
comment: String!
|
comment: String!
|
||||||
|
@ -53,23 +51,23 @@ type User {
|
||||||
permissions: String!
|
permissions: String!
|
||||||
isMember: Boolean!
|
isMember: Boolean!
|
||||||
application: String!
|
application: String!
|
||||||
|
tokens: [Token!]!
|
||||||
|
keys: [PGPKey!]!
|
||||||
|
primaryKey: PGPKey
|
||||||
}
|
}
|
||||||
|
|
||||||
type Query {
|
type Query {
|
||||||
users: [User!]!
|
users: [User!]!
|
||||||
user(id: UserID): User
|
user(id: UserID): User
|
||||||
applications: [User!]!
|
applications: [User!]!
|
||||||
tokens(user: UserID): [Token!]!
|
|
||||||
keys(user: UserID): [PGPKey!]!
|
|
||||||
permissions: String!
|
permissions: String!
|
||||||
primaryKey(user: UserID): PGPKey
|
|
||||||
}
|
}
|
||||||
|
|
||||||
type Mutation {
|
type Mutation {
|
||||||
apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
|
apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
|
||||||
verifyEmail(secret: String!): Unit!
|
verifyEmail(secret: String!): Unit!
|
||||||
resendVerificationEmail(user: UserID): 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!
|
newToken(comment: String, name: String, permissions: String): Token!
|
||||||
newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
|
newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
|
||||||
accept(user: UserID!): Unit!
|
accept(user: UserID!): Unit!
|
||||||
|
|
|
@ -1,26 +1,27 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
import Relude hiding (get)
|
import Relude hiding (get)
|
||||||
|
|
||||||
import Yesod
|
import System.Directory (createDirectoryIfMissing)
|
||||||
import Yesod.Auth
|
import Yesod.Static (static, Static)
|
||||||
|
import Yesod (mkYesodDispatch, warp)
|
||||||
|
import Yesod.Auth (getAuth)
|
||||||
|
|
||||||
|
import Options.Applicative
|
||||||
|
|
||||||
import Datarekisteri.Frontend.Types
|
import Datarekisteri.Frontend.Types
|
||||||
import Datarekisteri.Frontend.Handlers
|
import Datarekisteri.Frontend.Handlers
|
||||||
import Datarekisteri.Frontend.Auth ()
|
|
||||||
import Yesod.Static (static, Static)
|
|
||||||
import Options.Applicative
|
|
||||||
import System.Directory (createDirectoryIfMissing)
|
|
||||||
|
|
||||||
mkYesodDispatch "DataIdClient" resourcesDataIdClient
|
mkYesodDispatch "DataIdClient" resourcesDataIdClient
|
||||||
|
|
||||||
|
|
|
@ -13,9 +13,10 @@ module Datarekisteri.Frontend.ApiRequests where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
import Data.Morpheus.Client
|
import Data.Aeson (ToJSON, FromJSON)
|
||||||
import Yesod hiding (Header)
|
import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders)
|
||||||
import Yesod.Auth
|
import Yesod (HandlerFor, getYesod, liftHandler)
|
||||||
|
import Yesod.Auth (YesodAuth, AuthId, requireAuthId, maybeAuthId)
|
||||||
|
|
||||||
type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
|
type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
|
||||||
-- From Data.Morpheus.Client.Fetch.RequestType
|
-- From Data.Morpheus.Client.Fetch.RequestType
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PackageImports #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
@ -14,11 +14,11 @@ module Datarekisteri.Frontend.Auth where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
import Datarekisteri.Core.Types
|
import qualified "base64" Data.ByteString.Base64 as B64
|
||||||
import Data.Morpheus.Client
|
|
||||||
import Yesod
|
import Yesod
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
|
|
||||||
import qualified Yesod.Auth.Message as Msg
|
import qualified Yesod.Auth.Message as Msg
|
||||||
|
|
||||||
pluginName = "externalBasic"
|
pluginName = "externalBasic"
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
@ -8,14 +8,16 @@ module Datarekisteri.Frontend.FormFields where
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
import Yesod
|
import Yesod
|
||||||
import Datarekisteri.Frontend.Types
|
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
|
import Datarekisteri.Frontend.Types
|
||||||
|
|
||||||
emailField :: Field Handler Email
|
emailField :: Field Handler Email
|
||||||
emailField = Field
|
emailField = Field
|
||||||
{ fieldParse = \rawValues _ ->
|
{ fieldParse = \rawValues _ ->
|
||||||
case rawValues of
|
case rawValues of
|
||||||
[] -> pure $ Right Nothing
|
[] -> pure $ Right Nothing
|
||||||
|
[""] -> pure $ Right Nothing
|
||||||
[x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x
|
[x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x
|
||||||
_ -> pure $ Left $ "Expected one value"
|
_ -> pure $ Left $ "Expected one value"
|
||||||
, fieldView = \id name otherAttributes result isRequired ->
|
, fieldView = \id name otherAttributes result isRequired ->
|
||||||
|
@ -41,6 +43,9 @@ telephoneField = Field
|
||||||
, fieldEnctype = UrlEncoded
|
, fieldEnctype = UrlEncoded
|
||||||
}
|
}
|
||||||
|
|
||||||
|
textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
|
||||||
|
Textarea textareaField
|
||||||
|
|
||||||
verifiedPasswordField :: Field Handler Text
|
verifiedPasswordField :: Field Handler Text
|
||||||
verifiedPasswordField = Field
|
verifiedPasswordField = Field
|
||||||
{ fieldParse = \rawValues _ ->
|
{ fieldParse = \rawValues _ ->
|
||||||
|
|
|
@ -1,31 +1,33 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
|
||||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Datarekisteri.Frontend.Handlers
|
module Datarekisteri.Frontend.Handlers
|
||||||
( module Datarekisteri.Frontend.Handlers.Profile
|
( module Datarekisteri.Frontend.Handlers.Profile
|
||||||
, module Datarekisteri.Frontend.Handlers.Apply
|
|
||||||
, module Datarekisteri.Frontend.Handlers.Applications
|
, module Datarekisteri.Frontend.Handlers.Applications
|
||||||
, module Datarekisteri.Frontend.Handlers.VerifyEmail
|
, module Datarekisteri.Frontend.Handlers.Apply
|
||||||
, module Datarekisteri.Frontend.Handlers.Members
|
, module Datarekisteri.Frontend.Handlers.Members
|
||||||
|
, module Datarekisteri.Frontend.Handlers.VerifyEmail
|
||||||
, getHomeR
|
, getHomeR
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
|
import Yesod
|
||||||
|
import Yesod.Auth
|
||||||
|
|
||||||
import Datarekisteri.Frontend.Handlers.Profile
|
import Datarekisteri.Frontend.Handlers.Profile
|
||||||
import Datarekisteri.Frontend.Handlers.Apply
|
import Datarekisteri.Frontend.Handlers.Apply
|
||||||
import Datarekisteri.Frontend.Handlers.Applications
|
import Datarekisteri.Frontend.Handlers.Applications
|
||||||
import Datarekisteri.Frontend.Handlers.VerifyEmail
|
import Datarekisteri.Frontend.Handlers.VerifyEmail
|
||||||
import Datarekisteri.Frontend.Handlers.Members
|
import Datarekisteri.Frontend.Handlers.Members
|
||||||
import Datarekisteri.Frontend.Types
|
import Datarekisteri.Frontend.Types
|
||||||
import Yesod
|
|
||||||
import Yesod.Auth
|
|
||||||
|
|
||||||
getHomeR :: Handler Html
|
getHomeR :: Handler Html
|
||||||
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
|
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
@ -14,15 +14,17 @@ module Datarekisteri.Frontend.Handlers.Applications where
|
||||||
|
|
||||||
import Relude hiding (id)
|
import Relude hiding (id)
|
||||||
|
|
||||||
import Datarekisteri.Frontend.ApiRequests
|
import Data.Maybe (fromJust)
|
||||||
import Datarekisteri.Frontend.Types
|
import Data.Time (Day)
|
||||||
import Data.Morpheus.Client
|
import Data.Morpheus.Client (raw, declareLocalTypesInline)
|
||||||
import Datarekisteri.Core.Types hiding (Applications)
|
|
||||||
import Yesod hiding (emailField)
|
import Yesod hiding (emailField)
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
|
|
||||||
|
import Datarekisteri.Core.Types hiding (Applications)
|
||||||
|
import Datarekisteri.Frontend.ApiRequests
|
||||||
import Datarekisteri.Frontend.FormFields
|
import Datarekisteri.Frontend.FormFields
|
||||||
import Data.Time (Day)
|
import Datarekisteri.Frontend.Types
|
||||||
import Data.Maybe (fromJust)
|
|
||||||
|
|
||||||
declareLocalTypesInline "schema.gql" [raw|
|
declareLocalTypesInline "schema.gql" [raw|
|
||||||
query Applications {
|
query Applications {
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
@ -14,14 +14,16 @@ module Datarekisteri.Frontend.Handlers.Apply where
|
||||||
|
|
||||||
import Relude hiding (id)
|
import Relude hiding (id)
|
||||||
|
|
||||||
import Datarekisteri.Frontend.ApiRequests
|
import Data.Morpheus.Client (raw, declareLocalTypesInline)
|
||||||
import Datarekisteri.Frontend.Types
|
import Data.Time (Day)
|
||||||
import Data.Morpheus.Client
|
|
||||||
import Datarekisteri.Core.Types
|
|
||||||
import Yesod hiding (emailField)
|
import Yesod hiding (emailField)
|
||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
|
|
||||||
|
import Datarekisteri.Core.Types
|
||||||
|
import Datarekisteri.Frontend.ApiRequests
|
||||||
import Datarekisteri.Frontend.FormFields
|
import Datarekisteri.Frontend.FormFields
|
||||||
import Data.Time (Day)
|
import Datarekisteri.Frontend.Types
|
||||||
|
|
||||||
declareLocalTypesInline "schema.gql" [raw|
|
declareLocalTypesInline "schema.gql" [raw|
|
||||||
mutation Apply($name: String!, $nickname: String, $homeplace: String!,
|
mutation Apply($name: String!, $nickname: String, $homeplace: String!,
|
||||||
|
@ -46,8 +48,6 @@ applyForm = renderDivs $ ApplyArgs
|
||||||
where dayField' :: Field Handler Date
|
where dayField' :: Field Handler Date
|
||||||
dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
|
dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
|
||||||
(\(Date x) -> x) dayField
|
(\(Date x) -> x) dayField
|
||||||
textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
|
|
||||||
Textarea textareaField
|
|
||||||
nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
|
nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
|
||||||
nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
|
nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
|
||||||
homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}
|
homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}
|
||||||
|
|
|
@ -12,12 +12,14 @@ module Datarekisteri.Frontend.Handlers.Members where
|
||||||
|
|
||||||
import Relude hiding (id)
|
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.Types
|
||||||
import Datarekisteri.Frontend.ApiRequests
|
import Datarekisteri.Frontend.ApiRequests
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
import Yesod
|
|
||||||
import Yesod.Auth
|
|
||||||
|
|
||||||
declareLocalTypesInline "schema.gql" [raw|
|
declareLocalTypesInline "schema.gql" [raw|
|
||||||
query MembersPage {
|
query MembersPage {
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
@ -14,14 +14,16 @@ module Datarekisteri.Frontend.Handlers.Profile where
|
||||||
|
|
||||||
import Relude hiding (id)
|
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.ApiRequests
|
||||||
import Datarekisteri.Frontend.Types
|
import Datarekisteri.Frontend.Types
|
||||||
import Datarekisteri.Frontend.FormFields
|
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|
|
declareLocalTypesInline "schema.gql" [raw|
|
||||||
query ProfilePage($id: UserID) {
|
query ProfilePage($id: UserID) {
|
||||||
|
@ -35,14 +37,15 @@ query ProfilePage($id: UserID) {
|
||||||
birthdate
|
birthdate
|
||||||
phoneNumber
|
phoneNumber
|
||||||
isMember
|
isMember
|
||||||
|
application
|
||||||
}
|
}
|
||||||
permissions
|
permissions
|
||||||
}
|
}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
declareLocalTypesInline "schema.gql" [raw|
|
declareLocalTypesInline "schema.gql" [raw|
|
||||||
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $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) {
|
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber, application: $application) {
|
||||||
id
|
id
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -71,9 +74,12 @@ profileForm userID user extraHtml = do
|
||||||
(maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
|
(maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
|
||||||
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
|
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
|
||||||
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user)
|
(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 <$>
|
let profileUpdateRes = UpdateProfileArgs userID <$>
|
||||||
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
|
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
|
||||||
maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
|
maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
|
||||||
|
canUpdateApplication = maybe False (\x -> let ProfilePageUser {..} = x in not isMember) user
|
||||||
inputField FieldView {..} = [whamlet|
|
inputField FieldView {..} = [whamlet|
|
||||||
<label for="#{fvId}">
|
<label for="#{fvId}">
|
||||||
^{fvLabel}
|
^{fvLabel}
|
||||||
|
@ -91,6 +97,8 @@ profileForm userID user extraHtml = do
|
||||||
<a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
|
<a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
|
||||||
odottaa vahvistusta. #
|
odottaa vahvistusta. #
|
||||||
<a href="@{VerifyEmailR}">Siirry vahvistamaan
|
<a href="@{VerifyEmailR}">Siirry vahvistamaan
|
||||||
|
$if canUpdateApplication
|
||||||
|
^{inputField applicationView}
|
||||||
|]
|
|]
|
||||||
return (profileUpdateRes, widget)
|
return (profileUpdateRes, widget)
|
||||||
|
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
|
@ -13,12 +13,14 @@ module Datarekisteri.Frontend.Handlers.VerifyEmail where
|
||||||
|
|
||||||
import Relude
|
import Relude
|
||||||
|
|
||||||
|
import Data.Morpheus.Client (raw, declareLocalTypesInline)
|
||||||
|
|
||||||
|
import Yesod
|
||||||
|
import Yesod.Auth
|
||||||
|
|
||||||
import Datarekisteri.Frontend.ApiRequests
|
import Datarekisteri.Frontend.ApiRequests
|
||||||
import Datarekisteri.Frontend.Types
|
import Datarekisteri.Frontend.Types
|
||||||
import Datarekisteri.Core.Types
|
import Datarekisteri.Core.Types
|
||||||
import Data.Morpheus.Client
|
|
||||||
import Yesod
|
|
||||||
import Yesod.Auth
|
|
||||||
|
|
||||||
declareLocalTypesInline "schema.gql" [raw|
|
declareLocalTypesInline "schema.gql" [raw|
|
||||||
mutation VerifyEmail($secret: String!) {
|
mutation VerifyEmail($secret: String!) {
|
||||||
|
|
|
@ -16,20 +16,22 @@
|
||||||
module Datarekisteri.Frontend.Types where
|
module Datarekisteri.Frontend.Types where
|
||||||
|
|
||||||
import Relude hiding (id)
|
import Relude hiding (id)
|
||||||
import Relude.Extra.Foldable1 (maximum1)
|
|
||||||
|
|
||||||
import Yesod
|
import Data.Map (findWithDefault)
|
||||||
import Yesod.Core.Handler (getCurrentRoute)
|
import Data.Morpheus.Client (raw, declareLocalTypesInline)
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
|
||||||
import Yesod.Auth
|
|
||||||
import Yesod.Static
|
|
||||||
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
|
|
||||||
import Data.Time (getCurrentTime)
|
import Data.Time (getCurrentTime)
|
||||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
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 Datarekisteri.Frontend.ApiRequests
|
||||||
import Data.Morpheus.Client
|
import Datarekisteri.Frontend.Auth
|
||||||
import Data.Map (findWithDefault)
|
|
||||||
|
|
||||||
data DataIdClient = DataIdClient
|
data DataIdClient = DataIdClient
|
||||||
{ getStatic :: Static
|
{ getStatic :: Static
|
||||||
|
|
Loading…
Reference in New Issue