Compare commits
No commits in common. "7983f9b18704ce2e07351b64c3f9b37b7ed93030" and "b3737b312b819925fd21d19a0ceea62d1d5c2c32" have entirely different histories.
7983f9b187
...
b3737b312b
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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!
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue