mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-10 01:16:46 +09:00
104 lines
3.6 KiB
Haskell
104 lines
3.6 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.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)
|
|
|
|
-- | 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
|
|
regEnabled <- appRegister . appSettings <$> getYesod
|
|
if regEnabled
|
|
then 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")
|
|
else notFound
|
|
--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
|
|
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 :: Text -> Handler Html
|
|
getPersonR ident = do
|
|
person <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharerIdent ident
|
|
Entity _pid p <- getBy404 $ UniquePersonIdent sid
|
|
return p
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ "Vervis > People > " <> ident
|
|
$(widgetFile "person")
|