Add CLI command to update user data

backend/src/Datarekisteri/Backend/API.hs

@@ -162,7 +162,7 @@ resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
     MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
 resolveMutation = Mutation
     { apply = newUser
-    , verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret
+    , verifyEmail = \(Arg secret) -> either (const False) (const True) <$> dbVerifyEmail secret
     , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
         maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
     , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
@@ -258,7 +258,7 @@ data Query m = Query
 
 data Mutation m = Mutation
     { apply :: ApplicationArgs -> m (User m)
-    , verifyEmail :: Arg "secret" Text -> m Unit
+    , verifyEmail :: Arg "secret" Text -> m Bool
     , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
     , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
     , newToken :: NewTokenArgs -> m (Token m)

backend/src/Datarekisteri/CLI.hs

@@ -33,6 +33,7 @@ main = do
       GCEmails -> gcEmailsMain
       GCApplications -> gcApplicationsMain
       GCAll -> gcAllMain
+      UpdateUser opts -> updateUserMain opts
 
 addUserMain :: AddUserOpts -> CLIM ()
 addUserMain AddUserOpts {..} = do
@@ -74,6 +75,15 @@ gcAllMain = do
     gcEmailsMain
     gcApplicationsMain
 
+updateUserMain :: UpdateUserOpts -> CLIM ()
+updateUserMain UpdateUserOpts {..} = runQuery $ do
+    case updateUserApplication of
+      Nothing -> pure ()
+      Just application -> Sql.updateUserData updateUserId [] [Sql.SetUserApplication application]
+    case updateUserPermissions of
+      Nothing -> pure ()
+      Just permissions -> Sql.setPermissions updateUserId $ show permissions
+
 cliOptions :: Parser CLIOptions
 cliOptions = CLIOptions
     <$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend")
@@ -85,6 +95,7 @@ cliCommandParser = hsubparser
     <> command "gc-expired-emails" (info (pure GCEmails) (progDesc "Delete emails that have not been verified in time."))
     <> command "gc-applications" (info (pure GCApplications) (progDesc "Delete users without an email address"))
     <> command "gc" (info (pure GCAll) (progDesc "Run all garbage collection jobs."))
+    <> command "update-user" (info updateUserCommand (progDesc "Update a datarekisteri user"))
 
 addUserCommand :: Parser CLISubCommand
 addUserCommand = fmap AddUser $ AddUserOpts
@@ -94,9 +105,18 @@ addUserCommand = fmap AddUser $ AddUserOpts
     <*> strOption (long "homeplace" <> metavar "NAME" <> help "The user's homeplace, usually a city")
     <*> option (maybeReader $ toPhoneNumber . toText) (long "phone-number" <> metavar "PHONE" <> help "The user's phone number. Only numbers, spaces and the plus-sign are allowed")
     <*> option (maybeReader $ toEmail . toText) (long "email" <> metavar "EMAIL" <> help "The user's email address.")
-    <*> (fromList <$> many permissionParser)
+    <*> permissionsParser
     <*> strOption (long "application" <> metavar "TEXT" <> value "Added by the admin.")
 
+updateUserCommand :: Parser CLISubCommand
+updateUserCommand = fmap UpdateUser $ UpdateUserOpts
+    <$> (UserID <$> argument auto (metavar "USER"))
+    <*> optional (strOption (long "application" <> metavar "TEXT"))
+    <*> optional permissionsParser
+
+permissionsParser :: Parser (Map Scope Permission)
+permissionsParser = fromList <$> many permissionParser
+
 permissionParser :: Parser (Scope, Permission)
 permissionParser = (,)
     <$> option auto (long "scope")
@@ -111,6 +131,13 @@ data CLISubCommand = AddUser AddUserOpts
                    | GCEmails
                    | GCApplications
                    | GCAll
+                   | UpdateUser UpdateUserOpts
+
+data UpdateUserOpts = UpdateUserOpts
+    { updateUserId :: UserID
+    , updateUserApplication :: Maybe Text
+    , updateUserPermissions :: Maybe (Map Scope Permission)
+    }
 
 data AddUserOpts = AddUserOpts
         { addUserNickname :: Maybe Text

core/src/Datarekisteri/Core/Types.hs

@@ -6,7 +6,31 @@
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Datarekisteri.Core.Types where
+module Datarekisteri.Core.Types
+    ( Base64
+    , Date(..)
+    , Email
+    , KeyID(..)
+    , Permission(..)
+    , PhoneNumber
+    , Scope(..)
+    , Time(..)
+    , TokenID(..)
+    , Unit(Unit)
+    , UserID(..)
+    , addTime
+    , base64Decode
+    , base64Encode
+    , readPermission
+    , renderDate
+    , renderEmail
+    , renderPhoneNumber
+    , renderTime
+    , toDate
+    , toEmail
+    , toPhoneNumber
+    , toTime
+    ) where
 
 import Relude
 

frontend/schema.gql

@@ -65,7 +65,7 @@ type Query {
 
 type Mutation {
   apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
-  verifyEmail(secret: String!): Unit!
+  verifyEmail(secret: String!): Boolean!
   resendVerificationEmail(user: UserID): Unit!
   update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User!
   newToken(comment: String, name: String, permissions: String): Token!

frontend/src/Datarekisteri/Frontend/FormFields.hs

@@ -33,12 +33,13 @@ telephoneField = Field
     { fieldParse = \rawValues _ ->
         case rawValues of
           [] -> pure $ Right Nothing
+          [""] -> pure $ Right Nothing
           [x] -> pure $ maybe (Left "could not parse as a phone number") (Right . Just) $ toPhoneNumber x
           _ -> pure $ Left $ "Expected one value"
     , fieldView = \id name otherAttributes result isRequired ->
         let result' = either (\x -> x) renderPhoneNumber result
         in [whamlet|
-               <input type="tel" id="#{id}" name="#{name}" value="#{result'}" *{otherAttributes} :isRequired:required="true">
+               <input type="tel" id="#{id}" name="#{name}" value="#{result'}" pattern="[+ 0123456789]*" title="Only '+', spaces and numbers are allowed" "*{otherAttributes} :isRequired:required="true">
            |]
     , fieldEnctype = UrlEncoded
     }

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

@@ -14,7 +14,6 @@ module Datarekisteri.Frontend.Handlers.Profile where
 
 import Relude hiding (id)
 
-import Data.Maybe (fromJust)
 import Data.Morpheus.Client (raw, declareLocalTypesInline)
 
 import Yesod hiding (emailField)
@@ -62,28 +61,22 @@ mutation UpdatePassword($user: UserID, $password: String!) {
 passwordForm :: Form Text
 passwordForm = renderDivs $ areq verifiedPasswordField "Uusi salasana" Nothing
 
-profileForm :: (Maybe UserID) -> (Maybe ProfilePageUser) -> Form UpdateProfileArgs
-profileForm userID user extraHtml = do
-    (nameRes, nameView) <- mopt textField "Nimi"
-        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in name) user)
-    (homeRes, homeView) <- mopt textField "Kotipaikka"
-        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in homeplace) user)
-    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi"
-        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in nickname) user)
-    (emailRes, emailView) <- mopt emailField "Sähköposti"
-        (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 <$>
+profileForm :: ProfilePageUser -> Form UpdateProfileArgs
+profileForm ProfilePageUser {..} extraHtml = do
+    (nameRes, nameView) <- mopt textField "Nimi" (Just $ Just name)
+    (homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ Just homeplace)
+    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ Just nickname)
+    (emailRes, emailView) <- mopt emailField "Sähköposti" (Just email)
+    (phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero" (Just $ Just phoneNumber)
+    (applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus" (Just $ Just application)
+    let profileUpdateRes = UpdateProfileArgs (Just id) <$>
             nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
-        maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
-        canUpdateApplication = maybe False (\x -> let ProfilePageUser {..} = x in not isMember) user
         inputField FieldView {..} = [whamlet|
             <label for="#{fvId}">
                 ^{fvLabel}
                 ^{fvInput}
+                $maybe err <- fvErrors
+                    <div class=".errors">#{err}
             |]
         widget = [whamlet|
             #{extraHtml}
@@ -92,12 +85,12 @@ profileForm userID user extraHtml = do
             ^{inputField nicknameView}
             ^{inputField phoneNumberView}
             ^{inputField emailView}
-            $maybe pendingEmail <- maybePendingEmail
+            $maybe pending <- pendingEmail
                 <p>Päivitys osoitteeseen #
-                    <a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
+                    <a href="mailto:#{renderEmail pending}">#{renderEmail pending}
                     odottaa vahvistusta. #
                     <a href="@{VerifyEmailR}">Siirry vahvistamaan
-            $if canUpdateApplication
+            $if not isMember
                 ^{inputField applicationView}
             |]
     return (profileUpdateRes, widget)
@@ -127,10 +120,11 @@ getProfile userID = do
     ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
     passwordForm <- liftHandler $ generateFormPost passwordForm
     profileForm <- liftHandler $ generateFormPost $
-        profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) user
+        profileForm (fromJust user)
     defaultLayout $ profile (fromJust user)
         profileForm passwordForm
-        where fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
+
+fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
 
 getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
 getOwnProfileR = getProfile Nothing
@@ -140,12 +134,12 @@ getProfileR = getProfile . Just
 
 postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
 postProfileR userID = do
-    ((result, widget), enctype) <- runFormPost $ profileForm (Just userID) Nothing
+    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
+    ((result, widget), enctype) <- runFormPost $ profileForm (fromJust user)
     case result of
       FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
       _ -> do
           passwordForm <- liftHandler $ generateFormPost passwordForm
-          ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
           defaultLayout $ profile (fromJust user) (widget, enctype) passwordForm
           --- XXX fromJust explodes if the user no longer exists
 
@@ -156,7 +150,7 @@ postUpdatePasswordR userID = do
       FormSuccess new ->
           apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
       _ -> do
-          profileForm <- liftHandler $ generateFormPost $ profileForm (Just userID) Nothing
           ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
+          profileForm <- liftHandler $ generateFormPost $ profileForm (fromJust user)
           defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
           --- XXX fromJust explodes if the user no longer exists

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

@@ -36,7 +36,11 @@ postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Hand
 postVerifyEmailR = do
     ((result, widget), enctype) <- runFormPost verifyForm
     case result of
-      FormSuccess verify -> apiRequest @VerifyEmail False verify >> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
+      FormSuccess verify -> do
+          success <- apiRequest @VerifyEmail False verify
+          case success of
+            VerifyEmail True -> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
+            VerifyEmail False -> setMessage "Virheellinen vahvistuskoodi" >> redirect VerifyEmailR
       _ -> defaultLayout $ verifyEmailW (widget, enctype)
 
 verifyEmailW (codeWidget, codeEnctype) = do

frontend/src/Datarekisteri/Frontend/Types.hs

@@ -287,6 +287,9 @@ instance Yesod DataIdClient where
                 input[type="submit"].reject-button:hover {
                   background-color: #aa3968;
                 }
+                input:invalid {
+                  border-color: #8a003a;
+                }
                 nav {
                   display: block;
                   position: fixed;
@@ -322,6 +325,18 @@ instance Yesod DataIdClient where
                 .left-nav {
                   float: right;
                 }
+                aside.messages > ul {
+                  list-style: none;
+                  padding: 0;
+                  margin: 0;
+                }
+                aside.messages li.message {
+                  display: block;
+                  padding: 0.7em;
+                  background-color: #3b4553;
+                  color: white;
+                  border-radius: 0.3em;
+                }
                 main {
                   margin: 0 auto;
                   max-width: 50em;