mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-10 15:36:46 +09:00
141 lines
4.6 KiB
Haskell
141 lines
4.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.Group
|
|
( getGroupsR
|
|
, postGroupsR
|
|
, getGroupNewR
|
|
, getGroupR
|
|
, getGroupMembersR
|
|
, postGroupMembersR
|
|
, getGroupMemberNewR
|
|
, getGroupMemberR
|
|
, deleteGroupMemberR
|
|
, postGroupMemberR
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Database.Esqueleto
|
|
import Text.Blaze.Html (Html)
|
|
import Yesod.Auth (requireAuthId)
|
|
import Yesod.Core (defaultLayout, setMessage)
|
|
import Yesod.Core.Handler (redirect, lookupPostParam, notFound)
|
|
import Yesod.Form.Functions (runFormPost)
|
|
import Yesod.Form.Types (FormResult (..))
|
|
import Yesod.Persist.Core (runDB, getBy404)
|
|
|
|
import Vervis.Form.Group
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Model.Group
|
|
import Vervis.Model.Ident (ShrIdent, shr2text)
|
|
import Vervis.Settings (widgetFile)
|
|
import Vervis.Time (showDate)
|
|
import Vervis.Widget.Sharer (groupLinkW, personLinkW)
|
|
|
|
getGroupsR :: Handler Html
|
|
getGroupsR = do
|
|
groups <- runDB $ select $ from $ \ (sharer, group) -> do
|
|
where_ $ sharer ^. SharerId ==. group ^. GroupIdent
|
|
orderBy [asc $ sharer ^. SharerIdent]
|
|
return sharer
|
|
defaultLayout $(widgetFile "group/list")
|
|
|
|
postGroupsR :: Handler Html
|
|
postGroupsR = do
|
|
((result, widget), enctype) <- runFormPost newGroupForm
|
|
case result of
|
|
FormSuccess ng -> do
|
|
now <- liftIO getCurrentTime
|
|
pid <- requireAuthId
|
|
runDB $ do
|
|
let sharer = Sharer
|
|
{ sharerIdent = ngIdent ng
|
|
, sharerName = ngName ng
|
|
, sharerCreated = now
|
|
}
|
|
sid <- insert sharer
|
|
let group = Group
|
|
{ groupIdent = sid
|
|
}
|
|
gid <- insert group
|
|
let member = GroupMember
|
|
{ groupMemberPerson = pid
|
|
, groupMemberGroup = gid
|
|
, groupMemberRole = GRAdmin
|
|
}
|
|
insert_ member
|
|
redirect $ GroupR $ ngIdent ng
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
defaultLayout $(widgetFile "group/new")
|
|
FormFailure _l -> do
|
|
setMessage "Group creation failed, see errors below"
|
|
defaultLayout $(widgetFile "group/new")
|
|
|
|
getGroupNewR :: Handler Html
|
|
getGroupNewR = do
|
|
((_result, widget), enctype) <- runFormPost newGroupForm
|
|
defaultLayout $(widgetFile "group/new")
|
|
|
|
getGroupR :: ShrIdent -> Handler Html
|
|
getGroupR shar = do
|
|
group <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shar
|
|
Entity _gid g <- getBy404 $ UniqueGroup sid
|
|
return g
|
|
defaultLayout $ return ()
|
|
|
|
getGroupMembersR :: ShrIdent -> Handler Html
|
|
getGroupMembersR shar = do
|
|
(group, members) <- runDB $ do
|
|
Entity sid s <- getBy404 $ UniqueSharer shar
|
|
Entity gid _g <- getBy404 $ UniqueGroup sid
|
|
ms <- select $ from $ \ (member, person, sharer) -> do
|
|
where_ $
|
|
member ^. GroupMemberGroup ==. val gid &&.
|
|
member ^. GroupMemberPerson ==. person ^. PersonId &&.
|
|
person ^. PersonIdent ==. sharer ^. SharerId
|
|
orderBy
|
|
[ asc $ member ^. GroupMemberRole
|
|
, asc $ sharer ^. SharerIdent
|
|
]
|
|
return sharer
|
|
return (s, ms)
|
|
defaultLayout $(widgetFile "group/members")
|
|
|
|
postGroupMembersR :: ShrIdent -> Handler Html
|
|
postGroupMembersR shar = error "Not implemented"
|
|
|
|
getGroupMemberNewR :: ShrIdent -> Handler Html
|
|
getGroupMemberNewR shar = error "Not implemented"
|
|
|
|
getGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
|
|
getGroupMemberR grp memb = error "Not implemented"
|
|
|
|
deleteGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
|
|
deleteGroupMemberR grp memb = error "Not implemented"
|
|
|
|
postGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
|
|
postGroupMemberR grp memb = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "DELETE" -> deleteGroupMemberR grp memb
|
|
_ -> notFound
|