Compare commits

..

No commits in common. "7983f9b18704ce2e07351b64c3f9b37b7ed93030" and "b3737b312b819925fd21d19a0ceea62d1d5c2c32" have entirely different histories.

8 changed files with 33 additions and 98 deletions

View File

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

View File

@ -33,7 +33,6 @@ main = do
GCEmails -> gcEmailsMain GCEmails -> gcEmailsMain
GCApplications -> gcApplicationsMain GCApplications -> gcApplicationsMain
GCAll -> gcAllMain GCAll -> gcAllMain
UpdateUser opts -> updateUserMain opts
addUserMain :: AddUserOpts -> CLIM () addUserMain :: AddUserOpts -> CLIM ()
addUserMain AddUserOpts {..} = do addUserMain AddUserOpts {..} = do
@ -75,15 +74,6 @@ gcAllMain = do
gcEmailsMain gcEmailsMain
gcApplicationsMain 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 :: Parser CLIOptions
cliOptions = CLIOptions cliOptions = CLIOptions
<$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend") <$> 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-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-applications" (info (pure GCApplications) (progDesc "Delete users without an email address"))
<> command "gc" (info (pure GCAll) (progDesc "Run all garbage collection jobs.")) <> 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 :: Parser CLISubCommand
addUserCommand = fmap AddUser $ AddUserOpts 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") <*> 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 $ 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.") <*> 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.") <*> 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 :: Parser (Scope, Permission)
permissionParser = (,) permissionParser = (,)
<$> option auto (long "scope") <$> option auto (long "scope")
@ -131,13 +111,6 @@ data CLISubCommand = AddUser AddUserOpts
| GCEmails | GCEmails
| GCApplications | GCApplications
| GCAll | GCAll
| UpdateUser UpdateUserOpts
data UpdateUserOpts = UpdateUserOpts
{ updateUserId :: UserID
, updateUserApplication :: Maybe Text
, updateUserPermissions :: Maybe (Map Scope Permission)
}
data AddUserOpts = AddUserOpts data AddUserOpts = AddUserOpts
{ addUserNickname :: Maybe Text { addUserNickname :: Maybe Text

View File

@ -6,31 +6,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# 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 import Relude

View File

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

View File

@ -33,13 +33,12 @@ telephoneField = Field
{ fieldParse = \rawValues _ -> { fieldParse = \rawValues _ ->
case rawValues of case rawValues of
[] -> pure $ Right Nothing [] -> pure $ Right Nothing
[""] -> pure $ Right Nothing
[x] -> pure $ maybe (Left "could not parse as a phone number") (Right . Just) $ toPhoneNumber x [x] -> pure $ maybe (Left "could not parse as a phone number") (Right . Just) $ toPhoneNumber x
_ -> pure $ Left $ "Expected one value" _ -> pure $ Left $ "Expected one value"
, fieldView = \id name otherAttributes result isRequired -> , fieldView = \id name otherAttributes result isRequired ->
let result' = either (\x -> x) renderPhoneNumber result let result' = either (\x -> x) renderPhoneNumber result
in [whamlet| 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 , fieldEnctype = UrlEncoded
} }

View File

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

View File

@ -36,11 +36,7 @@ postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Hand
postVerifyEmailR = do postVerifyEmailR = do
((result, widget), enctype) <- runFormPost verifyForm ((result, widget), enctype) <- runFormPost verifyForm
case result of 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) _ -> defaultLayout $ verifyEmailW (widget, enctype)
verifyEmailW (codeWidget, codeEnctype) = do verifyEmailW (codeWidget, codeEnctype) = do

View File

@ -287,9 +287,6 @@ instance Yesod DataIdClient where
input[type="submit"].reject-button:hover { input[type="submit"].reject-button:hover {
background-color: #aa3968; background-color: #aa3968;
} }
input:invalid {
border-color: #8a003a;
}
nav { nav {
display: block; display: block;
position: fixed; position: fixed;
@ -325,18 +322,6 @@ instance Yesod DataIdClient where
.left-nav { .left-nav {
float: right; 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 { main {
margin: 0 auto; margin: 0 auto;
max-width: 50em; max-width: 50em;