ry
/
datarekisteri
10
0
Fork 0
Code Issues 10 Pull Requests Packages Projects Releases Wiki Activity

Require phone number to register

This commit is contained in:
Saku Laesvuori 2023-04-10 11:37:43 +03:00
parent 33661d5716
commit 60d9706fe6
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
8 changed files with 86 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
Client/FormFields.hs
View File

@ -21,7 +21,22 @@ emailField = Field
, fieldView = \id name otherAttributes result isRequired ->
let result' = either (\x -> x) renderEmail result
in [whamlet|
<input type="email" id="#{id}" name="#{name}" value="#{result'}" *{otherAttributes} :isRequired:required="">
<input type="email" id="#{id}" name="#{name}" value="#{result'}" *{otherAttributes} :isRequired:required="true">
|]
, fieldEnctype = UrlEncoded
}
telephoneField :: Field Handler PhoneNumber
telephoneField = Field
{ fieldParse = \rawValues _ ->
case rawValues of
[] -> 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">
|]
, fieldEnctype = UrlEncoded
}

4
Client/Handlers/Applications.hs
View File

@ -31,6 +31,7 @@ query Applications {
name
nickname
email
phoneNumber
homeplace
birthdate
application
@ -85,6 +86,9 @@ applicationsW applications = do
<tr>
<th scope="row">Sähköposti
<td>#{renderEmail $ fromJust $ email}
<tr>
<th scope="row">Puhelinnumero
<td>#{renderPhoneNumber $ phoneNumber}
$maybe route <- acceptRoute
<form action="@{route}" method="post" enctype="#{enctype}">
^{widget}

12
Client/Handlers/Apply.hs
View File

@ -25,16 +25,10 @@ import Data.Time (Day)
declareLocalTypesInline "schema.gql" [raw|
mutation Apply($name: String!, $nickname: String, $homeplace: String!,
$birthdate: Date!, $email: Email!, $password: String!, $application: String!) {
$birthdate: Date!, $email: Email!, $phoneNumber: PhoneNumber!, $password: String!, $application: String!) {
apply(email: $email, password: $password, name: $name, nickname: $nickname,
birthdate: $birthdate, homeplace: $homeplace, application: $application) {
birthdate: $birthdate, homeplace: $homeplace, application: $application, phoneNumber: $phoneNumber) {
id
name
nickname
email
pendingEmail
homeplace
birthdate
}
}
|]
@ -46,6 +40,7 @@ applyForm = renderDivs $ ApplyArgs
<*> areq textField homeplaceSettings Nothing
<*> areq dayField' birthdateSettings Nothing
<*> areq emailField emailSettings Nothing
<*> areq telephoneField phoneSettings Nothing
<*> areq verifiedPasswordField "Salasana" Nothing
<*> areq textareaField' applicationSettings Nothing
where dayField' :: Field Handler Date
@ -58,6 +53,7 @@ applyForm = renderDivs $ ApplyArgs
homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}
birthdateSettings = "Syntymäaika" {fsAttrs = [("placeholder","2000-01-01")]}
emailSettings = "Sähköposti" {fsAttrs = [("placeholder","erkki.juhani@esimerkki.fi")]}
phoneSettings = "Puhelinnumero" {fsAttrs = [("placeholder","+358 12 34567890")]}
applicationSettings = "Hakemus (eli miksi olet data)"
{fsAttrs = [("placeholder","Aloitin opiskelun Otaniemen datalla vuonna 2020.")]}

23
Client/Handlers/Profile.hs
View File

@ -32,14 +32,15 @@ query ProfilePage($id: UserID) {
pendingEmail
homeplace
birthdate
phoneNumber
}
permissions
}
|]
declareLocalTypesInline "schema.gql" [raw|
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email) {
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber) {
id
}
}
@ -58,11 +59,18 @@ 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 $ name (x ::ProfilePageUser)) user)
(homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
(nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ maybe Nothing (\x -> Just $ nickname (x :: ProfilePageUser)) user)
(emailRes, emailView) <- mopt emailField "Sähköposti" (maybe Nothing (\x -> Just $ email (x :: ProfilePageUser)) user)
let profileUpdateRes = UpdateProfileArgs userID <$> nameRes <*> homeRes <*> nicknameRes <*> emailRes
(nameRes, nameView) <- mopt textField "Nimi"
(Just $ maybe Nothing (\x -> Just $ name (x :: ProfilePageUser)) user)
(homeRes, homeView) <- mopt textField "Kotipaikka"
(Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
(nicknameRes, nicknameView) <- mopt textField "Kutsumanimi"
(Just $ maybe Nothing (\x -> Just $ nickname (x :: ProfilePageUser)) user)
(emailRes, emailView) <- mopt emailField "Sähköposti"
(maybe Nothing (\x -> Just $ email (x :: ProfilePageUser)) user)
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
(Just $ maybe Nothing (\x -> Just $ phoneNumber (x :: ProfilePageUser)) user)
let profileUpdateRes = UpdateProfileArgs userID <$>
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
maybePendingEmail = user >>= \x -> pendingEmail (x :: ProfilePageUser)
inputField FieldView {..} = [whamlet|
<label for="#{fvId}">
@ -74,6 +82,7 @@ profileForm userID user extraHtml = do
^{inputField nameView}
^{inputField homeView}
^{inputField nicknameView}
^{inputField phoneNumberView}
^{inputField emailView}
$maybe pendingEmail <- maybePendingEmail
<p>Päivitys osoitteeseen #

7
Server/API.hs
View File

@ -57,6 +57,7 @@ dbUserToUser user = let id = entityToID user
{ id = pure id
, email = pure dBUserEmail
, pendingEmail = pure dBUserPendingEmail
, phoneNumber = pure phoneNumber
, name = pure name
, nickname = pure $ fromMaybe (error "db contains empty name") $
maybe (viaNonEmpty head $ words $ name) Just nickname
@ -150,7 +151,8 @@ updateUser user (UpdateData {..}) = do
user <- updateUserData user
(catMaybes [(DBUserPendingEmail =. ) . Just <$> email, verificationSecretUpdate,
(DBUserPasswordCrypt =.) <$> hash])
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname, SetUserHomeplace <$> homeplace])
(catMaybes [SetUserName <$> name, SetUserNickname . Just <$> nickname,
SetUserHomeplace <$> homeplace, SetUserPhoneNumber <$> phoneNumber])
when (isJust email) $ sendVerificationSecret user
return user
@ -249,6 +251,7 @@ data User m = User
, pendingEmail :: m (Maybe Email)
, name :: m Text
, nickname :: m Text
, phoneNumber :: m PhoneNumber
, birthdate :: m Date
, homeplace :: m Text
, registered :: m Time
@ -281,6 +284,7 @@ data Token m = Token
data ApplicationData = ApplicationData
{ email :: Email
, phoneNumber :: PhoneNumber
, password :: Text
, name :: Text
, nickname :: Maybe Text
@ -291,6 +295,7 @@ data ApplicationData = ApplicationData
data UpdateData = UpdateData
{ email :: Maybe Email
, phoneNumber :: Maybe PhoneNumber
, password :: Maybe Text
, name :: Maybe Text
, nickname :: Maybe Text

2
Server/DB/Queries.hs
View File

@ -107,9 +107,11 @@ updateUserData user updates memberDataUpdates = runQuery $ do
updateData (SetUserName x) memberData = memberData { name = x }
updateData (SetUserNickname x) memberData = memberData { nickname = x }
updateData (SetUserHomeplace x) memberData = memberData { homeplace = x }
updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x }
Persist.update key (userUpdates <> updates)
pure user
data UserUpdate = SetUserName Text
| SetUserNickname (Maybe Text)
| SetUserHomeplace Text
| SetUserPhoneNumber PhoneNumber

33
Server/Types.hs
View File

@ -24,6 +24,8 @@ import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..),
import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON)
import Data.Time (UTCTime, getCurrentTime, NominalDiffTime, addUTCTime, Day)
import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
import qualified Data.Text as T
import Data.Char (isSpace)
import Database.Persist.Class (PersistField(..))
import Database.Persist.PersistValue (PersistValue(..))
import Database.Persist.Sql (PersistFieldSql(..), SqlBackend)
@ -86,11 +88,42 @@ data MemberData = MemberData
, birthdate :: Date
, homeplace :: Text
, application :: Text
, phoneNumber :: PhoneNumber
} deriving (Show, Eq, Generic)
instance FromJSON MemberData
instance ToJSON MemberData
newtype PhoneNumber = PhoneNumber Text deriving (Show, Generic)
renderPhoneNumber :: PhoneNumber -> Text
renderPhoneNumber (PhoneNumber txt) = txt
toPhoneNumber :: Text -> Maybe PhoneNumber
toPhoneNumber txt = do
guard $ not $ T.null txt
guard $ T.all (`elem` ("+ 0123456789" :: [Char])) txt
pure $ PhoneNumber txt
instance Eq PhoneNumber where
a == b = normalize a == normalize b
where normalize (PhoneNumber txt) = case T.uncons txt of
Just ('0', rest) -> "+358" <> T.filter (not . isSpace) rest
Just x -> T.filter (not . isSpace) (uncurry T.cons x)
Nothing -> error "PhoneNumber must not be empty"
instance DecodeScalar PhoneNumber where
decodeScalar (String s) =
maybe (Left $ "Couldn't parse \"" <> s <> "\" as a PhoneNumber") Right $ toPhoneNumber s
decodeScalar _ = Left "Invalid type for PhoneNumber, should be string"
instance EncodeScalar PhoneNumber where
encodeScalar = String . renderPhoneNumber
instance GQLType PhoneNumber where type KIND PhoneNumber = SCALAR
instance ToJSON PhoneNumber where toJSON = scalarToJSON
instance FromJSON PhoneNumber where parseJSON = scalarFromJSON <=< parseJSON
newtype UserID = UserID Int64 deriving (Eq, Show, Generic, Ord, Read)
instance DecodeScalar UserID where

7
schema.gql
View File

@ -6,6 +6,8 @@ scalar Email
scalar KeyID
scalar PhoneNumber
scalar Time
scalar TokenID
@ -43,6 +45,7 @@ type User {
pendingEmail: Email
name: String!
nickname: String!
phoneNumber: PhoneNumber!
birthdate: Date!
homeplace: String!
registered: Time!
@ -64,10 +67,10 @@ type Query {
}
type Mutation {
apply(email: Email!, 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!): Unit!
resendVerificationEmail(user: UserID): Unit!
update(email: Email, password: String, name: String, nickname: String, homeplace: String, user: UserID): User!
update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, user: UserID): User!
newToken(comment: String, name: String, permissions: String): Token!
newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
accept(user: UserID!): Unit!