diff --git a/config/models b/config/models index 414c555..3b49c95 100644 --- a/config/models +++ b/config/models @@ -131,6 +131,12 @@ Instance UniqueInstance host +RemoteCollection + instance InstanceId + ident LocalURI + + UniqueRemoteCollection instance ident + FollowerSet Follow diff --git a/migrations/2019_05_17.model b/migrations/2019_05_17.model new file mode 100644 index 0000000..79d1fb5 --- /dev/null +++ b/migrations/2019_05_17.model @@ -0,0 +1,5 @@ +RemoteCollection + instance InstanceId + ident Text + + UniqueRemoteCollection instance ident diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 21177d5..afab31d 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -19,6 +19,7 @@ module Data.Aeson.Local , fromEither , frg , (.=?) + , (.=%) , WithValue (..) ) where @@ -59,6 +60,13 @@ infixr 8 .=? _ .=? Nothing = mempty k .=? (Just v) = k .= v +infixr 8 .=% +(.=%) :: ToJSON v => Text -> [v] -> Series +k .=% v = + if null v + then mempty + else k .= v + data WithValue a = WithValue { wvRaw :: Object , wvParsed :: a diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 55eef97..794378d 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -1051,6 +1051,11 @@ isInstanceErrorG (Just e) = APGetErrorJSON _ -> False APGetErrorContentType _ -> False +data Recip + = RecipRA (Entity RemoteActor) + | RecipURA (Entity UnfetchedRemoteActor) + | RecipRC (Entity RemoteCollection) + -- | Handle a Note submitted by a local user to their outbox. It can be either -- a comment on a local ticket, or a comment on some remote context. Return an -- error message if the Note is rejected, otherwise the new 'LocalMessageId'. @@ -1477,16 +1482,18 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c else do es <- for lus' $ \ lu -> do ma <- runMaybeT - $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu) - <|> Right <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu) + $ RecipRA <$> MaybeT (getBy $ UniqueRemoteActor iid lu) + <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu) + <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection iid lu) return $ case ma of - Nothing -> Left lu - Just e -> - Right $ case e of - Left (Entity raid ra) -> Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) - Right (Entity uraid ura) -> Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura) - let (unknown, newKnown) = partitionEithers $ NE.toList es + Nothing -> Just $ Left lu + Just r -> + case r of + RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) + RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura) + RecipRC _ -> Nothing + let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es (fetched, unfetched) = partitionEithers newKnown return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown)) let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips' @@ -1615,42 +1622,48 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c if isInstanceErrorG err then Nothing else Just Nothing - Right (Right era) -> Just $ Just era + Right (Right mera) -> Just $ Just mera case e' of Nothing -> runSiteDB $ do let recips' = NE.toList recips updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False] - Just mera -> do + Just mmera -> do for_ rs $ \ (uraid, luActor, udlid) -> fork $ do e <- fetchRemoteActor iid h luActor case e of - Right (Right (Entity raid ra)) -> do - (fwd, e') <- deliver luActor h $ remoteActorInbox ra + Right (Right mera) -> + case mera of + Nothing -> runSiteDB $ delete udlid + Just (Entity raid ra) -> do + (fwd, e') <- deliver luActor h $ remoteActorInbox ra + runSiteDB $ + case e' of + Left _ -> do + updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + delete udlid + insert_ $ Delivery raid obid fwd False + Right _ -> delete udlid + _ -> runSiteDB $ do + updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] + update udlid [UnlinkedDeliveryRunning =. False] + case mmera of + Nothing -> runSiteDB $ do + updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] + update udlid [UnlinkedDeliveryRunning =. False] + Just mera -> + case mera of + Nothing -> runSiteDB $ delete udlid + Just (Entity raid ra) -> do + (fwd, e'') <- deliver luActor h $ remoteActorInbox ra runSiteDB $ - case e' of + case e'' of Left _ -> do updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] delete udlid insert_ $ Delivery raid obid fwd False Right _ -> delete udlid - _ -> runSiteDB $ do - updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] - update udlid [UnlinkedDeliveryRunning =. False] - case mera of - Nothing -> runSiteDB $ do - updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] - update udlid [UnlinkedDeliveryRunning =. False] - Just (Entity raid ra) -> do - (fwd, e'') <- deliver luActor h $ remoteActorInbox ra - runSiteDB $ - case e'' of - Left _ -> do - updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] - delete udlid - insert_ $ Delivery raid obid fwd False - Right _ -> delete udlid where logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", h, t] @@ -1661,7 +1674,9 @@ retryOutboxDelivery = do (udls, dls, fws) <- runSiteDB $ do -- Get all unlinked deliveries which aren't running already in outbox -- post handlers - unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` i `E.LeftOuterJoin` ra) -> do + unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do + E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. rc E.?. RemoteCollectionInstance + E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. rc E.?. RemoteCollectionIdent E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. ra E.?. RemoteActorInstance E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. ra E.?. RemoteActorIdent E.on $ ura E.^. UnfetchedRemoteActorInstance E.==. i E.^. InstanceId @@ -1680,6 +1695,7 @@ retryOutboxDelivery = do , udl E.^. UnlinkedDeliveryForwarding , ob E.^. OutboxItemActivity , ra E.?. RemoteActorId + , rc E.?. RemoteCollectionId ) -- Strip the E.Value wrappers and organize the records for the -- filtering and grouping we'll need to do @@ -1689,7 +1705,7 @@ retryOutboxDelivery = do (found, lonely) = partitionMaybes unlinked -- Turn the found ones into linked deliveries deleteWhere [UnlinkedDeliveryId <-. map (unlinkedID . snd) found] - insertMany_ $ map toLinked found + insertMany_ $ mapMaybe toLinked found -- We're left with the lonely ones. We'll check which actors have been -- unreachable for too long, and we'll delete deliveries for them. The -- rest of the actors we'll try to reach by HTTP. @@ -1785,8 +1801,8 @@ retryOutboxDelivery = do logInfo "Periodic delivery done" where adaptUnlinked - (E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid) = - ( mraid + (E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid) = + ( Left <$> mraid <|> Right <$> mrcid , ( ( (iid, h) , ((uraid, luRecip), (udlid, fwd, obid, persistJSONValue act)) ) @@ -1794,7 +1810,8 @@ retryOutboxDelivery = do ) ) unlinkedID ((_, (_, (udlid, _, _, _))), _) = udlid - toLinked (raid, ((_, (_, (_, fwd, obid, _))), _)) = Delivery raid obid fwd False + toLinked (Left raid, ((_, (_, (_, fwd, obid, _))), _)) = Just $ Delivery raid obid fwd False + toLinked (Right _ , _ ) = Nothing relevant dropAfter now since = addUTCTime dropAfter since > now decideBySinceUDL dropAfter now (udl@(_, (_, (udlid, _, _, _))), msince) = case msince of @@ -1889,26 +1906,29 @@ retryOutboxDelivery = do renderFedURI (l2f h luRecip) e <- fetchRemoteActor iid h luRecip case e of - Right (Right (Entity raid ra)) -> do - waitsD <- for delivs $ \ (udlid, fwd, obid, doc) -> fork $ do - let fwd' = if fwd then Just luRecip else Nothing - e' <- deliver doc fwd' h $ remoteActorInbox ra - case e' of - Left _err -> do - runSiteDB $ do - delete udlid - insert_ $ Delivery raid obid fwd False - return False - Right _resp -> do - runSiteDB $ delete udlid - return True - results <- sequence waitsD - runSiteDB $ - if and results - then update raid [RemoteActorErrorSince =. Nothing] - else if or results - then update raid [RemoteActorErrorSince =. Just now] - else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] + Right (Right mera) -> + case mera of + Nothing -> runSiteDB $ deleteWhere [UnlinkedDeliveryId <-. map fst4 (NE.toList delivs)] + Just (Entity raid ra) -> do + waitsD <- for delivs $ \ (udlid, fwd, obid, doc) -> fork $ do + let fwd' = if fwd then Just luRecip else Nothing + e' <- deliver doc fwd' h $ remoteActorInbox ra + case e' of + Left _err -> do + runSiteDB $ do + delete udlid + insert_ $ Delivery raid obid fwd False + return False + Right _resp -> do + runSiteDB $ delete udlid + return True + results <- sequence waitsD + runSiteDB $ + if and results + then update raid [RemoteActorErrorSince =. Nothing] + else if or results + then update raid [RemoteActorErrorSince =. Just now] + else updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] _ -> runSiteDB $ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now] return True results <- sequence waitsR diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 895f6d3..c45bf6b 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -166,11 +166,12 @@ getTopReply replyP = do postTopReply :: Text -> [Route App] + -> [Route App] -> Route App -> Route App -> (LocalMessageId -> Route App) -> Handler Html -postTopReply hDest recips context replyP after = do +postTopReply hDest recipsA recipsC context replyP after = do ((result, widget), enctype) <- runFormPost newMessageForm elmid <- runExceptT $ do msg <- case result of @@ -185,15 +186,17 @@ postTopReply hDest recips context replyP after = do lift $ runDB $ sharerIdent <$> get404 (personIdent p) let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor uContext = encodeRecipRoute context + recips = recipsA ++ recipsC note = Note { noteId = Nothing , noteAttrib = luAuthor , noteAudience = Audience - { audienceTo = map encodeRecipRoute recips - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] + { audienceTo = map encodeRecipRoute recips + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + , audienceNonActors = map encodeRecipRoute recipsC } , noteReplyTo = Just uContext , noteContext = Just uContext @@ -224,6 +227,7 @@ getReply replyG replyP getdid midParent = do postReply :: Text -> [Route App] + -> [Route App] -> Route App -> (MessageId -> Route App) -> (MessageId -> Route App) @@ -231,7 +235,7 @@ postReply -> AppDB DiscussionId -> MessageId -> Handler Html -postReply hDest recips context replyG replyP after getdid midParent = do +postReply hDest recipsA recipsC context replyG replyP after getdid midParent = do ((result, widget), enctype) <- runFormPost newMessageForm elmid <- runExceptT $ do msg <- case result of @@ -262,15 +266,17 @@ postReply hDest recips context replyG replyP after getdid midParent = do return (shr, parent) let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor uContext = encodeRecipRoute context + recips = recipsA ++ recipsC note = Note { noteId = Nothing , noteAttrib = luAuthor , noteAudience = Audience - { audienceTo = map encodeRecipRoute recips - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] + { audienceTo = map encodeRecipRoute recips + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + , audienceNonActors = map encodeRecipRoute recipsC } , noteReplyTo = Just uParent , noteContext = Just uContext diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index c618476..52c2634 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -327,20 +327,21 @@ postOutboxR shrAuthor = do let encodeRecipRoute = l2f hTicket . encodeRouteLocal uTicket = encodeRecipRoute $ TicketR shrTicket prj num (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor - recips = - [ ProjectR shrTicket prj - , TicketParticipantsR shrTicket prj num + collections = + [ TicketParticipantsR shrTicket prj num , TicketTeamR shrTicket prj num ] + recips = ProjectR shrTicket prj : collections note = Note { noteId = Nothing , noteAttrib = luAuthor , noteAudience = Audience - { audienceTo = map encodeRecipRoute recips - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] + { audienceTo = map encodeRecipRoute recips + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + , audienceNonActors = map encodeRecipRoute collections } , noteReplyTo = Just $ fromMaybe uTicket muParent , noteContext = Just uTicket diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 4974d08..ff3c07b 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -648,10 +648,8 @@ postTicketDiscussionR shr prj num = do hLocal <- getsYesod $ appInstanceHost . appSettings postTopReply hLocal - [ ProjectR shr prj - , TicketParticipantsR shr prj num - , TicketTeamR shr prj num - ] + [ProjectR shr prj] + [TicketParticipantsR shr prj num, TicketTeamR shr prj num] (TicketR shr prj num) (TicketDiscussionR shr prj num) (const $ TicketR shr prj num) @@ -668,10 +666,8 @@ postTicketMessageR shr prj num mkhid = do hLocal <- getsYesod $ appInstanceHost . appSettings postReply hLocal - [ ProjectR shr prj - , TicketParticipantsR shr prj num - , TicketTeamR shr prj num - ] + [ProjectR shr prj] + [TicketParticipantsR shr prj num, TicketTeamR shr prj num] (TicketR shr prj num) (TicketReplyR shr prj num . encodeHid) (TicketMessageR shr prj num . encodeHid) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index fedc964..bace23c 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -274,6 +274,8 @@ changes = , addUnique "InboxItemLocal" $ Unique "UniqueInboxItemLocalItem" ["item"] -- 73 , addUnique "InboxItemRemote" $ Unique "UniqueInboxItemRemoteItem" ["item"] + -- 74 + , addEntities model_2019_05_17 ] migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 4eb4fc5..7ccd016 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -39,6 +39,7 @@ module Vervis.Migration.Model , model_2019_04_12 , model_2019_04_22 , model_2019_05_03 + , model_2019_05_17 ) where @@ -106,3 +107,6 @@ model_2019_04_22 = $(schema "2019_04_22") model_2019_05_03 :: [Entity SqlBackend] model_2019_05_03 = $(schema "2019_05_03") + +model_2019_05_17 :: [Entity SqlBackend] +model_2019_05_17 = $(schema "2019_05_17") diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 91bdc64..ae3e5f3 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -32,6 +32,7 @@ where import Prelude +import Control.Applicative import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, newMVar) import Control.Concurrent.ResultShare @@ -41,6 +42,7 @@ import Control.Monad import Control.Monad.Logger.CallStack import Control.Monad.STM import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Foldable import Data.HashMap.Strict (HashMap) import Data.Maybe @@ -79,7 +81,7 @@ data RoomMode = RoomModeInstant | RoomModeCached RoomModeDB -type ActorFetchShare site = ResultShare FedURI (Either (Maybe APGetError) (Entity RemoteActor)) (site, InstanceId) +type ActorFetchShare site = ResultShare FedURI (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) (site, InstanceId) class Yesod site => YesodRemoteActorStore site where siteInstanceMutex :: site -> InstanceMutex @@ -469,18 +471,31 @@ actorFetchShareAction , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT ) - => FedURI -> (site, InstanceId) -> IO (Either (Maybe APGetError) (Entity RemoteActor)) + => FedURI + -> (site, InstanceId) + -> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) actorFetchShareAction u (site, iid) = flip runWorkerT site $ do let (h, lu) = f2l u - mers <- runSiteDB $ getBy $ UniqueRemoteActor iid lu - case mers of - Just ers -> return $ Right ers + mrecip <- runSiteDB $ runMaybeT + $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu) + <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid lu) + case mrecip of + Just recip -> + return $ Right $ + case recip of + Left ers -> Just ers + Right _ -> Nothing Nothing -> do manager <- asksSite getHttpManager - eactor <- fetchAPID' manager actorId h lu - for eactor $ \ actor -> runSiteDB $ - let ra = RemoteActor lu iid (actorInbox actor) Nothing - in either id (flip Entity ra) <$> insertBy' ra + erecip <- fetchRecipient manager h lu + for erecip $ \ recip -> + case recip of + RecipientActor actor -> runSiteDB $ + let ra = RemoteActor lu iid (actorInbox actor) Nothing + in Just . either id (flip Entity ra) <$> insertBy' ra + RecipientCollection _ -> runSiteDB $ do + insertUnique_ $ RemoteCollection iid lu + return Nothing fetchRemoteActor :: ( YesodPersist site @@ -493,11 +508,17 @@ fetchRemoteActor , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT ) - => InstanceId -> Text -> LocalURI -> m (Either SomeException (Either (Maybe APGetError) (Entity RemoteActor))) + => InstanceId -> Text -> LocalURI -> m (Either SomeException (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))) fetchRemoteActor iid host luActor = do - mers <- runSiteDB $ getBy $ UniqueRemoteActor iid luActor - case mers of - Just ers -> return $ Right $ Right ers + mrecip <- runSiteDB $ runMaybeT + $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid luActor) + <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid luActor) + case mrecip of + Just recip -> + return $ Right $ Right $ + case recip of + Left ers -> Just ers + Right _ -> Nothing Nothing -> do site <- askSite liftIO $ runShared (siteActorFetchShare site) (l2f host luActor) (site, iid) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 4c90867..b2dfa68 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -31,6 +31,9 @@ module Web.ActivityPub , Owner (..) , PublicKey (..) , Actor (..) + , CollectionType (..) + , Collection (..) + , Recipient (..) -- * Activity , Note (..) @@ -57,6 +60,7 @@ module Web.ActivityPub , Fetched (..) , fetchAPID , fetchAPID' + , fetchRecipient , keyListedByActor , fetchUnknownKey , fetchKnownPersonalKey @@ -327,6 +331,63 @@ instance ActivityPub Actor where <> "inbox" .= l2f host inbox <> "publicKey" `pair` encodePublicKeySet host pkeys +data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered + +instance FromJSON CollectionType where + parseJSON = withText "CollectionType" parse + where + parse "Collection" = pure CollectionTypeUnordered + parse "OrderedCollection" = pure CollectionTypeOrdered + parse t = fail $ "Unknown collection type: " ++ T.unpack t + +instance ToJSON CollectionType where + toJSON = error "toJSON CollectionType" + toEncoding ct = + toEncoding $ case ct of + CollectionTypeUnordered -> "Collection" :: Text + CollectionTypeOrdered -> "OrderedCollection" + +data Collection a = Collection + { collectionId :: LocalURI + , collectionType :: CollectionType + , collectionTotalItems :: Maybe Int + , collectionCurrent :: Maybe LocalURI + , collectionFirst :: Maybe LocalURI + , collectionLast :: Maybe LocalURI + , collectionItems :: [a] + } + +instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where + jsonldContext _ = ContextAS2 + parseObject o = do + (host, id_) <- f2l <$> o .: "id" + fmap (host,) $ + Collection id_ + <$> o .: "type" + <*> o .:? "totalItems" + <*> withHostMaybe host (fmap f2l <$> o .:? "current") + <*> withHostMaybe host (fmap f2l <$> o .:? "first") + <*> withHostMaybe host (fmap f2l <$> o .:? "last") + <*> optional (o .: "items" <|> o .: "orderedItems") .!= [] + toSeries host (Collection id_ typ total curr firzt last items) + = "id" .= l2f host id_ + <> "type" .= typ + <> "totalItems" .=? total + <> "current" .=? (l2f host <$> curr) + <> "first" .=? (l2f host <$> firzt) + <> "last" .=? (l2f host <$> last) + <> "items" .=% items + +data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI) + +instance ActivityPub Recipient where + jsonldContext _ = ContextAS2 + parseObject o = + second RecipientActor <$> parseObject o <|> + second RecipientCollection <$> parseObject o + toSeries h (RecipientActor a) = toSeries h a + toSeries h (RecipientCollection c) = toSeries h c + data Audience = Audience { audienceTo :: [FedURI] , audienceBto :: [FedURI] @@ -372,11 +433,6 @@ encodeAudience (Audience to bto cc bcc aud nons) <> "bcc" .=% bcc <> "audience" .=% aud <> (frg <> "nonActors") .=% nons - where - t .=% v = - if null v - then mempty - else t .= v data Note = Note { noteId :: Maybe LocalURI @@ -394,7 +450,7 @@ withHost h a = do then return v else fail "URI host mismatch" -withHostM h a = do +withHostMaybe h a = do mp <- a for mp $ \ (h', v) -> if h == h' @@ -409,7 +465,7 @@ instance ActivityPub Note where (h, attrib) <- f2l <$> o .: "attributedTo" fmap (h,) $ Note - <$> withHostM h (fmap f2l <$> o .:? "id") + <$> withHostMaybe h (fmap f2l <$> o .:? "id") <*> pure attrib <*> parseAudience o <*> o .:? "inReplyTo" @@ -747,6 +803,12 @@ fetchAPID' m getId h lu = runExceptT $ do then return v else throwE Nothing +fetchRecipient :: MonadIO m => Manager -> Text -> LocalURI -> m (Either (Maybe APGetError) Recipient) +fetchRecipient m = fetchAPID' m getId + where + getId (RecipientActor a) = actorId a + getId (RecipientCollection c) = collectionId c + fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a) fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu where