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) -> either (const False) (const True) <$> dbVerifyEmail secret
+    , verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret
     , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
         maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
     , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
@@ -258,7 +258,7 @@ data Query m = Query
 
 data Mutation m = Mutation
     { apply :: ApplicationArgs -> m (User m)
-    , verifyEmail :: Arg "secret" Text -> m Bool
+    , verifyEmail :: Arg "secret" Text -> m Unit
     , 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,7 +33,6 @@ main = do
       GCEmails -> gcEmailsMain
       GCApplications -> gcApplicationsMain
       GCAll -> gcAllMain
-      UpdateUser opts -> updateUserMain opts
 
 addUserMain :: AddUserOpts -> CLIM ()
 addUserMain AddUserOpts {..} = do
@@ -75,15 +74,6 @@ 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")
@@ -95,7 +85,6 @@ 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
@@ -105,18 +94,9 @@ 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.")
-    <*> permissionsParser
+    <*> (fromList <$> many permissionParser)
     <*> 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")
@@ -131,13 +111,6 @@ 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,31 +6,7 @@
 
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Datarekisteri.Core.Types
+module Datarekisteri.Core.Types where
-    ( 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!): Boolean!
+  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!
   newToken(comment: String, name: String, permissions: String): Token!

frontend/src/Datarekisteri/Frontend/FormFields.hs

@@ -33,13 +33,12 @@ 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'}" pattern="[+ 0123456789]*" title="Only '+', spaces and numbers are allowed" "*{otherAttributes} :isRequired:required="true">
+               <input type="tel" id="#{id}" name="#{name}" value="#{result'}" *{otherAttributes} :isRequired:required="true">
            |]
     , fieldEnctype = UrlEncoded
     }

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

@@ -14,6 +14,7 @@ module Datarekisteri.Frontend.Handlers.Profile where
 
 import Relude hiding (id)
 
+import Data.Maybe (fromJust)
 import Data.Morpheus.Client (raw, declareLocalTypesInline)
 
 import Yesod hiding (emailField)
@@ -61,22 +62,28 @@ mutation UpdatePassword($user: UserID, $password: String!) {
 passwordForm :: Form Text
 passwordForm = renderDivs $ areq verifiedPasswordField "Uusi salasana" Nothing
 
-profileForm :: ProfilePageUser -> Form UpdateProfileArgs
+profileForm :: (Maybe UserID) -> (Maybe ProfilePageUser) -> Form UpdateProfileArgs
-profileForm ProfilePageUser {..} extraHtml = do
+profileForm userID user extraHtml = do
-    (nameRes, nameView) <- mopt textField "Nimi" (Just $ Just name)
+    (nameRes, nameView) <- mopt textField "Nimi"
-    (homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ Just homeplace)
+        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in name) user)
-    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ Just nickname)
+    (homeRes, homeView) <- mopt textField "Kotipaikka"
-    (emailRes, emailView) <- mopt emailField "Sähköposti" (Just email)
+        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in homeplace) user)
-    (phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero" (Just $ Just phoneNumber)
+    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi"
-    (applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus" (Just $ Just application)
+        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in nickname) user)
-    let profileUpdateRes = UpdateProfileArgs (Just id) <$>
+    (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 <$>
             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}
@@ -85,12 +92,12 @@ profileForm ProfilePageUser {..} extraHtml = do
             ^{inputField nicknameView}
             ^{inputField phoneNumberView}
             ^{inputField emailView}
-            $maybe pending <- pendingEmail
+            $maybe pendingEmail <- maybePendingEmail
                 <p>Päivitys osoitteeseen #
-                    <a href="mailto:#{renderEmail pending}">#{renderEmail pending}
+                    <a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
                     odottaa vahvistusta. #
                     <a href="@{VerifyEmailR}">Siirry vahvistamaan
-            $if not isMember
+            $if canUpdateApplication
                 ^{inputField applicationView}
             |]
     return (profileUpdateRes, widget)
@@ -120,11 +127,10 @@ getProfile userID = do
     ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
     passwordForm <- liftHandler $ generateFormPost passwordForm
     profileForm <- liftHandler $ generateFormPost $
-        profileForm (fromJust user)
+        profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) 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
@@ -134,12 +140,12 @@ getProfileR = getProfile . Just
 
 postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
 postProfileR userID = do
-    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
+    ((result, widget), enctype) <- runFormPost $ profileForm (Just userID) Nothing
-    ((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
 
@@ -150,7 +156,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,11 +36,7 @@ postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Hand
 postVerifyEmailR = do
     ((result, widget), enctype) <- runFormPost verifyForm
     case result of
-      FormSuccess verify -> do
+      FormSuccess verify -> apiRequest @VerifyEmail False verify >> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
-          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,9 +287,6 @@ instance Yesod DataIdClient where
                 input[type="submit"].reject-button:hover {
                   background-color: #aa3968;
                 }
-                input:invalid {
-                  border-color: #8a003a;
-                }
                 nav {
                   display: block;
                   position: fixed;
@@ -325,18 +322,6 @@ 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;