diff --git a/src/Data/Char/Local.hs b/src/Data/Char/Local.hs new file mode 100644 index 0000000..1092337 --- /dev/null +++ b/src/Data/Char/Local.hs @@ -0,0 +1,24 @@ +{- 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 + - . + -} + +module Data.Char.Local + ( isAsciiLetter + ) +where + +import Prelude + +isAsciiLetter :: Char -> Bool +isAsciiLetter c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' diff --git a/src/Field.hs b/src/Field.hs new file mode 100644 index 0000000..f5f03b9 --- /dev/null +++ b/src/Field.hs @@ -0,0 +1,83 @@ +{- 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 + - . + -} + +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 diff --git a/src/Form.hs b/src/Form.hs new file mode 100644 index 0000000..7ff8891 --- /dev/null +++ b/src/Form.hs @@ -0,0 +1,39 @@ +{- 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 + - . + -} + +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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index b2497e0..2ae69be 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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 diff --git a/src/Handler/Person.hs b/src/Handler/Person.hs index 4e6bedc..6e57d63 100644 --- a/src/Handler/Person.hs +++ b/src/Handler/Person.hs @@ -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 diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs new file mode 100644 index 0000000..4bfea72 --- /dev/null +++ b/src/Handler/Util.hs @@ -0,0 +1,24 @@ +{- 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 + - . + -} + +module Handler.Util + ( loggedIn + ) +where + +import Import + +loggedIn :: Handler Bool +loggedIn = isJust <$> maybeAuthId diff --git a/vervis.cabal b/vervis.cabal index 6c8098f..f8569fe 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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