vervis/src/Vervis/Widget/Person.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2019, 2022, 2023 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.Widget.Person
    ( personLinkW
    , personLinkFedW
    , followW
    , personNavW
    )
where

import Data.Foldable
import Database.Persist
import Network.HTTP.Types.Method
import Yesod.Core
import Yesod.Persist.Core

import Network.FedURI
import Yesod.Auth.Unverified
import Yesod.Hashids

import qualified Web.ActivityPub as AP

import Database.Persist.Local

import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Widget

personLinkW :: Entity Person -> Actor -> Widget
personLinkW (Entity personID person) actor = do
    personHash <- encodeKeyHashid personID
    [whamlet|
        <a href=@{PersonR personHash}>
          #{actorName actor} ~#{username2text $ personUsername person}
    |]

personLinkFedW
    :: Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor)
    -> Widget
personLinkFedW (Left (ep, a)) = personLinkW ep a
personLinkFedW (Right (inztance, object, actor)) =
    [whamlet|
        <a href="#{renderObjURI uActor}">
          #{marker $ remoteActorType actor} #
          $maybe name <- remoteActorName actor
            #{name} @ #{renderAuthority $ instanceHost inztance}
          $nothing
            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
    |]
    where
    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
    marker = \case
        AP.ActorTypePerson -> '~'
        AP.ActorTypeRepo -> '^'
        AP.ActorTypeTicketTracker -> '='
        AP.ActorTypePatchTracker -> '+'
        AP.ActorTypeProject -> '$'
        AP.ActorTypeTeam -> '&'
        AP.ActorTypeOther _ -> '?'

followW :: Route App -> Route App -> FollowerSetId -> Widget
followW followRoute unfollowRoute fsid = do
    maybeUser <- maybeVerifiedAuth
    for_ maybeUser $ \ (Entity _ user) -> do
        mfollow <-
            handlerToWidget $ runDB $
                getBy $ UniqueFollow (personActor user) fsid
        case mfollow of
            Nothing -> buttonW POST "Follow" followRoute
            Just _ -> buttonW POST "Unfollow" unfollowRoute

personNavW :: Entity Person -> Widget
personNavW (Entity personID person) = do
    personHash <- encodeKeyHashid personID
    $(widgetFile "person/widget/nav")