mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-20 15:14:54 +09:00
84 lines
2.8 KiB
Haskell
84 lines
2.8 KiB
Haskell
{- 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/>.
|
||
-}
|
||
|
||
module Vervis.Field.Person
|
||
( loginField
|
||
, passField
|
||
)
|
||
where
|
||
|
||
import Vervis.Import
|
||
|
||
import Data.Char (isDigit)
|
||
import Data.Char.Local (isAsciiLetter)
|
||
|
||
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
|
||
msg :: Text
|
||
msg =
|
||
"The first character must be a letter, and every other character \
|
||
\must be a letter, a digit, ‘.’ (period) , ‘-’ (dash) or ‘_’ \
|
||
\(underscore)."
|
||
in checkBool ok msg
|
||
|
||
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
|