Eventually-decentralized project hosting and management platform
Clone
HTTPS:
darcs clone https://vervis.peers.community/repos/WvWbo
SSH:
darcs clone USERNAME@vervis.peers.community:WvWbo
Tags
TODO
Actor.hs
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | {- This file is part of Vervis.
-
- Written in 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.Data.Actor
( parseLocalActivityURI
, parseActivityURI
, activityRoute
, stampRoute
, parseStampRoute
, localActorID
, parseLocalURI
, parseFedURIOld
, parseLocalActorE
)
where
import Control.Concurrent.Chan
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Data.Text (Text)
import Database.Persist.Types
import UnliftIO.Exception (try, SomeException, displayException)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Network.FedURI
import Web.Actor
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient
parseLocalActivityURI
:: (MonadSite m, YesodHashids (SiteEnv m))
=> LocalURI
-> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
parseLocalActivityURI luAct = do
route <- fromMaybeE (decodeRouteLocal luAct) "Not a valid route"
(actorHash, outboxItemHash) <-
fromMaybeE
(parseOutboxItemRoute route)
"Valid local route, but not an outbox item route"
outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
return (actorKey, actorHash, outboxItemID)
where
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i)
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
parseOutboxItemRoute _ = Nothing
-- | If the given URI is remote, return as is. If the URI is local, verify that
-- it parses as an activity URI, i.e. an outbox item route, and return the
-- parsed route.
parseActivityURI
:: (MonadSite m, SiteEnv m ~ App)
=> FedURI
-> ExceptT Text m
(Either
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
FedURI
)
parseActivityURI u@(ObjURI h lu) = do
hl <- hostIsLocalOld h
if hl
then Left <$> parseLocalActivityURI lu
else pure $ Right u
activityRoute :: LocalActorBy KeyHashid -> KeyHashid OutboxItem -> Route App
activityRoute (LocalActorPerson p) = PersonOutboxItemR p
activityRoute (LocalActorGroup g) = GroupOutboxItemR g
activityRoute (LocalActorRepo r) = RepoOutboxItemR r
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
activityRoute (LocalActorLoom l) = LoomOutboxItemR l
stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
stampRoute (LocalActorPerson p) = PersonStampR p
stampRoute (LocalActorGroup g) = GroupStampR g
stampRoute (LocalActorRepo r) = RepoStampR r
stampRoute (LocalActorDeck d) = DeckStampR d
stampRoute (LocalActorLoom l) = LoomStampR l
parseStampRoute
:: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
parseStampRoute (PersonStampR p i) = Just (LocalActorPerson p, i)
parseStampRoute (GroupStampR g i) = Just (LocalActorGroup g, i)
parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i)
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
parseStampRoute _ = Nothing
localActorID :: LocalActorBy Entity -> ActorId
localActorID (LocalActorPerson (Entity _ p)) = personActor p
localActorID (LocalActorGroup (Entity _ g)) = groupActor g
localActorID (LocalActorRepo (Entity _ r)) = repoActor r
localActorID (LocalActorDeck (Entity _ d)) = deckActor d
localActorID (LocalActorLoom (Entity _ l)) = loomActor l
parseFedURIOld
:: ( MonadSite m
, SiteEnv m ~ site
, YesodActivityPub site
, SiteFedURIMode site ~ URIMode
)
=> FedURI
-> ExceptT Text m (Either (Route App) FedURI)
parseFedURIOld u@(ObjURI h lu) = do
hl <- hostIsLocalOld h
if hl
then Left <$> parseLocalURI lu
else pure $ Right u
parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
parseLocalActorE route = do
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
unhashLocalActorE actorByHash "Invalid actor keyhashid"
|