Require phone number to register

Client/FormFields.hs

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

Client/Handlers/Applications.hs

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

Client/Handlers/Apply.hs

@@ -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.")]}
 

Client/Handlers/Profile.hs

@@ -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) {
+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) {
+  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)
+    (nameRes, nameView) <- mopt textField "Nimi"
-    (homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
+        (Just $ maybe Nothing (\x -> Just $ name (x :: ProfilePageUser)) user)
-    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ maybe Nothing (\x -> Just $ nickname (x :: ProfilePageUser)) user)
+    (homeRes, homeView) <- mopt textField "Kotipaikka"
-    (emailRes, emailView) <- mopt emailField "Sähköposti" (maybe Nothing (\x -> Just $ email (x :: ProfilePageUser)) user)
+        (Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
-    let profileUpdateRes = UpdateProfileArgs userID <$> nameRes <*> homeRes <*> nicknameRes <*> emailRes
+    (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 #

Server/API.hs

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

Server/DB/Queries.hs

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

Server/Types.hs

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

schema.gql

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