.gitignore

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

.guix/modules/datarekisteri-package.scm

@@ -30,7 +30,6 @@
                   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 Datarekisteri.Backend.API (coreApp)
+import Server.API (coreApp)
 import qualified Data.ByteString.Lazy.Char8 as C8
-import Datarekisteri.Backend (APIM)
+import Server (APIM)
 
 main = C8.putStrLn $ render (coreApp :: App () APIM)

backend/datarekisteri-backend.cabal

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

backend/src/Datarekisteri/Backend.hs

@@ -5,42 +5,31 @@
 
 {-# 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 Network.HTTP.Types.Status (status500, status401)
+import Datarekisteri.Core.Types
 import Network.Mail.Mime (renderSendMailCustom, Address(..))
 import Network.Wai (Application)
 import Network.Wai.Handler.Warp (Port, run)
-import Network.Wai.Middleware.Cors (CorsResourcePolicy(..), cors)
+import Network.Wai.Middleware.Cors
-import Network.Wai.Middleware.Gzip (gzip)
+import Network.Wai.Middleware.Gzip
+import Datarekisteri.Backend.API
+import Datarekisteri.Backend.DB
+import Datarekisteri.Backend.DB.Queries (getUserByEmail, getPermissions, getToken)
+import Datarekisteri.Backend.Types
+import Datarekisteri.Backend.Utils (checkPassword)
 import 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 ()
@@ -112,15 +101,10 @@ parseBearer auth = do
 authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
 authBearer Nothing m = m
 authBearer (Just (BearerToken bearer)) m = do
-    let getUserPermissions = do
+    token <- lift $ getToken bearer
-            Right DBToken {..} <- lift $ dbGetTokenBySecret bearer
+    let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal
-            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 = user
+        { stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token
         , statePermissions = permissions
         }
 
@@ -139,23 +123,21 @@ parseBasic txt = do
 authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
 authBasic Nothing m = m
 authBasic (Just basic) m = do
-    DBUser {..} <- verifyBasic basic
+    user <- verifyBasic basic
-    permissions <- readPermission <$> lift dbUserPermissions >>=
+    permissions <- maybe (pure mempty)
-        fromMaybeFail status500 "Internal server error"
+        (fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user
-    userID <- lift dbUserId
     flip local m $ \state -> state
-        { stateCurrentUser = Just userID
+        { stateCurrentUser = user
         , statePermissions = permissions
         }
 
-verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
+-- TODO Refact, no need to convert to id and rerequest permissions
+verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
 verifyBasic BasicAuth {..} = do
-    Right user@DBUser {..} <- lift $ dbGetUserByEmail emailAddress
+    user <- lift $ getUserByEmail emailAddress
-    correctPassword <- checkPassword password <$> lift dbUserPasswordHash
+    if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user
-    if correctPassword
+       then pure $ entityToID <$> user
-       then pure user
+       else pure Nothing
-       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)
@@ -176,26 +158,10 @@ data Config = Config
 instance MonadTime APIM where
     currentTime = liftIO currentTime
 
-instance MonadSql APIM where
-    runQuery query = do
-        dbUrl <- fmap encodeUtf8 $ asks $ configDbUrl . stateConfig
-        liftIO $ runStderrLoggingT $ withPostgresqlConn dbUrl $ runSqlConn query
-
--- TODO: Catch database exceptions into Left values
 instance MonadDB APIM where
-    dbUpdateUser = Sql.dbUpdateUser
+    runQuery query = do
-    dbAddUser = Sql.dbAddUser
+        dbUrl <- asks $ configDbUrl . stateConfig
-    dbAcceptApplication = Sql.dbAcceptApplication
+        liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query
-    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
@@ -234,6 +200,3 @@ 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,23 +18,24 @@
 
 module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
 
-import Relude hiding (Undefined, get)
+import Relude hiding (Undefined, void, when, get)
 
 import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
-import qualified "base64" Data.ByteString.Base64 as B64
+import Control.Monad.Except (MonadError, throwError)
-
+import Data.Aeson (fromJSON, Result(..), toJSON)
-import Control.Monad.Except (MonadError, throwError, catchError)
+import Data.Maybe (fromJust)
 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 qualified Data.Text as T
+import Datarekisteri.Core.Types
-
-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 Datarekisteri.Core.Types
+import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
+import qualified Data.Text as T (null, chunksOf, intercalate)
 
 -- General functions, maybe migrate to Utils or API.Utils
 
@@ -42,135 +43,212 @@ targetUser :: (MonadError GQLError m, MonadRequest m) => Maybe UserID -> m UserI
 targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure
 
 fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
-fromMaybeFail txt = maybe (throwError txt) pure
+fromMaybeFail txt = maybe (throwError txt) pure 
 
-voidU :: Monad m => m a -> m Unit
+void :: Monad m => m a -> m Unit
-voidU m = m >> pure Unit
+void m = m >> pure Unit
 
-liftDBEither :: MonadError GQLError m => DBEither a -> m a
+when :: Monad m => Bool -> m a -> m Unit
-liftDBEither = either (throwError . fromString) pure
+when b m = if b then void m else pure Unit
 
-applicationArgsToData :: (MonadTime m, MonadRandom m, MonadPermissions m, MonadError GQLError m) =>
+dbUserToUser :: MonadDB m => Entity DBUser -> User m
-    ApplicationArgs -> m ApplicationData
+dbUserToUser user = let id = entityToID user
-applicationArgsToData ApplicationArgs {..} = do
+                        DBUser {..} = entityVal user
-    registered <- currentTime
+                        Success (MemberData {..}) = fromJSON dBUserMemberData
-    verificationSecret <- genVerificationSecret
+                        -- XXX: Explodes if database doesn't contain needed data
+                    in User
+                        { id = pure id
+                        , email = fmap (dBEmailEmail . entityVal) <$> getUserEmail id
+                        , pendingEmail = fmap (dBEmailEmail . entityVal) <$> getUserPendingEmail id
+                        , phoneNumber = pure phoneNumber
+                        , name = pure name
+                        , nickname = pure $ fromMaybe (error "db contains empty name") $
+                            maybe (viaNonEmpty head $ words $ name) Just nickname
+                        , birthdate = pure birthdate
+                        , homeplace = pure homeplace
+                        , registered = pure dBUserRegistered
+                        , accepted = pure dBUserAccepted
+                        , isMember = pure $ isJust dBUserAccepted
+                        , permissions = pure dBUserPermissions
+                        , application = pure application
+                        }
+
+dbKeyToPGPKey :: (MonadDB m, MonadError GQLError m) => Entity DBKey -> PGPKey m
+dbKeyToPGPKey key = let id = entityToID key
+                        DBKey {..} = entityVal key
+                    in PGPKey
+                        { id = pure id
+                        , user = getByID (fromDBKey dBKeyUid :: UserID)
+                              >>= fmap dbUserToUser . fromMaybeFail ""
+                        , pgpKeyData = pure $ base64Encode dBKeyData
+                        , expires = pure dBKeyExpires
+                        , uploaded = pure dBKeyUploaded
+                        , comment = pure dBKeyComment
+                        }
+
+dbTokenToToken :: (MonadDB m, MonadError GQLError m) => Entity DBToken -> Token m
+dbTokenToToken token = let id = entityToID token
+                           DBToken {..} = entityVal token
+                       in Token
+                           { id = pure id
+                           , user = getByID (fromDBKey dBTokenUid :: UserID)
+                                 >>= fmap dbUserToUser . fromMaybeFail ""
+                           , name = pure dBTokenName
+                           , tokenData = pure dBTokenData
+                           , comment = pure dBTokenComment
+                           , issued = pure dBTokenIssued
+                           , expires = pure dBTokenExpires
+                           , permissions = pure dBTokenPermissions
+                           }
+
+newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
+    ApplicationData -> m UserID
+newUser (ApplicationData {..}) = do
+    time <- currentTime
+    secret <- genVerificationSecret
     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"
-    pure ApplicationData {..}
+    let memberData = MemberData { nickname = nickname >>= \x -> if T.null x then Nothing else Just x, ..}
-
+    user <- addUser $ DBUser
-newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
+        { dBUserRegistered = time
-    ApplicationArgs -> m (User m)
+        , dBUserPasswordCrypt = passwordHash
-newUser args = do
+        , dBUserPermissions = permissions
-    applicationData <- applicationArgsToData args
+        , dBUserAccepted = Nothing
-    user <- dbAddUser applicationData >>= liftDBEither
+        , dBUserMemberData = toJSON memberData
-    sendVerificationSecret user >>= flip unless (throwError "Sending email verification failed!")
+        }
-    return $ dbUserToUser user
+    verification <- addEmailVerification secret
+    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) => DBUser m -> m Bool
+sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => Key DBEmail -> m Unit
-sendVerificationSecret DBUser {..} = do
+sendVerificationSecret email = void $ do
-    secret <- dbUserId >>= dbGetEmailVerificationSecret >>= liftDBEither
+    maybeDBEmail <- runQuery $ get email
-    pendingEmail <- dbUserPendingEmail
+    case maybeDBEmail of
-    case (secret, pendingEmail) of
+      Nothing -> pure Unit
-      (Just secret', Just pendingEmail') ->
+      Just dbEmail -> do
-          sendVerificationEmail secret' pendingEmail' >> pure True
+          case dBEmailVid dbEmail of
-      _ -> pure False
+            Nothing -> pure Unit
+            Just dbVerificationId -> do
+                secret <- fmap (dBEmailVerificationSecret . fromJust) $ runQuery $ get dbVerificationId
+                let email = dBEmailEmail dbEmail
+                void $ sendVerificationEmail secret email
 
-updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
+updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
-    UpdateArgs -> UserID -> m UpdateData
+    UserID -> UpdateData -> m UserID
-updateArgsToData UpdateArgs {..} user = do
+updateUser user (UpdateData {..}) = do
-    when (maybe False T.null name) $ throwError "Name must not be empty"
+    hash <- sequence $ hashPassword <$> password
-    when (maybe False T.null password) $ throwError "Password must not be empty"
+    -- TODO: assert stuff valid
-    when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
+    user <- updateUserData user
-    isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
+        (catMaybes [(DBUserPasswordCrypt =.) <$> hash])
-    when (isMember && isJust application) $ throwError "Members can't update their applications"
+        (catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
-    passwordHash <- sequence $ hashPassword <$> password
+            SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
-    updateTime <- currentTime
+    case email of
-    verificationSecret <- genVerificationSecret
+      Nothing -> pure Unit
-    pure UpdateData {..}
+      Just email' -> do
-
+          verificationSecret <- genVerificationSecret
-updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
+          emailKey <- updateEmail user email' verificationSecret
-    MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
+          sendVerificationSecret emailKey
-updateUser user args = do
+    return user
-    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 (Token m)
+    NewTokenArgs -> UserID -> m TokenID
-makeNewToken args user = do
+makeNewToken (NewTokenArgs {..}) user = do
-    tokenData <- newTokenArgsToData args user
+    tokenData <- B64.encodeBase64 <$> getRandomBytes 128
-    fmap dbTokenToToken $ dbAddToken tokenData >>= liftDBEither
+    time <- currentTime
-
+    permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
-newKeyArgsToData :: (MonadTime m, MonadError GQLError m) => NewKeyArgs -> UserID -> m NewKeyData
+    addToken $ DBToken
-newKeyArgsToData NewKeyArgs {..} user = do
+        { dBTokenUid = toDBKey user
-    uploaded <- currentTime
+        , dBTokenName = name
-    keyData <- maybe (throwError "Invalid base64") pure $ base64Decode keyData
+        , dBTokenData = tokenData
-    pure NewKeyData {..}
+        , dBTokenComment = fromMaybe "" comment
+        , dBTokenIssued = time
+        , dBTokenExpires = Nothing
+        , dBTokenPermissions = permissions
+        }
 
 makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
-    NewKeyArgs -> UserID -> m (PGPKey m)
+    KeyData -> UserID -> m KeyID
-makeNewKey args user = do
+makeNewKey (KeyData {..}) user = do
-    newKeyData <- newKeyArgsToData args user
+    time <- currentTime
-    fmap dbPGPKeyToPGPKey $ dbAddKey newKeyData >>= liftDBEither
+    keyData' <- fromMaybeFail "" $ base64Decode keyData
+    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 = voidU $ do
+acceptApplication user = void $ do
-    maybeEmail <- dbGetUserEmail user >>= liftDBEither
+    maybeEmail <- getUserEmail user
     case maybeEmail of
       Nothing -> throwError $ "No valid application for " <> show user <> "!"
       Just email -> do
           time <- currentTime
-          dbAcceptApplication user time >>= liftDBEither
+          applicationAccepted <- markAsAccepted user time
-          sendApplicationAcceptedEmail email
+          when applicationAccepted $
+              sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
 
 rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
-rejectApplication user = voidU $ do
+rejectApplication user = void $ do
-    maybeEmail <- dbGetUserEmail user >>= liftDBEither
+    maybeEmail <- getUserEmail user
     case maybeEmail of
       Nothing -> throwError $ "No valid application for " <> show user <> "!"
       Just email -> do
-          dbRejectApplication user
+          applicationDeleted <- deleteApplication user
-          sendApplicationRejectedEmail email
+          when applicationDeleted $
+              sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
 
 resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
 resolveQuery = Query
-    { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers
+    { users = requirePermission Members ReadOnly >> map (dbUserToUser) <$> getAllUsers
     , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
-        (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
+        fmap dbUserToUser <$> getByID user
-    , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
+    , tokens = \(Arg id) -> targetUser id >>= \user ->
+        requirePermission (Tokens user) ReadOnly >> map dbTokenToToken <$> getUserTokens user
+    , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> applicants
+    , keys = \(Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadOnly >> map dbKeyToPGPKey <$> getKeys user
+    --, key = \(Arg id) -> resolve (pure id)
+    -- TODO is this actually useful
+    , primaryKey = \(Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadOnly >> getPrimaryKey user >>= pure . fmap dbKeyToPGPKey
     , permissions = currentPermissions
     }
 
 resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
     MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
 resolveMutation = Mutation
-    { apply = newUser
+    { apply = \x -> do
-    , verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret
+        userID <- newUser x
-    , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
+        maybeUser <- getByID userID
-        maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
+        user <- fromMaybeFail "" maybeUser
-    , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
+        pure $ dbUserToUser user
-        requirePermission (Profile user) ReadWrite >> updateUser user updateArgs
+    , verifyEmail = \(Arg secret) -> void $ verifyEmailSecret secret >>= \x -> when (not x) $ throwError "Invalid verification secret"
+    , resendVerificationEmail = \(Arg id) -> targetUser id >>= getUserPendingEmail >>=
+        maybe (pure Unit) (sendVerificationSecret . entityKey)
+    , update = \updateData (Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadWrite >>
+            updateUser user updateData >> getByID user >>= fmap dbUserToUser . fromMaybeFail ""
     , 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
     }
@@ -184,34 +262,6 @@ 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)
@@ -226,13 +276,11 @@ 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
@@ -241,6 +289,7 @@ 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
@@ -249,60 +298,57 @@ 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 :: ApplicationArgs -> m (User m)
+    { apply :: ApplicationData -> m (User m)
     , verifyEmail :: Arg "secret" Text -> m Unit
     , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
-    , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
+    , update :: UpdateData -> Arg "user" (Maybe UserID) -> m (User m)
     , newToken :: NewTokenArgs -> m (Token m)
-    , newKey :: NewKeyArgs -> m (PGPKey m)
+    , newKey :: KeyData -> 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,24 +1,105 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DataKinds #-}
-
+{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Datarekisteri.Backend.DB where
 
-import Relude
+import Data.ByteString (ByteString)
-
+import Data.Text (Text)
-import Datarekisteri.Backend.Types
+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
 
-dbGetUserEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
+mkPersist sqlSettings [persistUpperCase|
-dbGetUserEmail userID = do
+DBUser sql=users
-    userOrErr <- dbGetUser userID
+  registered Time
-    case userOrErr of
+  passwordCrypt PasswordHash
-      Left err -> pure $ Left err
+  permissions Text
-      Right DBUser {..} -> Right <$> dbUserEmail
+  accepted (Maybe Time)
+  memberData Value sqltype=jsonb
 
-dbGetUserPendingEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
+  deriving (Show)
-dbGetUserPendingEmail userID = do
+
-    userOrErr <- dbGetUser userID
+DBEmail sql=emails
-    case userOrErr of
+  uid DBUserId
-      Left err -> pure $ Left err
+  email Email sqltype=varchar(320)
-      Right DBUser {..} -> Right <$> dbUserPendingEmail
+  vid (Maybe DBEmailVerificationId) sql=verification
+
+  UniqueUserVerified uid vid
+  -- This enables using persistent functions to get unique verified emails. The real
+  -- constraint is stricter and doesn't allow having more than one null and one non-null
+  -- verification but it's too complicated for persistent to understand.
+
+  UniqueEmail email
+  UniqueVerification vid
+
+DBEmailVerification sql=emailVerifications
+  secret Text sqltype=varchar(255)
+  expires Time
+
+  UniqueVerificationSecret secret
+
+DBKey sql=keys
+  uid DBUserId
+  data ByteString
+  expires (Maybe Time)
+  uploaded Time
+  comment Text
+  isPrimaryEncryptionKey Bool
+
+DBToken sql=tokens
+  uid DBUserId
+  name (Maybe Text)
+  data Text
+  comment Text
+  issued Time
+  expires (Maybe Time)
+  permissions Text
+
+  UniqueNameUid name uid
+  UniqueData data
+|]
+
+entityToID :: FromDBKey a => Entity (DB a) -> a
+entityToID = fromDBKey . entityKey
+
+class PersistEntity (DB a) =>  FromDBKey a where
+    type DB a
+    fromDBKey :: Key (DB a) -> a
+
+instance FromDBKey UserID where
+    type DB UserID = DBUser
+    fromDBKey = UserID . fromIntegral . fromSqlKey
+
+instance FromDBKey TokenID where
+    type DB TokenID = DBToken
+    fromDBKey = TokenID . fromIntegral . fromSqlKey
+
+instance FromDBKey KeyID where
+    type DB KeyID = DBKey
+    fromDBKey = KeyID . fromIntegral . fromSqlKey
+
+class FromDBKey a => ToDBKey a where
+    toDBKey :: a -> Key (DB a)
+
+instance ToDBKey UserID where
+    toDBKey (UserID x) = toSqlKey $ fromIntegral x
+
+instance ToDBKey KeyID where
+    toDBKey (KeyID x) = toSqlKey $ fromIntegral x
+
+instance ToDBKey TokenID where
+    toDBKey (TokenID x) = toSqlKey $ fromIntegral x

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

@@ -0,0 +1,204 @@
+{-# 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,12 +2,11 @@
 
 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

@@ -1,212 +0,0 @@
-{-# 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

@@ -1,239 +0,0 @@
-{-# 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

@@ -1,98 +0,0 @@
-{-# 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,16 +1,11 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PackageImports #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -18,19 +13,18 @@ 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, GQLType)
+import Data.Morpheus.Types (MonadError, GQLError)
 import Data.Time (getCurrentTime)
 import Database.Persist.Class (PersistField(..))
-import Database.Persist.Sql (PersistFieldSql(..))
+import Database.Persist.Sql (PersistFieldSql(..), SqlBackend)
 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
@@ -52,102 +46,9 @@ 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 newtype (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess,
+    deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray,
-        ByteArray, PersistField, PersistFieldSql)
+        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
@@ -155,22 +56,11 @@ 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
-    dbUpdateUser :: UpdateData -> m (DBEither (DBUser m))
+    runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a
-    dbAddUser :: ApplicationData -> m (DBEither (DBUser m))
+    -- TODO refactor so that it is possible to define a IO-less db, for safety and testability.
-    dbAcceptApplication :: UserID -> Time -> m (DBEither ())
+    --      Is there a way to do this that doesn't require moving all db calls to the class?
-    dbRejectApplication :: UserID -> m (DBEither ())
+    --      Probably not :(
-    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 ()
@@ -186,19 +76,7 @@ class Monad m => MonadPermissions m where
     toPermissions :: Text -> m (Maybe Text)
 
 instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
-    dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser
+    runQuery = lift . runQuery
-    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
@@ -218,44 +96,3 @@ 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,15 +2,12 @@
 
 module Datarekisteri.Backend.Utils where
 
-import "cryptonite" Crypto.Random (MonadRandom)
-
 import Data.ByteArray.Encoding (convertToBase, Base(..))
 import Data.ByteString (ByteString)
-import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-
+import Data.Text (Text)
 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,18 +12,13 @@ import "cryptonite" Crypto.Random (MonadRandom(..))
 import Control.Monad.Logger (runStderrLoggingT)
 import Data.Aeson (toJSON)
 import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
-import System.IO.Echo (withoutInputEcho)
+import Datarekisteri.Backend.DB
-
+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
@@ -38,36 +33,36 @@ addUserMain :: AddUserOpts -> CLIM ()
 addUserMain AddUserOpts {..} = do
     time <- currentTime
     passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword
-    runQuery $ do
+    userID <- addUser $ DBUser
-        userID <- Sql.addUser $ SqlUser
+        { dBUserRegistered = time
-            { sqlUserRegistered = time
+        , dBUserPasswordCrypt = passwordHash
-            , sqlUserPasswordCrypt = passwordHash
+        , dBUserPermissions = show addUserPermissions
-            , sqlUserPermissions = show addUserPermissions
+        , dBUserAccepted = Just time
-            , sqlUserAccepted = Just time
+        , dBUserMemberData = toJSON $ MemberData
-            , sqlUserMemberData = toJSON $ MemberData
+            { nickname = addUserNickname
-                { nickname = addUserNickname
+            , name = addUserName
-                , name = addUserName
+            , birthdate = addUserBirthdate
-                , birthdate = addUserBirthdate
+            , homeplace = addUserHomeplace
-                , homeplace = addUserHomeplace
+            , application = addUserApplication
-                , application = addUserApplication
+            , phoneNumber = addUserPhoneNumber
-                , phoneNumber = addUserPhoneNumber
-                }
-            }
-        void $ Sql.addEmail $ SqlEmail
-            { sqlEmailUid = fromID userID
-            , sqlEmailEmail = addUserEmail
-            , sqlEmailVid = Nothing
             }
+        }
+    _ <- addEmail $ DBEmail
+        { dBEmailUid = toDBKey userID
+        , dBEmailEmail = addUserEmail
+        , dBEmailVid = Nothing
+        }
+    pure ()
 
 gcEmailsMain :: CLIM ()
 gcEmailsMain = do
     time <- currentTime
-    runQuery $ do
+    deleteExpiredEmails time
-        Sql.deleteExpiredEmails time
+    deleteOrphanedVerifications
-        Sql.deleteOrphanedVerifications
 
 gcApplicationsMain :: CLIM ()
-gcApplicationsMain = runQuery $ Sql.deleteUsersWithoutEmail
+gcApplicationsMain = do
+    deleteUsersWithoutEmail
 
 gcAllMain :: CLIM ()
 gcAllMain = do
@@ -129,7 +124,7 @@ newtype CLIM a = CLIM (ReaderT String IO a)
 instance MonadTime CLIM where
     currentTime = liftIO currentTime
 
-instance MonadSql CLIM where
+instance MonadDB CLIM where
     runQuery query = do
         dbUrl <- ask
         liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query

backend/src/Main.hs

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

core/src/Datarekisteri/Core/Types.hs

@@ -1,17 +1,14 @@
 {-# 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)
@@ -24,6 +21,7 @@ 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,6 +21,7 @@ enum Unit {
 
 type PGPKey {
   id: KeyID!
+  user: User!
   pgpKeyData: Base64!
   expires: Time
   uploaded: Time!
@@ -29,6 +30,7 @@ type PGPKey {
 
 type Token {
   id: TokenID!
+  user: User!
   name: String
   tokenData: String!
   comment: String!
@@ -51,23 +53,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, application: String, user: UserID): User!
+  update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: 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,27 +1,26 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# 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 System.Directory (createDirectoryIfMissing)
+import Yesod
-import Yesod.Static (static, Static)
+import Yesod.Auth
-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,10 +13,9 @@ module Datarekisteri.Frontend.ApiRequests where
 
 import Relude
 
-import Data.Aeson (ToJSON, FromJSON)
+import Data.Morpheus.Client
-import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders)
+import Yesod hiding (Header)
-import Yesod (HandlerFor, getYesod, liftHandler)
+import Yesod.Auth
-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 DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -14,11 +14,11 @@ module Datarekisteri.Frontend.Auth where
 
 import Relude
 
-import qualified "base64" Data.ByteString.Base64 as B64
+import Datarekisteri.Core.Types
-
+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 OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -8,16 +8,14 @@ module Datarekisteri.Frontend.FormFields where
 import Relude
 
 import Yesod
-
-import Datarekisteri.Core.Types
 import Datarekisteri.Frontend.Types
+import Datarekisteri.Core.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 ->
@@ -43,9 +41,6 @@ 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,33 +1,31 @@
-{-# LANGUAGE DisambiguateRecordFields #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Datarekisteri.Frontend.Handlers
     ( module Datarekisteri.Frontend.Handlers.Profile
-    , module Datarekisteri.Frontend.Handlers.Applications
     , module Datarekisteri.Frontend.Handlers.Apply
-    , module Datarekisteri.Frontend.Handlers.Members
+    , module Datarekisteri.Frontend.Handlers.Applications
     , module Datarekisteri.Frontend.Handlers.VerifyEmail
+    , module Datarekisteri.Frontend.Handlers.Members
     , 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 RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -14,17 +14,15 @@ module Datarekisteri.Frontend.Handlers.Applications where
 
 import Relude hiding (id)
 
-import Data.Maybe (fromJust)
+import Datarekisteri.Frontend.ApiRequests
-import Data.Time (Day)
+import Datarekisteri.Frontend.Types
-import Data.Morpheus.Client (raw, declareLocalTypesInline)
+import Data.Morpheus.Client
-
+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 Datarekisteri.Frontend.Types
+import Data.Time (Day)
+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 RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -14,16 +14,14 @@ module Datarekisteri.Frontend.Handlers.Apply where
 
 import Relude hiding (id)
 
-import Data.Morpheus.Client (raw, declareLocalTypesInline)
+import Datarekisteri.Frontend.ApiRequests
-import Data.Time (Day)
+import Datarekisteri.Frontend.Types
-
+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 Datarekisteri.Frontend.Types
+import Data.Time (Day)
 
 declareLocalTypesInline "schema.gql" [raw|
 mutation Apply($name: String!, $nickname: String, $homeplace: String!,
@@ -48,6 +46,8 @@ 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,14 +12,12 @@ module Datarekisteri.Frontend.Handlers.Members where
 
 import Relude hiding (id)
 
-import Data.Morpheus.Client (raw, declareLocalTypesInline)
+import Data.Morpheus.Client
-
-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 RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -14,16 +14,14 @@ 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) {
@@ -37,15 +35,14 @@ 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, $application: String) {
+mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber) {
-  update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber, application: $application) {
+  update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber) {
     id
   }
 }
@@ -74,12 +71,9 @@ 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 <*> applicationRes
+            nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
         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}
@@ -97,8 +91,6 @@ 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 TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -13,14 +13,12 @@ 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,22 +16,20 @@
 module Datarekisteri.Frontend.Types where
 
 import Relude hiding (id)
-
-import Data.Map (findWithDefault)
-import Data.Morpheus.Client (raw, declareLocalTypesInline)
-import Data.Time (getCurrentTime)
-import Data.Time.Format.ISO8601 (iso8601Show)
 import Relude.Extra.Foldable1 (maximum1)
-import Yesod.Core.Handler (getCurrentRoute)
-import Yesod.Default.Util (addStaticContentExternal)
 
 import Yesod
+import Yesod.Core.Handler (getCurrentRoute)
+import Yesod.Default.Util (addStaticContentExternal)
 import Yesod.Auth
 import Yesod.Static
-
 import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
-import Datarekisteri.Frontend.ApiRequests
+import Data.Time (getCurrentTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Datarekisteri.Frontend.Auth
+import Datarekisteri.Frontend.ApiRequests
+import Data.Morpheus.Client
+import Data.Map (findWithDefault)
 
 data DataIdClient = DataIdClient
     { getStatic :: Static