vervis/src/Vervis/Handler/Group.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.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