Eventually-decentralized project hosting and management platform

[[ 🗃 ^WvWbo vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/WvWbo

SSH: darcs clone USERNAME@vervis.peers.community:WvWbo

Tags

TODO

src / Vervis / Handler /

Inbox.hs

{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2022 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.Inbox
    ( getSharerInboxR
    , getProjectInboxR
    , getDeckInboxR
    , getRepoInboxR
    , postSharerInboxR
    , postProjectInboxR
    , postDeckInboxR
    , postRepoInboxR
    , getSharerOutboxR
    , getSharerOutboxItemR
    , getProjectOutboxR
    , getProjectOutboxItemR
    , getDeckOutboxR
    , getDeckOutboxItemR
    , getRepoOutboxR
    , getRepoOutboxItemR
    )
where

import Control.Applicative ((<|>))
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
import Control.Exception hiding (Handler)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger.CallStack
import Control.Monad.STM (atomically)
import Control.Monad.Trans.Except
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Bitraversable
import Data.Foldable (for_)
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock
import Data.Time.Interval (TimeInterval, toTimeUnit)
import Data.Time.Units (Second)
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Types.Status
import Text.Blaze.Html (Html, preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS
import Text.Shakespeare.I18N (RenderMessage)
import Yesod.Core hiding (logDebug)
import Yesod.Core.Handler
import Yesod.Form.Fields
import Yesod.Form.Functions
import Yesod.Form.Types
import Yesod.Persist.Core

import qualified Data.ByteString.Char8 as BC (unpack)
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL (toStrict)
import qualified Data.Vector as V
import qualified Database.Esqueleto as E

import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub hiding (Project (..), ActorLocal (..))
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource

import Data.Aeson.Local
import Data.Either.Local
import Data.EventTime.Local
import Data.Paginate.Local
import Data.Time.Clock.Local
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.API
import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model hiding (Ticket)
import Vervis.Model.Ident
import Vervis.Paginate
import Vervis.Settings

getShowTime = showTime <$> liftIO getCurrentTime
    where
    showTime now =
        showEventTime .
        intervalToEventTime .
        FriendlyConvert .
        diffUTCTime now

objectSummary o =
    case M.lookup "summary" o of
        Just (String t) | not (T.null t) -> Just t
        _ -> Nothing

objectId o =
    case M.lookup "id" o <|> M.lookup "@id" o of
        Just (String t) | not (T.null t) -> t
        _ -> error "'id' field not found"

getSharerInboxR :: ShrIdent -> Handler TypedContent
getSharerInboxR shr = getInbox here getInboxId
    where
    here = SharerInboxR shr
    getInboxId = do
        sid <- getKeyBy404 $ UniqueSharer shr
        p <- getValBy404 $ UniquePersonIdent sid
        return $ personInbox p

getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectInboxR shr prj = getInbox here getInboxId
    where
    here = ProjectInboxR shr prj
    getInboxId = do
        sid <- getKeyBy404 $ UniqueSharer shr
        j <- getValBy404 $ UniqueProject prj sid
        a <- getJust $ projectActor j
        return $ actorInbox a

getDeckInboxR :: KeyHashid Project -> Handler TypedContent
getDeckInboxR dkkhid = do
    dkid <- decodeKeyHashid404 dkkhid
    getInbox here (getInboxId dkid)
    where
    here = ProjectInboxR dkkhid
    getInboxId dkid = do
        dk <- get404 dkid
        actorInbox <$> getJust (projectActor dk)

getRepoInboxR :: ShrIdent -> RpIdent -> Handler TypedContent
getRepoInboxR shr rp = getInbox here getInboxId
    where
    here = RepoInboxR shr rp
    getInboxId = do
        sid <- getKeyBy404 $ UniqueSharer shr
        r <- getValBy404 $ UniqueRepo rp sid
        return $ repoInbox r

postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip

postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR shr prj = handleInbox $ handleProjectInbox shr prj

postDeckInboxR :: KeyHashid Project -> Handler ()
postDeckInboxR dkkhid = handleInbox $ handleDeckInbox dkkhid

postRepoInboxR :: ShrIdent -> RpIdent -> Handler ()
postRepoInboxR shr rp = handleInbox $ handleRepoInbox shr rp

{-
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
jsonField = checkMMap fromTextarea toTextarea textareaField
    where
    toTextarea = Textarea . TL.toStrict . encodePrettyToLazyText
    fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea
-}


getSharerOutboxR :: ShrIdent -> Handler TypedContent
getSharerOutboxR shr = getOutbox here getObid
    where
    here = SharerOutboxR shr
    getObid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        p <- getValBy404 $ UniquePersonIdent sid
        return $ personOutbox p

getSharerOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
getSharerOutboxItemR shr obikhid = getOutboxItem here getObid obikhid
    where
    here = SharerOutboxItemR shr obikhid
    getObid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        p <- getValBy404 $ UniquePersonIdent sid
        return $ personOutbox p

getProjectOutboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectOutboxR shr prj = getOutbox here getObid
    where
    here = ProjectOutboxR shr prj
    getObid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        j <- getValBy404 $ UniqueProject prj sid
        a <- getJust $ projectActor j
        return $ actorOutbox a

getProjectOutboxItemR
    :: ShrIdent -> PrjIdent -> KeyHashid OutboxItem -> Handler TypedContent
getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid
    where
    here = ProjectOutboxItemR shr prj obikhid
    getObid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        j <- getValBy404 $ UniqueProject prj sid
        a <- getJust $ projectActor j
        return $ actorOutbox a

getDeckOutboxR :: KeyHashid Project -> Handler TypedContent
getDeckOutboxR dkkhid = do
    dkid <- decodeKeyHashid404 dkkhid
    getOutbox here (getObid dkid)
    where
    here = DeckOutboxR dkkhid
    getObid dkid = do
        dk <- get404 dkid
        actorOutbox <$> getJust (projectActor dk)

getDeckOutboxItemR
    :: KeyHashid Project -> KeyHashid OutboxItem -> Handler TypedContent
getDeckOutboxItemR dkkhid obikhid = do
    dkid <- decodeKeyHashid404 dkkhid
    getOutboxItem here (getObid dkid) obikhid
    where
    here = DeckOutboxItemR dkkhid obikhid
    getObid dkid = do
        dk <- get404 dkid
        actorOutbox <$> getJust (projectActor dk)

getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent
getRepoOutboxR shr rp = getOutbox here getObid
    where
    here = RepoOutboxR shr rp
    getObid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        r <- getValBy404 $ UniqueRepo rp sid
        return $ repoOutbox r

getRepoOutboxItemR
    :: ShrIdent -> RpIdent -> KeyHashid OutboxItem -> Handler TypedContent
getRepoOutboxItemR shr rp obikhid = getOutboxItem here getObid obikhid
    where
    here = RepoOutboxItemR shr rp obikhid
    getObid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        r <- getValBy404 $ UniqueRepo rp sid
        return $ repoOutbox r
[See repo JSON]