Implement registration and make it build

config/models

@@ -20,7 +20,7 @@ Sharer
     ident Text       --CI
     name  Text Maybe
 
-    UniqueIdent ident
+    UniqueSharerIdent ident
 
 Person
     ident SharerId

config/routes

@@ -32,7 +32,7 @@
 
 /                            HomeR      GET
 
-/u                           PeopleR    GET -- POST
+/u                           PeopleR    GET POST
 /u/!new                      PersonNewR GET
 /u/#Text                     PersonR    GET
 

src/Handler/Person.hs

@@ -15,6 +15,7 @@
 
 module Handler.Person
     ( getPeopleR
+    , postPeopleR
     , getPersonNewR
     , getPersonR
     )
@@ -23,25 +24,88 @@ where
 import Import hiding ((==.))
 --import Prelude
 
-import Text.Blaze (text)
+import Data.Char (isDigit)
-import Database.Esqueleto
+import Database.Esqueleto hiding (isNothing)
 --import Model
---import Yesod.Core (Handler)
+import Text.Blaze (text)
+import Yesod.Auth.HashDB (setPassword)
 
 data PersonNew = PersonNew
     { uLogin :: Text
     , uPass  :: Text
-    , uPass' :: Text
     , uEmail :: Maybe Text
     }
 
-formPersonNew :: Form PersonNew
+isAsciiLetter :: Char -> Bool
-formPersonNew = renderDivs $ PersonNew
+isAsciiLetter c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z'
-    <$> areq textField "Username" Nothing
+
-    <*> areq passwordField "Password" Nothing
+checkLoginTemplate :: Field Handler Text -> Field Handler Text
-    <*> areq passwordField "Repeat password" Nothing
+checkLoginTemplate =
+    let first = isAsciiLetter
+        rest c = isAsciiLetter c || isDigit c || c `elem` ("-._" :: String)
+        ok t =
+            case uncons t of
+                Just (c, r) -> first c && all rest r
+                Nothing     -> False
+    in  checkBool
+            ok
+            ( "The first character must be a letter, and every other \
+            \ character must be a letter, a digit, ‘.’ (period) , ‘-’ (dash) \
+            \or ‘_’ (underscore)." :: Text)
+
+checkLoginUnique :: Field Handler Text -> Field Handler Text
+checkLoginUnique = checkM $ \ login -> runDB $ do
+    let sharer = Sharer
+            { sharerIdent = login
+            , sharerName  = Nothing
+            }
+    mus <- checkUnique sharer
+    return $ if isNothing mus
+        then Right login
+        else Left ("This username is already in use" :: Text)
+
+loginField :: Field Handler Text
+loginField = checkLoginUnique . checkLoginTemplate $ textField
+
+checkPassLength :: Field Handler Text -> Field Handler Text
+checkPassLength =
+    let msg :: Text
+        msg =
+            "The password must be at least 8 characters long. Yes, I know, \
+            \having so many different passwords for many different sites is \
+            \annoying and cumbersome. I'm trying to figure out an \
+            \alternative, such as a client TLS certificate, that can work \
+            \somewhat like SSH and GPG keys."
+        minlen = 8
+    in  checkBool  ((>= minlen) . length) msg
+
+passConfirmField :: Field Handler Text
+passConfirmField = Field
+    { fieldParse = \ vals _files ->
+        return $ case vals of
+            [a, b] ->
+                if a == b
+                    then Right $ Just a
+                    else Left "Passwords don’t match"
+            [] -> Right Nothing
+            _ -> Left "You must enter the password twice"
+    , fieldView = \ idAttr nameAttr otherAttrs _eResult _isReq ->
+        $(widgetFile "password-field")
+    , fieldEnctype = UrlEncoded
+    }
+
+passField :: Field Handler Text
+passField = checkPassLength passConfirmField
+
+newPersonAForm :: AForm Handler PersonNew
+newPersonAForm = PersonNew
+    <$> areq loginField "Username" Nothing
+    <*> areq passField "Password" Nothing
     <*> aopt emailField "E-mail" Nothing
 
+formPersonNew :: Form PersonNew
+formPersonNew = renderTable newPersonAForm
+
 -- | Get list of users
 getPeopleR :: Handler Html
 getPeopleR = do
@@ -54,8 +118,37 @@ getPeopleR = do
         $(widgetFile "people")
 
 -- | Create new user
---postPeopleR :: Handler Html
+postPeopleR :: Handler Html
---postPeopleR =
+postPeopleR = do
+    ((result, widget), enctype) <- runFormPost formPersonNew
+    case result of
+        FormSuccess pn -> do
+            runDB $ do
+                let sharer = Sharer
+                        { sharerIdent = uLogin pn
+                        , sharerName  = Nothing
+                        }
+                sid <- insert sharer
+                let person = Person
+                        { personIdent = sid
+                        , personLogin = uLogin pn
+                        , personHash  = Nothing
+                        , personEmail = uEmail pn
+                        }
+                person' <- setPassword (uPass pn) person
+                insert_ person'
+            redirectUltDest HomeR
+        FormMissing -> do
+            setMessage "Field(s) missing"
+            defaultLayout $(widgetFile "person-new")
+        FormFailure l -> do
+            setMessage $ toHtml $ intercalate "; " l
+            defaultLayout $(widgetFile "person-new")
+    --TODO NEXT:
+    -- * Maybe make the form return Form Person and just insert defaults (using
+    -- 'pure') for the remaining Person fields? Then, maybe the same form can
+    -- be used to generate the RESTful JSON API query that adds a Person with
+    -- their entire details. Dunno if it matters, just could be good/nice/cool.
 
 getPersonNewR :: Handler Html
 getPersonNewR = do

templates/password-field.hamlet

@@ -0,0 +1,17 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
+<div>Confirm:
+<input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>