vervis/src/Vervis/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 Vervis.Handler.Person
    ( getPeopleR
    , postPeopleR
    , getPersonNewR
    , getPersonR
    )
where

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

import Database.Esqueleto hiding (isNothing)
import Vervis.Form.Person
--import Model
import Text.Blaze.Html (toHtml)
import Yesod.Auth.HashDB (setPassword)

import Vervis.Model.Ident

-- | 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 $(widgetFile "people")

-- | Create new user
postPeopleR :: Handler Html
postPeopleR = do
    regEnabled <- getsYesod $ appRegister . appSettings
    if regEnabled
        then do
            ((result, widget), enctype) <- runFormPost formPersonNew
            case result of
                FormSuccess pn -> do
                    now <- liftIO getCurrentTime
                    runDB $ do
                        let sharer = Sharer
                                { sharerIdent   = text2shr $ uLogin pn
                                , sharerName    = uName pn
                                , sharerCreated = now
                                }
                        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 "User registration failed, see errors below"
                    defaultLayout $(widgetFile "person-new")
        else notFound

getPersonNewR :: Handler Html
getPersonNewR = do
    mpid <- maybeAuthId
    if isJust mpid
        then redirect HomeR
        else do
            regEnabled <- appRegister . appSettings <$> getYesod
            if regEnabled
                then do
                    ((_result, widget), enctype) <- runFormPost formPersonNew
                    defaultLayout $ do
                        setTitle "Vervis > People > New"
                        $(widgetFile "person-new")
                else notFound

getPersonR :: ShrIdent -> Handler Html
getPersonR ident = do
    person <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharer ident
        Entity _pid p <- getBy404 $ UniquePersonIdent sid
        return p
    defaultLayout $(widgetFile "person")