vervis/src/Vervis/Handler/Sharer.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2019 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.Sharer
    ( getSharersR
    , getSharerR
    )
where

import Prelude

import Control.Applicative ((<|>))
import Control.Monad.Logger (logWarn)
import Control.Monad.Trans.Maybe
import Data.Monoid ((<>))
import Database.Persist
import Text.Blaze.Html (Html)
import Yesod.Core (defaultLayout)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Handler (redirect, notFound)
import Yesod.Persist.Core (runDB, getBy404)

import Vervis.Foundation
import Vervis.Handler.Person
import Vervis.Handler.Group
import Vervis.Model
import Vervis.Model.Ident (ShrIdent, shr2text)
import Vervis.Paginate
import Vervis.Settings (widgetFile)
import Vervis.Widget.Sharer (sharerLinkW)

getSharersR :: Handler Html
getSharersR = do
    (sharers, navModel) <- getPageAndNav $ \ off lim ->
        runDB $ do
            total <- count ([] :: [Filter Sharer])
            ss <- selectList [] [OffsetBy off, LimitTo lim, Asc SharerIdent]
            return (total, ss)
    let pageNav = navWidget navModel
    defaultLayout $(widgetFile "sharer/list")

getSharerR :: ShrIdent -> Handler TypedContent
getSharerR shr = do
    ment <- runDB $ do
        Entity sid sharer <- getBy404 $ UniqueSharer shr
        runMaybeT . fmap (sharer,)
            $   Left  <$> MaybeT (getBy $ UniquePersonIdent sid)
            <|> Right <$> MaybeT (getBy $ UniqueGroup sid)
    case ment of
        Nothing -> do
            $logWarn $ "Found non-person non-group sharer: " <> shr2text shr
            notFound
        Just (s, ent) ->
            case ent of
                Left (Entity _ p) -> getPerson shr s p
                Right (Entity _ g) -> getGroup shr g