Move some utils to new modules
This commit is contained in:
parent
b95bf9e42b
commit
9154ad8f8b
7 changed files with 179 additions and 80 deletions
24
src/Data/Char/Local.hs
Normal file
24
src/Data/Char/Local.hs
Normal file
|
@ -0,0 +1,24 @@
|
|||
{- 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 Data.Char.Local
|
||||
( isAsciiLetter
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
isAsciiLetter :: Char -> Bool
|
||||
isAsciiLetter c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z'
|
83
src/Field.hs
Normal file
83
src/Field.hs
Normal file
|
@ -0,0 +1,83 @@
|
|||
{- 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 Field
|
||||
( loginField
|
||||
, passField
|
||||
)
|
||||
where
|
||||
|
||||
import 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
|
||||
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
|
39
src/Form.hs
Normal file
39
src/Form.hs
Normal file
|
@ -0,0 +1,39 @@
|
|||
{- 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 Form
|
||||
( PersonNew (..)
|
||||
, formPersonNew
|
||||
)
|
||||
where
|
||||
|
||||
import Import
|
||||
|
||||
import Field
|
||||
|
||||
data PersonNew = PersonNew
|
||||
{ uLogin :: Text
|
||||
, uPass :: Text
|
||||
, uEmail :: Maybe Text
|
||||
}
|
||||
|
||||
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
|
|
@ -20,13 +20,14 @@ where
|
|||
|
||||
import Import hiding ((==.))
|
||||
|
||||
import Database.Esqueleto hiding (isNothing)
|
||||
import Database.Esqueleto
|
||||
import Git
|
||||
import Handler.Util (loggedIn)
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
mpid <- maybeAuthId
|
||||
if isNothing mpid
|
||||
li <- loggedIn
|
||||
if li
|
||||
then do
|
||||
rows <- do
|
||||
repos <- runDB $ select $ from $ \ (sharer, project, repo) -> do
|
||||
|
|
|
@ -24,88 +24,12 @@ where
|
|||
import Import hiding ((==.))
|
||||
--import Prelude
|
||||
|
||||
import Data.Char (isDigit)
|
||||
import Database.Esqueleto hiding (isNothing)
|
||||
import Form
|
||||
--import Model
|
||||
import Text.Blaze (text)
|
||||
import Yesod.Auth.HashDB (setPassword)
|
||||
|
||||
data PersonNew = PersonNew
|
||||
{ uLogin :: Text
|
||||
, uPass :: Text
|
||||
, uEmail :: Maybe Text
|
||||
}
|
||||
|
||||
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
|
||||
|
|
24
src/Handler/Util.hs
Normal file
24
src/Handler/Util.hs
Normal file
|
@ -0,0 +1,24 @@
|
|||
{- 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 Handler.Util
|
||||
( loggedIn
|
||||
)
|
||||
where
|
||||
|
||||
import Import
|
||||
|
||||
loggedIn :: Handler Bool
|
||||
loggedIn = isJust <$> maybeAuthId
|
|
@ -35,6 +35,9 @@ flag library-only
|
|||
|
||||
library
|
||||
exposed-modules: Application
|
||||
Data.Char.Local
|
||||
Field
|
||||
Form
|
||||
Foundation
|
||||
Git
|
||||
Import
|
||||
|
@ -46,6 +49,7 @@ library
|
|||
Handler.Home
|
||||
Handler.Person
|
||||
Handler.Project
|
||||
Handler.Util
|
||||
Style
|
||||
-- other-modules:
|
||||
default-extensions: TemplateHaskell
|
||||
|
|
Loading…
Reference in a new issue