diff --git a/config/models b/config/models index 624eae4..303a8b8 100644 --- a/config/models +++ b/config/models @@ -20,7 +20,7 @@ Sharer ident Text --CI name Text Maybe - UniqueIdent ident + UniqueSharerIdent ident Person ident SharerId diff --git a/config/routes b/config/routes index d473a36..c008b2f 100644 --- a/config/routes +++ b/config/routes @@ -32,7 +32,7 @@ / HomeR GET -/u PeopleR GET -- POST +/u PeopleR GET POST /u/!new PersonNewR GET /u/#Text PersonR GET diff --git a/src/Handler/Person.hs b/src/Handler/Person.hs index 0e59915..4e6bedc 100644 --- a/src/Handler/Person.hs +++ b/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 Database.Esqueleto +import Data.Char (isDigit) +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 -formPersonNew = renderDivs $ PersonNew - <$> areq textField "Username" Nothing - <*> areq passwordField "Password" Nothing - <*> areq passwordField "Repeat password" Nothing +isAsciiLetter :: Char -> Bool +isAsciiLetter c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' + +checkLoginTemplate :: Field Handler Text -> Field Handler Text +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 = +postPeopleR :: Handler Html +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 diff --git a/templates/password-field.hamlet b/templates/password-field.hamlet new file mode 100644 index 0000000..c3f390f --- /dev/null +++ b/templates/password-field.hamlet @@ -0,0 +1,17 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ 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 +$# . + + +
Confirm: +