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

View File

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

View File

@ -6,31 +6,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
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
module Datarekisteri.Core.Types where
import Relude

View File

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

View File

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

View File

@ -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 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) <$>
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 <$>
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
fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
where 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 (fromJust user)
((result, widget), enctype) <- runFormPost $ profileForm (Just userID) Nothing
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

View File

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

View File

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