vervis/src/Handler/Person.hs

{- 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.Person
    ( getPeopleR
    , postPeopleR
    , getPersonNewR
    , getPersonR
    )
where

import Import hiding ((==.))
--import Prelude

import Data.Char (isDigit)
import Database.Esqueleto hiding (isNothing)
--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
    people <- runDB $ select $ from $ \ (sharer, person) -> do
        where_ $ sharer ^. SharerId ==. person ^. PersonIdent
        orderBy [asc $ sharer ^. SharerIdent]
        return $ sharer ^. SharerIdent
    defaultLayout $ do
        setTitle "Vervis > People"
        $(widgetFile "people")

-- | Create new user
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
    mpid <- maybeAuthId
    if isJust mpid
        then redirect HomeR
        else do
            ((_result, widget), enctype) <- runFormPost formPersonNew
            defaultLayout $ do
                setTitle "Vervis > People > New"
                $(widgetFile "person-new")

getPersonR :: Text -> Handler Html
getPersonR ident = do
    people <- runDB $ select $ from $ \ (sharer, person) -> do
        where_ $
            sharer ^. SharerIdent ==. val ident &&.
            sharer ^. SharerId ==. person ^. PersonIdent
        return person
    case people of
        []   -> notFound
        p:ps -> defaultLayout $ do
            let mperson = if null ps then Just p else Nothing
            setTitle $ text $ "Vervis > People > " <> ident
            $(widgetFile "person")