Don't try to parse empty email fields

.gitignore

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

.guix/modules/datarekisteri-package.scm

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

PrintSchema.hs

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

backend/datarekisteri-backend.cabal

@@ -16,8 +16,10 @@ executable datarekisteri-backend
     base64,
     cryptonite,
     datarekisteri-core,
+    data-default,
     email-validate,
     esqueleto,
+    http-types,
     memory,
     mime-mail,
     monad-logger,
@@ -41,11 +43,14 @@ executable datarekisteri-backend
     wai-cors,
     wai-extra,
     directory
-  main-is: Datarekisteri/Backend.hs
+  main-is: Main.hs
   other-modules:
+    Datarekisteri.Backend,
     Datarekisteri.Backend.API,
     Datarekisteri.Backend.DB,
-    Datarekisteri.Backend.DB.Queries,
+    Datarekisteri.Backend.Sql,
+    Datarekisteri.Backend.Sql.Types,
+    Datarekisteri.Backend.Sql.Queries,
     Datarekisteri.Backend.Email,
     Datarekisteri.Backend.Types,
     Datarekisteri.Backend.Utils,
@@ -82,8 +87,9 @@ executable datarekisteri-cli
     time
   main-is: Datarekisteri/CLI.hs
   other-modules:
-    Datarekisteri.Backend.DB,
+    Datarekisteri.Backend.Sql,
-    Datarekisteri.Backend.DB.Queries,
+    Datarekisteri.Backend.Sql.Types,
+    Datarekisteri.Backend.Sql.Queries,
     Datarekisteri.Backend.Types,
     Datarekisteri.Backend.Utils,
   hs-source-dirs: src

backend/src/Datarekisteri/Backend.hs

@@ -5,31 +5,42 @@
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
+module Datarekisteri.Backend where
+
 import Relude
 
 import "cryptonite" Crypto.Random (MonadRandom(..))
+import qualified "base64" Data.ByteString.Base64 as B64
+
+import Control.Monad.Except (catchError)
 import Control.Monad.Logger (runStderrLoggingT)
+import Data.Default (def)
 import Data.Map (findWithDefault)
 import Data.Text (toLower, breakOn, stripPrefix)
-import Database.Persist (entityVal)
 import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
-import Datarekisteri.Core.Types
+import Network.HTTP.Types.Status (status500, status401)
 import Network.Mail.Mime (renderSendMailCustom, Address(..))
 import Network.Wai (Application)
 import Network.Wai.Handler.Warp (Port, run)
-import Network.Wai.Middleware.Cors
+import Network.Wai.Middleware.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.Process (callProcess)
-import Options.Applicative hiding (header)
+
 import qualified Options.Applicative as O
+
+import Options.Applicative hiding (Success, header)
 import Web.Scotty.Trans hiding (readEither)
-import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
+
+import Datarekisteri.Backend.Sql (MonadSql)
+import Datarekisteri.Backend.Utils (checkPassword)
+
+import qualified Datarekisteri.Backend.Sql as Sql
+
+import Datarekisteri.Backend.API
+import Datarekisteri.Backend.Types
+import Datarekisteri.Core.Types
+
 import Paths_datarekisteri_backend
 
 main :: IO ()
@@ -101,10 +112,15 @@ parseBearer auth = do
 authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
 authBearer Nothing m = m
 authBearer (Just (BearerToken bearer)) m = do
-    token <- lift $ getToken bearer
+    let 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
-        { stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token
+        { stateCurrentUser = user
         , statePermissions = permissions
         }
 
@@ -123,21 +139,23 @@ parseBasic txt = do
 authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
 authBasic Nothing m = m
 authBasic (Just basic) m = do
-    user <- verifyBasic basic
+    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
-        { stateCurrentUser = user
+        { stateCurrentUser = Just userID
         , 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
-    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)
     deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
@@ -158,10 +176,26 @@ data Config = Config
 instance MonadTime APIM where
     currentTime = liftIO currentTime
 
-instance MonadDB APIM where
+instance MonadSql APIM where
     runQuery query = do
-        dbUrl <- asks $ configDbUrl . stateConfig
+        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
     sendEmail email = do
@@ -200,3 +234,6 @@ runAPIM config (APIM m) = runReaderT m RequestState
     , statePermissions = fromList []
     , stateConfig = config
     }
+
+fromMaybeFail status err Nothing = raiseStatus status err
+fromMaybeFail _ _ (Just x) = pure x

backend/src/Datarekisteri/Backend/API.hs

@@ -8,9 +8,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 {-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
 
@@ -18,24 +18,23 @@
 
 module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
 
-import Relude hiding (Undefined, void, when, get)
+import Relude hiding (Undefined, get)
 
 import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
-import Control.Monad.Except (MonadError, throwError)
+import 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.Types (defaultRootResolver, RootResolver(..), Undefined)
 import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
-import Database.Persist (Entity, entityVal, entityKey, get, (=.))
+
-import Datarekisteri.Core.Types
+import qualified Data.Text as T
+
+import Datarekisteri.Backend.Email
 import Datarekisteri.Backend.DB
-import Datarekisteri.Backend.DB.Queries
-import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
 import Datarekisteri.Backend.Types
 import Datarekisteri.Backend.Utils
-import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
+import Datarekisteri.Core.Types
-import qualified Data.Text as T (null, chunksOf, intercalate)
 
 -- General functions, maybe migrate to Utils or API.Utils
 
@@ -45,210 +44,133 @@ targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) p
 fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
 fromMaybeFail txt = maybe (throwError txt) pure
 
-void :: Monad m => m a -> m Unit
+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
     permissions <- defaultPermissions
     when (T.null name) $ throwError "Name must not be empty"
     when (T.null password) $ throwError "Password must not be empty"
     when (T.null homeplace) $ throwError "Homeplace must not be empty"
-    let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
+    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 = 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
-          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) =>
-    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) =>
-    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 user = void $ do
+acceptApplication user = voidU $ do
-    maybeEmail <- getUserEmail user
+    maybeEmail <- dbGetUserEmail user >>= liftDBEither
     case maybeEmail of
       Nothing -> throwError $ "No valid application for " <> show user <> "!"
       Just email -> do
           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 user = void $ do
+rejectApplication user = voidU $ do
-    maybeEmail <- getUserEmail user
+    maybeEmail <- dbGetUserEmail user >>= liftDBEither
     case maybeEmail of
       Nothing -> throwError $ "No valid application for " <> show user <> "!"
       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 = Query
-    { users = requirePermission Members ReadOnly >> map (dbUserToUser) <$> getAllUsers
+    { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers
     , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
-        fmap dbUserToUser <$> getByID user
+        (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
     }
 
 resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
     MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
 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 ->
-        requirePermission (Profile user) ReadWrite >> makeNewToken args user >>=
+        requirePermission (Profile user) ReadWrite >> makeNewToken args user
-            getByID >>= fmap dbTokenToToken . fromMaybeFail ""
     , 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
     , reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id
     }
@@ -262,6 +184,34 @@ resolver :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
     MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
 resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation }
 
+data ApplicationArgs = ApplicationArgs
+    { email :: Email
+    , phoneNumber :: PhoneNumber
+    , password :: Text
+    , name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    } deriving (Generic, GQLType, Eq, Show)
+
+data UpdateArgs = UpdateArgs
+    { email :: Maybe Email
+    , phoneNumber :: Maybe PhoneNumber
+    , password :: Maybe Text
+    , name :: Maybe Text
+    , nickname :: Maybe Text
+    , homeplace :: Maybe Text
+    , application :: Maybe Text
+    } deriving (Generic, GQLType, Eq, Show)
+
+data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
+    deriving (Generic, GQLType, Eq, Show)
+
+data NewTokenArgs = NewTokenArgs
+    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
+    deriving (Generic, GQLType)
+
 data User m = User
     { id :: m UserID
     , email :: m (Maybe Email)
@@ -276,11 +226,13 @@ data User m = User
     , permissions :: m Text
     , isMember :: m Bool
     , application :: m Text
+    , tokens :: m [Token m]
+    , keys :: m [PGPKey m]
+    , primaryKey :: m (Maybe (PGPKey m))
     } deriving (Generic, GQLType)
 
 data PGPKey m = PGPKey
     { id :: m KeyID
-    , user :: m (User m)
     , pgpKeyData :: m Base64
     , expires :: m (Maybe Time)
     , uploaded :: m Time
@@ -289,7 +241,6 @@ data PGPKey m = PGPKey
 
 data Token m = Token
     { id :: m TokenID
-    , user :: m (User m)
     , name :: m (Maybe Text)
     , tokenData :: m Text
     , comment :: m Text
@@ -298,57 +249,60 @@ data Token m = Token
     , permissions :: m Text
     } deriving (Generic, GQLType)
 
-data ApplicationData = ApplicationData
-    { email :: Email
-    , phoneNumber :: PhoneNumber
-    , password :: Text
-    , name :: Text
-    , nickname :: Maybe Text
-    , birthdate :: Date
-    , homeplace :: Text
-    , application :: Text
-    } deriving (Generic, GQLType, Eq, Show)
-
-data UpdateData = UpdateData
-    { email :: Maybe Email
-    , phoneNumber :: Maybe PhoneNumber
-    , password :: Maybe Text
-    , name :: Maybe Text
-    , nickname :: Maybe Text
-    , homeplace :: Maybe Text
-    } deriving (Generic, GQLType, Eq, Show)
-
-data KeyData = KeyData { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
-    deriving (Generic, GQLType, Eq, Show)
-
-newtype Cursor = Cursor Text
-    deriving (Generic, GQLType, Eq, Show)
-
-data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
-    deriving (Generic, GQLType)
-
-data NewTokenArgs = NewTokenArgs
-    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
-    deriving (Generic, GQLType)
-
 data Query m = Query
     { users :: m [User m]
     , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
     , applications :: m [User m]
-    , tokens :: Arg "user" (Maybe UserID) -> m [Token m]
-    , keys :: Arg "user" (Maybe UserID) -> m [PGPKey m]
     , permissions :: m Text
-    --, key :: Arg "id" KeyID -> m (PGPKey m)
-    , primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
     } deriving (Generic, GQLType)
 
 data Mutation m = Mutation
-    { apply :: ApplicationData -> m (User m)
+    { apply :: ApplicationArgs -> m (User m)
     , verifyEmail :: Arg "secret" Text -> m Unit
     , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
-    , update :: UpdateData -> Arg "user" (Maybe UserID) -> m (User m)
+    , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
     , newToken :: NewTokenArgs -> m (Token m)
-    , newKey :: KeyData -> m (PGPKey m)
+    , newKey :: NewKeyArgs -> m (PGPKey m)
     , accept :: Arg "user" UserID -> m Unit
     , reject :: Arg "user" UserID -> m Unit
     } deriving (Generic, GQLType)
+
+dbUserToUser :: (MonadPermissions m, MonadError GQLError m) => DBUser m -> User m
+dbUserToUser DBUser {..} = User
+    { id = dbUserId
+    , email = dbUserEmail
+    , pendingEmail = dbUserPendingEmail
+    , name = dbUserName
+    , nickname = dbUserNickname
+    , phoneNumber = dbUserPhoneNumber
+    , birthdate = dbUserBirthdate
+    , homeplace = dbUserHomeplace
+    , registered = dbUserRegistered
+    , accepted = dbUserAccepted
+    , permissions = dbUserPermissions
+    , isMember = isJust <$> dbUserAccepted
+    , application = dbUserApplication
+    , tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
+    , keys = map dbPGPKeyToPGPKey <$> dbUserKeys
+    , primaryKey = fmap dbPGPKeyToPGPKey <$> dbUserPrimaryKey
+    }
+
+dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
+dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
+    { id = dbPGPKeyId
+    , pgpKeyData = dbPGPKeyData
+    , expires = dbPGPKeyExpires
+    , uploaded = dbPGPKeyUploaded
+    , comment = dbPGPKeyComment
+    }
+
+dbTokenToToken :: Monad m => DBToken m -> Token m
+dbTokenToToken DBToken {..} = Token
+    { id = dbTokenId
+    , name = dbTokenName
+    , tokenData = dbTokenData
+    , comment = dbTokenComment
+    , issued = dbTokenIssued
+    , expires = dbTokenExpires
+    , permissions = dbTokenPermissions
+    }

backend/src/Datarekisteri/Backend/DB.hs

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

backend/src/Datarekisteri/Backend/DB/Queries.hs

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

backend/src/Datarekisteri/Backend/Email.hs

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

backend/src/Datarekisteri/Backend/Sql.hs

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

backend/src/Datarekisteri/Backend/Sql/Queries.hs

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

backend/src/Datarekisteri/Backend/Sql/Types.hs

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

backend/src/Datarekisteri/Backend/Types.hs

@@ -1,11 +1,16 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -13,18 +18,19 @@ module Datarekisteri.Backend.Types where
 
 import Relude
 
+import "cryptonite" Crypto.Random (MonadRandom(..))
+
 import Control.Monad.Except (throwError)
-import Control.Monad.Logger (LoggingT)
-import Datarekisteri.Core.Types
 import Data.Aeson (ToJSON(..), FromJSON(..))
 import Data.ByteArray (ByteArray, ByteArrayAccess)
 import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation)
-import Data.Morpheus.Types (MonadError, GQLError)
+import Data.Morpheus.Types (MonadError, GQLError, GQLType)
 import Data.Time (getCurrentTime)
 import Database.Persist.Class (PersistField(..))
-import Database.Persist.Sql (PersistFieldSql(..), SqlBackend)
+import Database.Persist.Sql (PersistFieldSql(..))
 import Network.Mail.Mime (Mail, Address(..))
-import "cryptonite" Crypto.Random (MonadRandom(..))
+
+import Datarekisteri.Core.Types
 
 forward :: Monad m => [a] -> m [Maybe a]
 forward = pure . map Just
@@ -46,9 +52,102 @@ data MemberData = MemberData
 instance FromJSON MemberData
 instance ToJSON MemberData
 
+data ApplicationData = ApplicationData
+    { email :: Email
+    , phoneNumber :: PhoneNumber
+    , password :: Text
+    , name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    , registered :: Time
+    , verificationSecret :: Text
+    , passwordHash :: PasswordHash
+    , permissions :: Text
+    } deriving (Generic, Eq, Show)
+
+data UpdateData = UpdateData
+    { email :: Maybe Email
+    , phoneNumber :: Maybe PhoneNumber
+    , passwordHash :: Maybe PasswordHash
+    , name :: Maybe Text
+    , nickname :: Maybe Text
+    , homeplace :: Maybe Text
+    , application :: Maybe Text
+    , user :: UserID
+    , updateTime :: Time
+    , verificationSecret :: Text
+    } deriving (Generic, Eq, Show)
+
+data NewKeyData = NewKeyData
+    { comment :: Maybe Text
+    , keyData :: ByteString
+    , expires :: Maybe Time
+    , uploaded :: Time
+    , user :: UserID
+    }
+    deriving (Generic, Eq, Show)
+
+newtype Cursor = Cursor Text
+    deriving (Generic, Eq, Show)
+    deriving anyclass GQLType
+
+data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
+    deriving (Generic, GQLType)
+
+data NewTokenData = NewTokenData
+    { comment :: Maybe Text
+    , name :: Maybe Text
+    , permissions :: Text 
+    , tokenData :: Text
+    , issued :: Time
+    , expires :: Maybe Time
+    , user :: UserID
+    }
+    deriving (Generic, Eq, Show)
+
 newtype PasswordHash = PasswordHash ByteString
-    deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray,
+    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
     currentTime :: m Time
@@ -56,11 +155,22 @@ class Monad m => MonadTime m where
 instance MonadTime IO where
     currentTime = Time <$> getCurrentTime
 
+type DBEither a = Either String a
+
 class Monad m => MonadDB m where
-    runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a
+    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
     sendEmail :: Mail -> m ()
@@ -76,7 +186,19 @@ class Monad m => MonadPermissions m where
     toPermissions :: Text -> m (Maybe Text)
 
 instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
-    runQuery = lift . runQuery
+    dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser
+    dbAddUser = fmap (fmap liftUser) . lift . dbAddUser
+    dbAcceptApplication user = lift . dbAcceptApplication user
+    dbRejectApplication = lift . dbRejectApplication
+    dbVerifyEmail = lift . dbVerifyEmail
+    dbAddToken = fmap (fmap liftToken) . lift . dbAddToken
+    dbAddKey = fmap (fmap liftKey) . lift . dbAddKey
+    dbGetUser = fmap (fmap liftUser) . lift . dbGetUser
+    dbGetUserByEmail = fmap (fmap liftUser) . lift . dbGetUserByEmail
+    dbGetUsers = fmap (map liftUser) $ lift $ dbGetUsers
+    dbGetApplications = fmap (map liftUser) $ lift $ dbGetApplications
+    dbGetEmailVerificationSecret = lift . dbGetEmailVerificationSecret
+    dbGetTokenBySecret = fmap (fmap liftToken) . lift . dbGetTokenBySecret
 
 instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where
     currentUser = lift currentUser
@@ -96,3 +218,44 @@ instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
 
 instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
     currentTime = lift currentTime
+
+liftUser :: (MonadTrans t, Monad m, Monad (t m)) => DBUser m -> DBUser (t m)
+liftUser DBUser {..} = DBUser
+    { dbUserId = lift dbUserId
+    , dbUserEmail = lift dbUserEmail
+    , dbUserPendingEmail = lift dbUserPendingEmail
+    , dbUserName = lift dbUserName
+    , dbUserNickname = lift dbUserNickname
+    , dbUserPhoneNumber = lift dbUserPhoneNumber
+    , dbUserBirthdate = lift dbUserBirthdate
+    , dbUserHomeplace = lift dbUserHomeplace
+    , dbUserRegistered = lift dbUserRegistered
+    , dbUserAccepted = lift dbUserAccepted
+    , dbUserPermissions = lift dbUserPermissions
+    , dbUserApplication = lift dbUserApplication
+    , dbUserPasswordHash = lift dbUserPasswordHash
+    , dbUserTokens = map liftToken <$> lift dbUserTokens
+    , dbUserKeys = map liftKey <$> lift dbUserKeys
+    , dbUserPrimaryKey = fmap liftKey <$> lift dbUserPrimaryKey
+    }
+
+liftToken :: (MonadTrans t, Monad m, Monad (t m)) => DBToken m -> DBToken (t m)
+liftToken DBToken {..} = DBToken
+    { dbTokenId = lift dbTokenId
+    , dbTokenUser = fmap liftUser $ lift dbTokenUser
+    , dbTokenName = lift dbTokenName
+    , dbTokenData = lift dbTokenData
+    , dbTokenComment = lift dbTokenComment
+    , dbTokenIssued = lift dbTokenIssued
+    , dbTokenExpires = lift dbTokenExpires
+    , dbTokenPermissions = lift dbTokenPermissions
+    }
+
+liftKey :: (MonadTrans t, Monad m, Monad (t m)) => DBPGPKey m -> DBPGPKey (t m)
+liftKey DBPGPKey {..} = DBPGPKey
+    { dbPGPKeyId = lift dbPGPKeyId
+    , dbPGPKeyData = lift dbPGPKeyData
+    , dbPGPKeyExpires = lift dbPGPKeyExpires
+    , dbPGPKeyUploaded = lift dbPGPKeyUploaded
+    , dbPGPKeyComment = lift dbPGPKeyComment
+    }

backend/src/Datarekisteri/Backend/Utils.hs

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

backend/src/Datarekisteri/CLI.hs

@@ -12,13 +12,18 @@ import "cryptonite" Crypto.Random (MonadRandom(..))
 import Control.Monad.Logger (runStderrLoggingT)
 import Data.Aeson (toJSON)
 import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
-import Datarekisteri.Backend.DB
+import 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.Utils
 import Datarekisteri.Core.Types
-import Options.Applicative
-import System.IO.Echo (withoutInputEcho)
 
 main :: IO ()
 main = do
@@ -33,12 +38,13 @@ addUserMain :: AddUserOpts -> CLIM ()
 addUserMain AddUserOpts {..} = do
     time <- currentTime
     passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword
-    userID <- addUser $ DBUser
+    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
                 , name = addUserName
                 , birthdate = addUserBirthdate
@@ -47,22 +53,21 @@ addUserMain AddUserOpts {..} = do
                 , 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 = do
     time <- currentTime
-    deleteExpiredEmails time
+    runQuery $ do
-    deleteOrphanedVerifications
+        Sql.deleteExpiredEmails time
+        Sql.deleteOrphanedVerifications
 
 gcApplicationsMain :: CLIM ()
-gcApplicationsMain = do
+gcApplicationsMain = runQuery $ Sql.deleteUsersWithoutEmail
-    deleteUsersWithoutEmail
 
 gcAllMain :: CLIM ()
 gcAllMain = do
@@ -124,7 +129,7 @@ newtype CLIM a = CLIM (ReaderT String IO a)
 instance MonadTime CLIM where
     currentTime = liftIO currentTime
 
-instance MonadDB CLIM where
+instance MonadSql CLIM where
     runQuery query = do
         dbUrl <- ask
         liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query

backend/src/Main.hs

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

core/src/Datarekisteri/Core/Types.hs

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

frontend/schema.gql

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

frontend/src/Datarekisteri/Frontend.hs

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

frontend/src/Datarekisteri/Frontend/ApiRequests.hs

@@ -13,9 +13,10 @@ module Datarekisteri.Frontend.ApiRequests where
 
 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)
 -- From Data.Morpheus.Client.Fetch.RequestType

frontend/src/Datarekisteri/Frontend/Auth.hs

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

frontend/src/Datarekisteri/Frontend/FormFields.hs

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

frontend/src/Datarekisteri/Frontend/Handlers.hs

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

frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs

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

frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs

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

frontend/src/Datarekisteri/Frontend/Handlers/Members.hs

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

frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs

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

frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs

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

frontend/src/Datarekisteri/Frontend/Types.hs

@@ -16,20 +16,22 @@
 module Datarekisteri.Frontend.Types where
 
 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.Format.ISO8601 (iso8601Show)
-import Datarekisteri.Frontend.Auth
+import Relude.Extra.Foldable1 (maximum1)
+import Yesod.Core.Handler (getCurrentRoute)
+import Yesod.Default.Util (addStaticContentExternal)
+
+import Yesod
+import Yesod.Auth
+import Yesod.Static
+
+import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
 import Datarekisteri.Frontend.ApiRequests
-import Data.Morpheus.Client
+import Datarekisteri.Frontend.Auth
-import Data.Map (findWithDefault)
 
 data DataIdClient = DataIdClient
     { getStatic :: Static