mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-01-11 08:36:46 +09:00
32c87e3839
New iteration of the ActivityPub delivery implementation and interface. Advantages over previous interface: * When sending a ByteString body, the sender is explicitly passed as a parameter instead of JSON-parsing it out of the ByteString * Clear 3 operations provided: Send, Resend and Forward * Support for per-actor keys * Actor-type-specific functions (e.g. deliverRemoteDB_D) removed * Only the most high-level API is exposed to Activity handler code, making handler code more concise and clear Also added in this patch: * Foundation for per-actor key support * 1 key per actor allowed in DB * Disabled C2S and S2S handlers now un-exported for clarity * Audience and capability parsing automatically done for all C2S handlers * Audience and activity composition automatically done for Vervis.Client builder functions Caveats: * Actor documents still don't link to their per-actor keys; that should be the last piece to complete per-actor key support * No moderation and anti-spam tools yet * Delivery API doesn't yet have good integration of persistence layer, e.g. activity is separately encoded into bytestring for DB and for HTTP; this will be improved in the next iteration * Periodic delivery now done in 3 separate steps, running sequentially; it simplifies the code, but may be changed for efficiency/robustness in the next iterations * Periodic delivery collects per-actor keys in a 1-DB-transaction-for-each-delivery fashion, rather than grabbing them in the big Esqueleto query (or keeping the signed output in the DB; this isn't done currently to allow for smooth actor key renewal) * No support yet in the API for delivery where the actor key has already been fetched, rather than doing a DB transaction to grab it; such support would be just an optimization, so it's low-priority, but will be added in later iterations
2391 lines
83 KiB
Haskell
2391 lines
83 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019, 2020, 2021, 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 Web.ActivityPub
|
|
( -- * Type-safe manipulation tools
|
|
--
|
|
-- Types and functions that make handling URIs and JSON-LD contexts less
|
|
-- error-prone and safer by recording safety checks in the type and
|
|
-- placing the checks in a single clear place.
|
|
ActivityPub (..)
|
|
, Doc (..)
|
|
|
|
-- * Actor
|
|
--
|
|
-- ActivityPub actor document including a public key, with a 'FromJSON'
|
|
-- instance for fetching and a 'ToJSON' instance for publishing.
|
|
, ActorType (..)
|
|
--, Algorithm (..)
|
|
, Owner (..)
|
|
, PublicKey (..)
|
|
, SshKeyAlgorithm (..)
|
|
, SshPublicKey (..)
|
|
, ActorLocal (..)
|
|
, ActorDetail (..)
|
|
, Actor (..)
|
|
, Repo (..)
|
|
, TicketTracker (..)
|
|
, CollectionType (..)
|
|
, Collection (..)
|
|
, CollectionPageType (..)
|
|
, CollectionPage (..)
|
|
, Recipient (..)
|
|
, Resource (..)
|
|
|
|
-- * Content objects
|
|
, Note (..)
|
|
, TicketDependency (..)
|
|
, PatchLocal (..)
|
|
, Patch (..)
|
|
, BundleLocal (..)
|
|
, Bundle (..)
|
|
, TicketLocal (..)
|
|
, MergeRequest (..)
|
|
, Ticket (..)
|
|
, Author (..)
|
|
, Hash (..)
|
|
, Commit (..)
|
|
, Branch (..)
|
|
, Role (..)
|
|
|
|
-- * Activity
|
|
, Accept (..)
|
|
, AddObject (..)
|
|
, Add (..)
|
|
, Apply (..)
|
|
, CreateObject (..)
|
|
, Create (..)
|
|
, Follow (..)
|
|
, Grant (..)
|
|
, Invite (..)
|
|
, OfferObject (..)
|
|
, Offer (..)
|
|
, Push (..)
|
|
, Reject (..)
|
|
, Resolve (..)
|
|
, Undo (..)
|
|
, Audience (..)
|
|
, SpecificActivity (..)
|
|
, Action (..)
|
|
, makeActivity
|
|
, Activity (..)
|
|
|
|
-- * Utilities
|
|
, emptyAudience
|
|
, emptyActivity
|
|
, hActivityPubActor
|
|
, provideAP
|
|
, provideAP'
|
|
, APGetError (..)
|
|
, httpGetAP
|
|
, APPostError (..)
|
|
, hActivityPubForwarder
|
|
, hForwardingSignature
|
|
, hForwardedSignature
|
|
, Envelope ()
|
|
, Errand ()
|
|
, sending
|
|
, retrying
|
|
, deliver
|
|
, forwarding
|
|
, forward
|
|
, Fetched (..)
|
|
, fetchAP
|
|
, fetchAP_T
|
|
, fetchAPID
|
|
, fetchAPID'
|
|
, fetchTip
|
|
, fetchRecipient
|
|
, fetchResource
|
|
, keyListedByActor
|
|
, fetchUnknownKey
|
|
, fetchKnownPersonalKey
|
|
, fetchKnownSharedKey
|
|
|
|
, Obj (..)
|
|
)
|
|
where
|
|
|
|
import Control.Applicative ((<|>), optional)
|
|
import Control.Exception (Exception, displayException, try)
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Class
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Writer (Writer)
|
|
import Crypto.Hash hiding (Context)
|
|
import Data.Aeson
|
|
import Data.Aeson.Encoding (pair)
|
|
import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
|
|
import Data.Bifunctor
|
|
import Data.Bitraversable
|
|
import Data.ByteString (ByteString)
|
|
import Data.Char
|
|
import Data.Foldable (for_)
|
|
import Data.List
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.Proxy
|
|
import Data.Semigroup (Endo, First (..))
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
|
|
import Data.Time.Clock
|
|
import Data.Traversable
|
|
import Network.HTTP.Client hiding (Proxy, proxy)
|
|
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
|
import Network.HTTP.Simple (JSONException)
|
|
import Network.HTTP.Types.Header (HeaderName, hContentType)
|
|
import Text.Email.Parser (EmailAddress)
|
|
import Text.HTML.SanitizeXSS
|
|
import Yesod.Core.Content (ContentType)
|
|
import Yesod.Core.Handler (ProvidedRep, provideRepType)
|
|
|
|
import Network.HTTP.Client.Signature
|
|
|
|
import qualified Data.Attoparsec.ByteString as A
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import qualified Data.ByteString.Char8 as BC
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.HashMap.Strict as M
|
|
import qualified Data.List.NonEmpty as NE
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Vector as V
|
|
import qualified Network.HTTP.Signature as S
|
|
import qualified Text.Email.Parser as E
|
|
|
|
import Crypto.PublicVerifKey
|
|
import Development.PatchMediaType
|
|
import Development.PatchMediaType.JSON
|
|
import Network.FedURI
|
|
import Network.HTTP.Digest
|
|
import Web.Text
|
|
|
|
import Data.Aeson.Local
|
|
|
|
proxy :: a u -> Proxy a
|
|
proxy _ = Proxy
|
|
|
|
as2Context :: Text
|
|
as2Context = "https://www.w3.org/ns/activitystreams"
|
|
|
|
secContext :: Text
|
|
secContext = "https://w3id.org/security/v2"
|
|
|
|
forgeContext :: Text
|
|
forgeContext = "https://forgefed.org/ns"
|
|
|
|
publicURI :: Text
|
|
publicURI = "https://www.w3.org/ns/activitystreams#Public"
|
|
|
|
class ActivityPub a where
|
|
jsonldContext :: Proxy a -> [Text]
|
|
parseObject :: UriMode u => Object -> Parser (Authority u, a u)
|
|
toSeries :: UriMode u => Authority u -> a u -> Series
|
|
|
|
data Doc a u = Doc
|
|
{ docAuthority :: Authority u
|
|
, docValue :: a u
|
|
}
|
|
|
|
instance (ActivityPub a, UriMode u) => FromJSON (Doc a u) where
|
|
parseJSON = withObject "Doc" $ \ o -> uncurry Doc <$> parseObject o
|
|
|
|
instance (ActivityPub a, UriMode u) => ToJSON (Doc a u) where
|
|
toJSON = error "toJSON Doc"
|
|
toEncoding (Doc h v) =
|
|
pairs
|
|
$ context (jsonldContext $ proxy v)
|
|
<> toSeries h v
|
|
where
|
|
context [] = mempty
|
|
context [t] = "@context" .= t
|
|
context ts = "@context" .= ts
|
|
|
|
data ActorType
|
|
= ActorTypePerson
|
|
| ActorTypeRepo
|
|
| ActorTypeTicketTracker
|
|
| ActorTypePatchTracker
|
|
| ActorTypeOther Text
|
|
deriving Eq
|
|
|
|
instance FromJSON ActorType where
|
|
parseJSON = withText "ActorType" $ pure . parse
|
|
where
|
|
parse t
|
|
| t == "Person" = ActorTypePerson
|
|
| t == "Repository" = ActorTypeRepo
|
|
| t == "TicketTracker" = ActorTypeTicketTracker
|
|
| t == "PatchTracker" = ActorTypePatchTracker
|
|
| otherwise = ActorTypeOther t
|
|
|
|
instance ToJSON ActorType where
|
|
toJSON = error "toJSON ActorType"
|
|
toEncoding at =
|
|
toEncoding $ case at of
|
|
ActorTypePerson -> "Person"
|
|
ActorTypeRepo -> "Repository"
|
|
ActorTypeTicketTracker -> "TicketTracker"
|
|
ActorTypePatchTracker -> "PatchTracker"
|
|
ActorTypeOther t -> t
|
|
|
|
data Owner = OwnerInstance | OwnerActor LocalURI
|
|
|
|
ownerShared :: Owner -> Bool
|
|
ownerShared OwnerInstance = True
|
|
ownerShared (OwnerActor _) = False
|
|
|
|
data PublicKey u = PublicKey
|
|
{ publicKeyId :: LocalRefURI
|
|
, publicKeyExpires :: Maybe UTCTime
|
|
, publicKeyOwner :: Owner
|
|
, publicKeyMaterial :: PublicVerifKey
|
|
}
|
|
|
|
instance ActivityPub PublicKey where
|
|
jsonldContext _ = [secContext]
|
|
parseObject o = do
|
|
mtyp <- optional $ o .: "@type" <|> o .: "type"
|
|
for_ mtyp $ \ t ->
|
|
unless (t == ("Key" :: Text) || t == "CryptographicKey") $
|
|
fail "PublicKey @type isn't Key or CryptographicKey"
|
|
RefURI authority id_ <- o .: "@id" <|> o .: "id"
|
|
shared <- o .:|? "isShared" .!= False
|
|
fmap (authority,) $
|
|
PublicKey id_
|
|
<$> o .:? "expires"
|
|
<*> (mkOwner shared =<< withAuthorityO authority (o .: "owner"))
|
|
<*> (either fail return . decodePublicVerifKeyPEM =<<
|
|
o .: "publicKeyPem"
|
|
)
|
|
where
|
|
mkOwner True lu
|
|
| lu == topLocalURI = return OwnerInstance
|
|
mkOwner True _ = fail "Shared key but owner isn't instance URI"
|
|
mkOwner False lu = return $ OwnerActor lu
|
|
toSeries authority (PublicKey id_ mexpires owner mat)
|
|
= "@id" .= RefURI authority id_
|
|
<> "expires" .=? mexpires
|
|
<> "owner" .= mkOwner authority owner
|
|
<> "publicKeyPem" .= encodePublicVerifKeyPEM mat
|
|
<> "isShared" .= ownerShared owner
|
|
where
|
|
mkOwner a OwnerInstance = ObjURI a topLocalURI
|
|
mkOwner a (OwnerActor lu) = ObjURI a lu
|
|
|
|
parsePublicKeySet
|
|
:: UriMode u
|
|
=> Value
|
|
-> Parser (Authority u, [Either LocalURI (PublicKey u)])
|
|
parsePublicKeySet v =
|
|
case v of
|
|
Array a ->
|
|
case V.toList a of
|
|
[] -> fail "No public keys"
|
|
k : ks -> do
|
|
(a, e) <- parseKey k
|
|
es <- traverse (withAuthorityT a . parseKey) ks
|
|
return (a, e : es)
|
|
_ -> second (: []) <$> parseKey v
|
|
where
|
|
parseKey v@(String _) = second Left . f2l <$> parseJSON v
|
|
where
|
|
f2l (ObjURI a l) = (a, l)
|
|
parseKey (Object o) = second Right <$> parseObject o
|
|
parseKey v = typeMismatch "PublicKeySet Item" v
|
|
|
|
encodePublicKeySet
|
|
:: UriMode u => Authority u -> [Either LocalURI (PublicKey u)] -> Encoding
|
|
encodePublicKeySet authority es =
|
|
case es of
|
|
[e] -> renderKey e
|
|
_ -> listEncoding renderKey es
|
|
where
|
|
renderKey (Left lu) = toEncoding $ ObjURI authority lu
|
|
renderKey (Right pk) = pairs $ toSeries authority pk
|
|
|
|
data SshKeyAlgorithm
|
|
= SshKeyAlgorithmRSA
|
|
| SshKeyAlgorithmDSA
|
|
| SshKeyAlgorithmECDSA
|
|
| SshKeyAlgorithmEd25519
|
|
|
|
instance FromJSON SshKeyAlgorithm where
|
|
parseJSON = withText "SshKeyAlgorithm" parse
|
|
where
|
|
parse t
|
|
| t == "ssh-rsa" = pure SshKeyAlgorithmRSA
|
|
| t == "ssh-dsa" = pure SshKeyAlgorithmDSA
|
|
| t == "ssh-ecdsa" = pure SshKeyAlgorithmECDSA
|
|
| t == "ssh-ed25519" = pure SshKeyAlgorithmEd25519
|
|
| otherwise =
|
|
fail $ "Unrecognized ssh key algo: " ++ T.unpack t
|
|
|
|
instance ToJSON SshKeyAlgorithm where
|
|
toJSON = error "toJSON SshKeyAlgorithm"
|
|
toEncoding = toEncoding . render
|
|
where
|
|
render :: SshKeyAlgorithm -> Text
|
|
render SshKeyAlgorithmRSA = "ssh-rsa"
|
|
render SshKeyAlgorithmDSA = "ssh-dsa"
|
|
render SshKeyAlgorithmECDSA = "ssh-ecdsa"
|
|
render SshKeyAlgorithmEd25519 = "ssh-ed25519"
|
|
|
|
data SshPublicKey u = SshPublicKey
|
|
{ sshPublicKeyId :: LocalURI
|
|
, sshPublicKeyExpires :: Maybe UTCTime
|
|
, sshPublicKeyOwner :: LocalURI
|
|
, sshPublicKeyAlgorithm :: SshKeyAlgorithm
|
|
, sshPublicKeyMaterial :: ByteString
|
|
}
|
|
|
|
instance ActivityPub SshPublicKey where
|
|
jsonldContext _ = [secContext, forgeContext]
|
|
parseObject o = do
|
|
mtyp <- optional $ o .: "@type" <|> o .: "type"
|
|
for_ mtyp $ \ t ->
|
|
when (t /= ("SshKey" :: Text)) $
|
|
fail "SshKey @type isn't SshKey"
|
|
|
|
mediaType <- o .: "mediaType"
|
|
unless (mediaType == ("application/octet-stream" :: Text)) $
|
|
fail "mediaType isn't octet-stream"
|
|
|
|
ObjURI authority luId <- o .: "@id" <|> o .: "id"
|
|
fmap (authority,) $
|
|
SshPublicKey luId
|
|
<$> o .:? "expires"
|
|
<*> withAuthorityO authority (o .: "owner")
|
|
<*> o .: "sshKeyType"
|
|
<*> (decodeBase64 . encodeUtf8 =<< o .: "content")
|
|
where
|
|
decodeBase64 = either fail return . B64.decode
|
|
toSeries authority (SshPublicKey luId mexpires owner algo mat)
|
|
= "@id" .= ObjURI authority luId
|
|
<> "expires" .=? mexpires
|
|
<> "owner" .= ObjURI authority owner
|
|
<> "sshKeyType" .= algo
|
|
<> "mediaType" .= ("application/octet-stream" :: Text)
|
|
<> "content" .= decodeUtf8 (B64.encode mat)
|
|
|
|
data ActorLocal u = ActorLocal
|
|
{ actorId :: LocalURI
|
|
, actorInbox :: LocalURI
|
|
, actorOutbox :: Maybe LocalURI
|
|
, actorFollowers :: Maybe LocalURI
|
|
, actorFollowing :: Maybe LocalURI
|
|
, actorPublicKeys :: [Either LocalURI (PublicKey u)]
|
|
, actorSshKeys :: [LocalURI]
|
|
}
|
|
|
|
parseActorLocal :: UriMode u => Object -> Parser (Maybe (Authority u, ActorLocal u))
|
|
parseActorLocal o = do
|
|
mid <- o .:? "id"
|
|
case mid of
|
|
Nothing -> do
|
|
verifyNothing "inbox"
|
|
verifyNothing "outbox"
|
|
verifyNothing "followers"
|
|
verifyNothing "following"
|
|
verifyNothing "publicKey"
|
|
verifyNothing "sshKey"
|
|
return Nothing
|
|
Just (ObjURI a id_) ->
|
|
fmap (Just . (a,)) $
|
|
ActorLocal
|
|
<$> pure id_
|
|
<*> withAuthorityO a (o .: "inbox")
|
|
<*> withAuthorityMaybeO a (o .:? "outbox")
|
|
<*> withAuthorityMaybeO a (o .:? "followers")
|
|
<*> withAuthorityMaybeO a (o .:? "following")
|
|
<*> withAuthorityT a (parsePublicKeySet =<< o .: "publicKey")
|
|
<*> (traverse (withAuthorityO a . return) =<< o .:? "sshKey" .!= [])
|
|
where
|
|
verifyNothing t =
|
|
if t `M.member` o
|
|
then fail $ T.unpack t ++ " field found, expected none"
|
|
else return ()
|
|
|
|
encodeActorLocal :: UriMode u => Authority u -> ActorLocal u -> Series
|
|
encodeActorLocal a (ActorLocal id_ inbox outbox followers following pkeys skeys)
|
|
= "id" .= ObjURI a id_
|
|
<> "inbox" .= ObjURI a inbox
|
|
<> "outbox" .=? (ObjURI a <$> outbox)
|
|
<> "followers" .=? (ObjURI a <$> followers)
|
|
<> "following" .=? (ObjURI a <$> following)
|
|
<> "publicKey" `pair` encodePublicKeySet a pkeys
|
|
<> "sshKey" .=% map (ObjURI a) skeys
|
|
|
|
data ActorDetail = ActorDetail
|
|
{ actorType :: ActorType
|
|
, actorUsername :: Maybe Text
|
|
, actorName :: Maybe Text
|
|
, actorSummary :: Maybe Text
|
|
}
|
|
|
|
parseActorDetail :: Object -> Parser ActorDetail
|
|
parseActorDetail o =
|
|
ActorDetail
|
|
<$> o .: "type"
|
|
<*> o .:? "preferredUsername"
|
|
<*> o .:? "name"
|
|
<*> o .:? "summary"
|
|
|
|
encodeActorDetail :: ActorDetail -> Series
|
|
encodeActorDetail (ActorDetail typ musername mname msummary)
|
|
= "type" .= typ
|
|
<> "preferredUsername" .=? musername
|
|
<> "name" .=? mname
|
|
<> "summary" .=? msummary
|
|
|
|
data Actor u = Actor
|
|
{ actorLocal :: ActorLocal u
|
|
, actorDetail :: ActorDetail
|
|
}
|
|
|
|
instance ActivityPub Actor where
|
|
jsonldContext _ = [as2Context, secContext, forgeContext]
|
|
parseObject o = do
|
|
mlocal <- parseActorLocal o
|
|
(h, local) <-
|
|
case mlocal of
|
|
Nothing -> fail "No ActorLocal"
|
|
Just l -> return l
|
|
detail <- parseActorDetail o
|
|
return (h, Actor local detail)
|
|
toSeries h (Actor local detail) =
|
|
encodeActorLocal h local <> encodeActorDetail detail
|
|
|
|
data Repo u = Repo
|
|
{ repoActor :: Actor u
|
|
, repoTeam :: Maybe LocalURI
|
|
, repoVcs :: VersionControlSystem
|
|
, repoLoom :: Maybe LocalURI
|
|
, repoClone :: NonEmpty LocalURI
|
|
}
|
|
|
|
instance ActivityPub Repo where
|
|
jsonldContext _ = [as2Context, secContext, forgeContext]
|
|
parseObject o = do
|
|
(h, a) <- parseObject o
|
|
unless (actorType (actorDetail a) == ActorTypeRepo) $
|
|
fail "Actor type isn't Repository"
|
|
fmap (h,) $
|
|
Repo a
|
|
<$> withAuthorityMaybeO h (o .:|? "team")
|
|
<*> o .: "versionControlSystem"
|
|
<*> withAuthorityMaybeO h (o .:? "sendPatchesTo")
|
|
<*> (traverse (withAuthorityO h . pure) =<< o .:*+ "cloneUri")
|
|
toSeries authority (Repo actor team vcs loom clone)
|
|
= toSeries authority actor
|
|
<> "team" .= (ObjURI authority <$> team)
|
|
<> "versionControlSystem" .= vcs
|
|
<> "sendPatchesTo" .=? (ObjURI authority <$> loom)
|
|
<> "cloneUri" .=*+ (ObjURI authority <$> clone)
|
|
|
|
data TicketTracker u = TicketTracker
|
|
{ ticketTrackerActor :: Actor u
|
|
, ticketTrackerTeam :: Maybe LocalURI
|
|
}
|
|
|
|
instance ActivityPub TicketTracker where
|
|
jsonldContext _ = [as2Context, secContext, forgeContext]
|
|
parseObject o = do
|
|
(h, a) <- parseObject o
|
|
unless (actorType (actorDetail a) == ActorTypeTicketTracker) $
|
|
fail "Actor type isn't TicketTracker"
|
|
fmap (h,) $
|
|
TicketTracker a
|
|
<$> withAuthorityMaybeO h (o .:|? "team")
|
|
toSeries authority (TicketTracker actor team)
|
|
= toSeries authority actor
|
|
<> "team" .= (ObjURI authority <$> team)
|
|
|
|
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 u = Collection
|
|
{ collectionId :: LocalURI
|
|
, collectionType :: CollectionType
|
|
, collectionTotalItems :: Maybe Int
|
|
, collectionCurrent :: Maybe LocalURI
|
|
, collectionFirst :: Maybe LocalPageURI
|
|
, collectionLast :: Maybe LocalPageURI
|
|
, collectionItems :: [a]
|
|
}
|
|
|
|
instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
ObjURI authority id_ <- o .: "id"
|
|
fmap (authority,) $
|
|
Collection id_
|
|
<$> o .: "type"
|
|
<*> o .:? "totalItems"
|
|
<*> withAuthorityMaybeO authority (o .:? "current")
|
|
<*> withAuthorityMaybeP authority (o .:? "first")
|
|
<*> withAuthorityMaybeP authority (o .:? "last")
|
|
<*> optional (o .: "items" <|> o .: "orderedItems") .!= []
|
|
toSeries authority (Collection id_ typ total curr firzt last items)
|
|
= "id" .= ObjURI authority id_
|
|
<> "type" .= typ
|
|
<> "totalItems" .=? total
|
|
<> "current" .=? (ObjURI authority <$> curr)
|
|
<> "first" .=? (PageURI authority <$> firzt)
|
|
<> "last" .=? (PageURI authority <$> last)
|
|
<> itemsProp .=% items
|
|
where
|
|
itemsProp =
|
|
case typ of
|
|
CollectionTypeUnordered -> "items"
|
|
CollectionTypeOrdered -> "orderedItems"
|
|
|
|
data CollectionPageType
|
|
= CollectionPageTypeUnordered
|
|
| CollectionPageTypeOrdered
|
|
|
|
instance FromJSON CollectionPageType where
|
|
parseJSON = withText "CollectionPageType" parse
|
|
where
|
|
parse "CollectionPage" = pure CollectionPageTypeUnordered
|
|
parse "OrderedCollectionPage" = pure CollectionPageTypeOrdered
|
|
parse t = fail $ "Unknown collection page type: " ++ T.unpack t
|
|
|
|
instance ToJSON CollectionPageType where
|
|
toJSON = error "toJSON CollectionPageType"
|
|
toEncoding ct =
|
|
toEncoding $ case ct of
|
|
CollectionPageTypeUnordered -> "CollectionPage" :: Text
|
|
CollectionPageTypeOrdered -> "OrderedCollectionPage"
|
|
|
|
data CollectionPage a u = CollectionPage
|
|
{ collectionPageId :: LocalPageURI
|
|
, collectionPageType :: CollectionPageType
|
|
, collectionPageTotalItems :: Maybe Int
|
|
, collectionPageCurrent :: Maybe LocalPageURI
|
|
, collectionPageFirst :: Maybe LocalPageURI
|
|
, collectionPageLast :: Maybe LocalPageURI
|
|
, collectionPagePartOf :: LocalURI
|
|
, collectionPagePrev :: Maybe LocalPageURI
|
|
, collectionPageNext :: Maybe LocalPageURI
|
|
, collectionPageStartIndex :: Maybe Int
|
|
, collectionPageItems :: [a]
|
|
}
|
|
|
|
instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
PageURI authority id_ <- o .: "id"
|
|
fmap (authority,) $
|
|
CollectionPage id_
|
|
<$> o .: "type"
|
|
<*> o .:? "totalItems"
|
|
<*> withAuthorityMaybeP authority (o .:? "current")
|
|
<*> withAuthorityMaybeP authority (o .:? "first")
|
|
<*> withAuthorityMaybeP authority (o .:? "last")
|
|
<*> withAuthorityO authority (o .: "partOf")
|
|
<*> withAuthorityMaybeP authority (o .:? "prev")
|
|
<*> withAuthorityMaybeP authority (o .:? "next")
|
|
<*> o .:? "startIndex"
|
|
<*> optional (o .: "items" <|> o .: "orderedItems") .!= []
|
|
toSeries authority (CollectionPage id_ typ total curr firzt last partOf prev next ind items)
|
|
= "id" .= PageURI authority id_
|
|
<> "type" .= typ
|
|
<> "totalItems" .=? total
|
|
<> "current" .=? (PageURI authority <$> curr)
|
|
<> "first" .=? (PageURI authority <$> firzt)
|
|
<> "last" .=? (PageURI authority <$> last)
|
|
<> "partOf" .= (ObjURI authority partOf)
|
|
<> "prev" .=? (PageURI authority <$> prev)
|
|
<> "next" .=? (PageURI authority <$> next)
|
|
<> "startIndex" .=? ind
|
|
<> itemsProp .=% items
|
|
where
|
|
itemsProp =
|
|
case typ of
|
|
CollectionPageTypeUnordered -> "items"
|
|
CollectionPageTypeOrdered -> "orderedItems"
|
|
|
|
data Recipient u = RecipientActor (Actor u) | RecipientCollection (Collection (ObjURI u) u)
|
|
|
|
instance ActivityPub Recipient where
|
|
jsonldContext _ = [as2Context, secContext, forgeContext]
|
|
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 Resource u = ResourceActor (Actor u) | ResourceChild LocalURI LocalURI
|
|
|
|
instance ActivityPub Resource where
|
|
jsonldContext _ = [as2Context, secContext, forgeContext]
|
|
parseObject o =
|
|
second ResourceActor <$> parseObject o <|> do
|
|
ObjURI h luId <- o .: "id" <|> o .: "@id"
|
|
(h,) . ResourceChild luId <$> withAuthorityO h (o .: "managedBy")
|
|
toSeries h (ResourceActor a) = toSeries h a
|
|
toSeries h (ResourceChild luId luManager)
|
|
= "id" .= ObjURI h luId
|
|
<> "managedBy" .= ObjURI h luManager
|
|
|
|
data Audience u = Audience
|
|
{ audienceTo :: [ObjURI u]
|
|
, audienceBto :: [ObjURI u]
|
|
, audienceCc :: [ObjURI u]
|
|
, audienceBcc :: [ObjURI u]
|
|
, audienceGeneral :: [ObjURI u]
|
|
, audienceNonActors :: [ObjURI u]
|
|
}
|
|
|
|
newtype AdaptAudience u = AdaptAudience
|
|
{ unAdapt :: ObjURI u
|
|
}
|
|
|
|
instance UriMode u => FromJSON (AdaptAudience u) where
|
|
parseJSON = fmap AdaptAudience . parseJSON . adapt
|
|
where
|
|
adapt v =
|
|
case v of
|
|
String t
|
|
| t == "as:Public" -> String "Public"
|
|
| t == publicURI -> String "Public"
|
|
_ -> v
|
|
|
|
parseAudience :: UriMode u => Object -> Parser (Audience u)
|
|
parseAudience o =
|
|
Audience
|
|
<$> o .:& "to"
|
|
<*> o .:& "bto"
|
|
<*> o .:& "cc"
|
|
<*> o .:& "bcc"
|
|
<*> o .:& "audience"
|
|
<*> o .:|& "nonActors"
|
|
where
|
|
obj .:& key = do
|
|
l <- obj .:? key .!= []
|
|
return $ map unAdapt l
|
|
obj .:|& key = do
|
|
l <- obj .:|? key .!= []
|
|
return $ map unAdapt l
|
|
|
|
encodeAudience :: UriMode u => Audience u -> Series
|
|
encodeAudience (Audience to bto cc bcc aud nons)
|
|
= "to" .=% to
|
|
<> "bto" .=% bto
|
|
<> "cc" .=% cc
|
|
<> "bcc" .=% bcc
|
|
<> "audience" .=% aud
|
|
<> "nonActors" .=% nons
|
|
|
|
data Note u = Note
|
|
{ noteId :: Maybe LocalURI
|
|
, noteAttrib :: LocalURI
|
|
, noteAudience :: Audience u
|
|
, noteReplyTo :: Maybe (ObjURI u)
|
|
, noteContext :: Maybe (ObjURI u)
|
|
, notePublished :: Maybe UTCTime
|
|
, noteSource :: Text
|
|
, noteContent :: Text
|
|
}
|
|
|
|
withAuthorityT a m = do
|
|
(a', v) <- m
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityO a m = do
|
|
ObjURI a' v <- m
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityS a m = do
|
|
SubURI a' v <- m
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityP a m = do
|
|
PageURI a' v <- m
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityD a m = do
|
|
Doc a' v <- m
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityMaybeT a m = do
|
|
mu <- m
|
|
for mu $ \ (a', v) ->
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityMaybeO a m = do
|
|
mu <- m
|
|
for mu $ \ (ObjURI a' v) ->
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityMaybeS a m = do
|
|
mu <- m
|
|
for mu $ \ (SubURI a' v) ->
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
withAuthorityMaybeP a m = do
|
|
mu <- m
|
|
for mu $ \ (PageURI a' v) ->
|
|
if a == a'
|
|
then return v
|
|
else fail "URI authority mismatch"
|
|
|
|
instance ActivityPub Note where
|
|
jsonldContext _ = [as2Context]
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Note" :: Text)) $
|
|
fail "type isn't Note"
|
|
|
|
mediaType <- o .: "mediaType"
|
|
unless (mediaType == ("text/html" :: Text)) $
|
|
fail "mediaType isn't HTML"
|
|
|
|
source <- o .: "source"
|
|
sourceType <- source .: "mediaType"
|
|
unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
|
|
fail "source mediaType isn't Pandoc Markdown"
|
|
|
|
ObjURI a attrib <- o .: "attributedTo"
|
|
fmap (a,) $
|
|
Note
|
|
<$> withAuthorityMaybeO a (o .:? "id")
|
|
<*> pure attrib
|
|
<*> parseAudience o
|
|
<*> o .:? "inReplyTo"
|
|
<*> o .:? "context"
|
|
<*> o .:? "published"
|
|
<*> source .: "content"
|
|
<*> (sanitizeBalance <$> o .: "content")
|
|
toSeries authority (Note mid attrib aud mreply mcontext mpublished src content)
|
|
= "type" .= ("Note" :: Text)
|
|
<> "id" .=? (ObjURI authority <$> mid)
|
|
<> "attributedTo" .= ObjURI authority attrib
|
|
<> encodeAudience aud
|
|
<> "inReplyTo" .=? mreply
|
|
<> "context" .=? mcontext
|
|
<> "published" .=? mpublished
|
|
<> "source" .= object
|
|
[ "content" .= src
|
|
, "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
|
|
]
|
|
<> "content" .= content
|
|
<> "mediaType" .= ("text/html" :: Text)
|
|
|
|
data RelationshipProperty = RelDependsOn deriving Eq
|
|
|
|
instance FromJSON RelationshipProperty where
|
|
parseJSON = withText "RelationshipProperty" parse
|
|
where
|
|
parse t
|
|
| t == "dependsOn" = pure RelDependsOn
|
|
| otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
|
|
|
|
instance ToJSON RelationshipProperty where
|
|
toJSON = error "toJSON RelationshipProperty"
|
|
toEncoding at =
|
|
toEncoding $ case at of
|
|
RelDependsOn -> "dependsOn" :: Text
|
|
|
|
data Relationship u = Relationship
|
|
{ relationshipId :: Maybe (ObjURI u)
|
|
, relationshipExtraTypes :: [Text]
|
|
, relationshipSubject :: ObjURI u
|
|
, relationshipProperty :: Either RelationshipProperty Text
|
|
, relationshipObject :: ObjURI u
|
|
, relationshipAttributedTo :: LocalURI
|
|
, relationshipPublished :: Maybe UTCTime
|
|
, relationshipUpdated :: Maybe UTCTime
|
|
}
|
|
|
|
instance ActivityPub Relationship where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
typs <- o .: "type"
|
|
unless (("Relationship" :: Text) `elem` typs) $
|
|
fail "type isn't Relationship"
|
|
|
|
ObjURI a attributedTo <- o .: "attributedTo"
|
|
|
|
fmap (a,) $
|
|
Relationship
|
|
<$> o .:? "id"
|
|
<*> pure (delete "Relationship" typs)
|
|
<*> o .: "subject"
|
|
<*> o .:+ "relationship"
|
|
<*> o .: "object"
|
|
<*> pure attributedTo
|
|
<*> o .:? "published"
|
|
<*> o .:? "updated"
|
|
|
|
toSeries authority
|
|
(Relationship id_ typs subject property object attributedTo published
|
|
updated)
|
|
= "id" .=? id_
|
|
<> "type" .= ("Relationship" : typs)
|
|
<> "subject" .= subject
|
|
<> "relationship" .=+ property
|
|
<> "object" .= object
|
|
<> "attributedTo" .= ObjURI authority attributedTo
|
|
<> "published" .=? published
|
|
<> "updated" .=? updated
|
|
|
|
data TicketDependency u = TicketDependency
|
|
{ ticketDepId :: Maybe (ObjURI u)
|
|
, ticketDepParent :: ObjURI u
|
|
, ticketDepChild :: ObjURI u
|
|
, ticketDepAttributedTo :: LocalURI
|
|
, ticketDepPublished :: Maybe UTCTime
|
|
, ticketDepUpdated :: Maybe UTCTime
|
|
}
|
|
|
|
instance ActivityPub TicketDependency where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
(a, rel) <- parseObject o
|
|
unless ("TicketDependency" `elem` relationshipExtraTypes rel) $
|
|
fail "type isn't TicketDependency"
|
|
|
|
unless (relationshipProperty rel == Left RelDependsOn) $
|
|
fail "relationship isn't dependsOn"
|
|
|
|
return (a, rel2td rel)
|
|
where
|
|
rel2td rel = TicketDependency
|
|
{ ticketDepId = relationshipId rel
|
|
, ticketDepParent = relationshipSubject rel
|
|
, ticketDepChild = relationshipObject rel
|
|
, ticketDepAttributedTo = relationshipAttributedTo rel
|
|
, ticketDepPublished = relationshipPublished rel
|
|
, ticketDepUpdated = relationshipUpdated rel
|
|
}
|
|
|
|
toSeries a = toSeries a . td2rel
|
|
where
|
|
td2rel td = Relationship
|
|
{ relationshipId = ticketDepId td
|
|
, relationshipExtraTypes = ["TicketDependency"]
|
|
, relationshipSubject = ticketDepParent td
|
|
, relationshipProperty = Left RelDependsOn
|
|
, relationshipObject = ticketDepChild td
|
|
, relationshipAttributedTo = ticketDepAttributedTo td
|
|
, relationshipPublished = ticketDepPublished td
|
|
, relationshipUpdated = ticketDepUpdated td
|
|
}
|
|
|
|
data PatchLocal = PatchLocal
|
|
{ patchId :: LocalURI
|
|
, patchContext :: LocalURI
|
|
}
|
|
|
|
parsePatchLocal
|
|
:: UriMode u => Object -> Parser (Maybe (Authority u, PatchLocal))
|
|
parsePatchLocal o = do
|
|
mid <- o .:? "id"
|
|
case mid of
|
|
Nothing -> do
|
|
verifyNothing "context"
|
|
return Nothing
|
|
Just (ObjURI a id_) ->
|
|
fmap (Just . (a,)) $
|
|
PatchLocal
|
|
<$> pure id_
|
|
<*> withAuthorityO a (o .: "context")
|
|
where
|
|
verifyNothing t =
|
|
if t `M.member` o
|
|
then fail $ T.unpack t ++ " field found, expected none"
|
|
else return ()
|
|
|
|
encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series
|
|
encodePatchLocal a (PatchLocal id_ context)
|
|
= "id" .= ObjURI a id_
|
|
<> "context" .= ObjURI a context
|
|
|
|
data Patch u = Patch
|
|
{ patchLocal :: Maybe (Authority u, PatchLocal)
|
|
, patchAttributedTo :: LocalURI
|
|
, patchPublished :: Maybe UTCTime
|
|
, patchType :: PatchMediaType
|
|
, patchContent :: Text
|
|
}
|
|
|
|
instance ActivityPub Patch where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Patch" :: Text)) $
|
|
fail "type isn't Patch"
|
|
|
|
ObjURI a attrib <- o .: "attributedTo"
|
|
|
|
fmap (a,) $
|
|
Patch
|
|
<$> parsePatchLocal o
|
|
<*> pure attrib
|
|
<*> o .:? "published"
|
|
<*> o .: "mediaType"
|
|
<*> o .: "content"
|
|
|
|
toSeries a (Patch local attrib published typ content)
|
|
= maybe mempty (uncurry encodePatchLocal) local
|
|
<> "type" .= ("Patch" :: Text)
|
|
<> "attributedTo" .= ObjURI a attrib
|
|
<> "published" .=? published
|
|
<> "mediaType" .= typ
|
|
<> "content" .= content
|
|
|
|
data BundleLocal = BundleLocal
|
|
{ bundleId :: LocalURI
|
|
, bundleContext :: LocalURI
|
|
, bundlePrevVersions :: [LocalURI]
|
|
, bundleCurrentVersion :: Maybe LocalURI
|
|
}
|
|
|
|
parseBundleLocal
|
|
:: UriMode u => Object -> Parser (Maybe (Authority u, BundleLocal))
|
|
parseBundleLocal o = do
|
|
mid <- o .:? "id"
|
|
case mid of
|
|
Nothing -> do
|
|
verifyNothing "context"
|
|
verifyNothing "previousVersions"
|
|
verifyNothing "currentVersion"
|
|
return Nothing
|
|
Just (ObjURI a id_) ->
|
|
fmap (Just . (a,)) $
|
|
BundleLocal
|
|
<$> pure id_
|
|
<*> withAuthorityO a (o .: "context")
|
|
<*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= [])
|
|
<*> withAuthorityMaybeO a (o .:? "currentVersion")
|
|
where
|
|
verifyNothing t =
|
|
if t `M.member` o
|
|
then fail $ T.unpack t ++ " field found, expected none"
|
|
else return ()
|
|
|
|
encodeBundleLocal :: UriMode u => Authority u -> BundleLocal -> Series
|
|
encodeBundleLocal a (BundleLocal id_ context versions mcurrent)
|
|
= "id" .= ObjURI a id_
|
|
<> "context" .= ObjURI a context
|
|
<> "previousVersions" .= map (ObjURI a) versions
|
|
<> "currentVersion" .=? (ObjURI a <$> mcurrent)
|
|
|
|
data Bundle u
|
|
= BundleHosted (Maybe BundleLocal) (NonEmpty LocalURI)
|
|
| BundleOffer (Maybe (Authority u, BundleLocal)) (NonEmpty (Patch u))
|
|
|
|
instance ActivityPub Bundle where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("OrderedCollection" :: Text)) $
|
|
fail "type isn't OrderedCollection"
|
|
|
|
mlocal <- parseBundleLocal o
|
|
mtotal <- o .:? "totalItems"
|
|
|
|
items <- toEither <$> o .: "orderedItems" <|> o .: "items"
|
|
case items of
|
|
Left (ObjURI h lu :| us) -> do
|
|
for_ mlocal $ \ (h', _) ->
|
|
unless (h == h') $
|
|
fail "Patches in bundle not on the same host as bundle"
|
|
unless (all (== h) $ map objUriAuthority us) $
|
|
fail "Patches in bundle on different hosts"
|
|
for_ mtotal $ \ total ->
|
|
unless (length us + 1 == total) $
|
|
fail "Incorrect totalItems"
|
|
return (h, BundleHosted (snd <$> mlocal) $ lu :| map objUriLocal us)
|
|
Right (Doc h p :| ps) -> do
|
|
unless (all (== h) $ map docAuthority ps) $
|
|
fail "Patches in bundle have different authors"
|
|
for_ mtotal $ \ total ->
|
|
unless (length ps + 1 == total) $
|
|
fail "Incorrect totalItems"
|
|
return (h, BundleOffer mlocal $ p :| map docValue ps)
|
|
|
|
toSeries hBundle (BundleHosted mlocal lus)
|
|
= maybe mempty (encodeBundleLocal hBundle) mlocal
|
|
<> "type" .= ("OrderedCollection" :: Text)
|
|
<> "totalItems" .= length lus
|
|
<> "orderedItems" .= NE.map (ObjURI hBundle) lus
|
|
toSeries hAttrib (BundleOffer mlocal patches)
|
|
= maybe mempty (uncurry encodeBundleLocal) mlocal
|
|
<> "type" .= ("OrderedCollection" :: Text)
|
|
<> "totalItems" .= length patches
|
|
<> "orderedItems" .= NE.map (Doc hAttrib) patches
|
|
|
|
data TicketLocal = TicketLocal
|
|
{ ticketId :: LocalURI
|
|
, ticketReplies :: LocalURI
|
|
, ticketParticipants :: LocalURI
|
|
, ticketTeam :: Maybe LocalURI
|
|
, ticketEvents :: LocalURI
|
|
, ticketDeps :: LocalURI
|
|
, ticketReverseDeps :: LocalURI
|
|
}
|
|
|
|
parseTicketLocal :: UriMode u => Object -> Parser (Maybe (Authority u, TicketLocal))
|
|
parseTicketLocal o = do
|
|
mid <- o .:? "id"
|
|
case mid of
|
|
Nothing -> do
|
|
verifyNothing "replies"
|
|
verifyNothing "participants"
|
|
verifyNothing "followers"
|
|
verifyNothing "team"
|
|
verifyNothing "history"
|
|
verifyNothing "dependencies"
|
|
verifyNothing "dependants"
|
|
return Nothing
|
|
Just (ObjURI a id_) ->
|
|
fmap (Just . (a,)) $
|
|
TicketLocal
|
|
<$> pure id_
|
|
<*> withAuthorityO a (o .: "replies")
|
|
<*> withAuthorityO a (o .: "participants" <|> o .: "followers")
|
|
<*> withAuthorityMaybeO a (o .:? "team")
|
|
<*> withAuthorityO a (o .: "history")
|
|
<*> withAuthorityO a (o .: "dependencies")
|
|
<*> withAuthorityO a (o .: "dependants")
|
|
where
|
|
verifyNothing t =
|
|
if t `M.member` o
|
|
then fail $ T.unpack t ++ " field found, expected none"
|
|
else return ()
|
|
|
|
encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series
|
|
encodeTicketLocal
|
|
a (TicketLocal id_ replies followers team events deps rdeps)
|
|
= "id" .= ObjURI a id_
|
|
<> "replies" .= ObjURI a replies
|
|
<> "followers" .= ObjURI a followers
|
|
<> "team" .=? (ObjURI a <$> team)
|
|
<> "history" .= ObjURI a events
|
|
<> "dependencies" .= ObjURI a deps
|
|
<> "dependants" .= ObjURI a rdeps
|
|
|
|
data MergeRequest u = MergeRequest
|
|
{ mrOrigin :: Maybe (Either (ObjURI u) (Authority u, Branch u))
|
|
, mrTarget :: Either LocalURI (Branch u)
|
|
, mrBundle :: Maybe (Either (ObjURI u) (Authority u, Bundle u))
|
|
}
|
|
|
|
instance ActivityPub MergeRequest where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Offer" :: Text)) $
|
|
fail "type isn't Offer"
|
|
|
|
target <- o .:+ "target"
|
|
let (a, target') =
|
|
case target of
|
|
Left (ObjURI h lu) -> (h, Left lu)
|
|
Right (Doc h branch) -> (h, Right branch)
|
|
|
|
fmap (a,) $
|
|
MergeRequest
|
|
<$> (fmap (second fromDoc) <$> o .:+? "origin")
|
|
<*> pure target'
|
|
<*> (fmap (second fromDoc) <$> o .:+? "object")
|
|
where
|
|
fromDoc (Doc h v) = (h, v)
|
|
|
|
toSeries h (MergeRequest morigin target bundle)
|
|
= "type" .= ("Offer" :: Text)
|
|
<> "origin" .=+? fmap (second $ uncurry Doc) morigin
|
|
<> "target" .=+ bimap (ObjURI h) (Doc h) target
|
|
<> "object" .=+? fmap (second $ uncurry Doc) bundle
|
|
|
|
data Ticket u = Ticket
|
|
{ ticketLocal :: Maybe (Authority u, TicketLocal)
|
|
, ticketAttributedTo :: LocalURI
|
|
, ticketPublished :: Maybe UTCTime
|
|
, ticketUpdated :: Maybe UTCTime
|
|
, ticketContext :: Maybe (ObjURI u)
|
|
-- , ticketName :: Maybe Text
|
|
, ticketSummary :: Escaped
|
|
, ticketContent :: HTML
|
|
, ticketSource :: PandocMarkdown
|
|
, ticketAssignedTo :: Maybe (ObjURI u)
|
|
, ticketResolved :: Maybe (Maybe (ObjURI u), Maybe UTCTime)
|
|
, ticketAttachment :: Maybe (Authority u, MergeRequest u)
|
|
}
|
|
|
|
instance ActivityPub Ticket where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Ticket" :: Text)) $
|
|
fail "type isn't Ticket"
|
|
|
|
mediaType <- o .: "mediaType"
|
|
unless (mediaType == ("text/html" :: Text)) $
|
|
fail "mediaType isn't HTML"
|
|
|
|
source <- o .: "source"
|
|
sourceType <- source .: "mediaType"
|
|
unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
|
|
fail "source mediaType isn't Pandoc Markdown"
|
|
|
|
ObjURI a attributedTo <- o .: "attributedTo"
|
|
|
|
mresolved <- do
|
|
is <- o .:? "isResolved" .!= False
|
|
if is
|
|
then do
|
|
at <- o .:? "resolved"
|
|
by <- o .:? "resolvedBy"
|
|
return $ Just (by, at)
|
|
else do
|
|
verifyNothing "resolved"
|
|
verifyNothing "resolvedBy"
|
|
return Nothing
|
|
|
|
fmap (a,) $
|
|
Ticket
|
|
<$> parseTicketLocal o
|
|
<*> pure attributedTo
|
|
<*> o .:? "published"
|
|
<*> o .:? "updated"
|
|
<*> o .:? "context"
|
|
-- <*> o .:? "name"
|
|
<*> o .: "summary"
|
|
<*> o .: "content"
|
|
<*> source .: "content"
|
|
<*> o .:? "assignedTo"
|
|
<*> pure mresolved
|
|
<*> (traverse parseObject =<< o .:? "attachment")
|
|
where
|
|
verifyNothing t =
|
|
if t `M.member` o
|
|
then fail $ T.unpack t ++ " field found, expected none"
|
|
else return ()
|
|
|
|
toSeries authority
|
|
(Ticket local attributedTo published updated context {-name-}
|
|
summary content source assignedTo mresolved mmr)
|
|
|
|
= maybe mempty (uncurry encodeTicketLocal) local
|
|
<> "type" .= ("Ticket" :: Text)
|
|
<> "attributedTo" .= ObjURI authority attributedTo
|
|
<> "published" .=? published
|
|
<> "updated" .=? updated
|
|
<> "context" .=? context
|
|
-- <> "name" .=? name
|
|
<> "summary" .= summary
|
|
<> "content" .= content
|
|
<> "mediaType" .= ("text/html" :: Text)
|
|
<> "source" .= object
|
|
[ "content" .= source
|
|
, "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
|
|
]
|
|
<> "assignedTo" .=? assignedTo
|
|
<> maybe
|
|
("isResolved" .= False)
|
|
(\ (mby, mat)
|
|
-> "isResolved" .= True
|
|
<> "resolvedBy" .=? mby
|
|
<> "resolved" .=? mat
|
|
)
|
|
mresolved
|
|
<> maybe
|
|
mempty
|
|
(\ (h, mr) -> "attachment" `pair` pairs (toSeries h mr))
|
|
mmr
|
|
|
|
data Author = Author
|
|
{ authorName :: Text
|
|
, authorEmail :: EmailAddress
|
|
}
|
|
|
|
instance FromJSON Author where
|
|
parseJSON = withObject "Author" $ \ o ->
|
|
Author
|
|
<$> o .: "name"
|
|
<*> (parseMailto =<< o .: "mbox")
|
|
where
|
|
parseMailto =
|
|
either fail return .
|
|
A.parseOnly (A.string "mailto:" *> E.addrSpec <* A.endOfInput) .
|
|
encodeUtf8
|
|
|
|
instance ToJSON Author where
|
|
toJSON = error "toJSON Author"
|
|
toEncoding (Author name email) =
|
|
pairs
|
|
$ "name" .= name
|
|
<> "mbox" .= ("mailto:" <> decodeUtf8 (E.toByteString email))
|
|
|
|
newtype Hash = Hash ByteString
|
|
|
|
instance FromJSON Hash where
|
|
parseJSON = withText "Hash" $ \ t ->
|
|
let b = encodeUtf8 t
|
|
in if not (BC.null b) && BC.all isHexDigit b
|
|
then return $ Hash b
|
|
else fail "Hash should be a non-empty hex string"
|
|
|
|
instance ToJSON Hash where
|
|
toJSON (Hash b) = toJSON $ decodeUtf8 b
|
|
toEncoding (Hash b) = toEncoding $ decodeUtf8 b
|
|
|
|
data Commit u = Commit
|
|
{ commitId :: LocalURI
|
|
, commitRepository :: LocalURI
|
|
, commitAuthor :: Either Author (ObjURI u)
|
|
, commitCommitter :: Maybe (Either Author (ObjURI u))
|
|
, commitTitle :: Text
|
|
, commitHash :: Hash
|
|
, commitDescription :: Maybe Text
|
|
, commitWritten :: UTCTime
|
|
, commitCommitted :: Maybe UTCTime
|
|
}
|
|
|
|
instance ActivityPub Commit where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Commit" :: Text)) $
|
|
fail "type isn't Commit"
|
|
|
|
mdesc <- o .:? "description"
|
|
mdescContent <- for mdesc $ \ desc -> do
|
|
descType <- desc .: "mediaType"
|
|
unless (descType == ("text/plain" :: Text)) $
|
|
fail "description mediaType isn't \"text/plain\""
|
|
desc .: "content"
|
|
|
|
ObjURI a id_ <- o .: "id"
|
|
fmap (a,) $
|
|
Commit id_
|
|
<$> withAuthorityO a (o .: "context")
|
|
<*> o .:+ "attributedTo"
|
|
<*> o .:+? "committedBy"
|
|
<*> o .: "name"
|
|
<*> o .: "hash"
|
|
<*> pure mdescContent
|
|
<*> o .: "created"
|
|
<*> o .:? "committed"
|
|
|
|
toSeries authority
|
|
(Commit id_ repo author committer title hash mdesc written mcommitted)
|
|
= "id" .= ObjURI authority id_
|
|
<> "type" .= ("Commit" :: Text)
|
|
<> "context" .= ObjURI authority repo
|
|
<> "attributedTo" .=+ author
|
|
<> "committedBy" .=+? committer
|
|
<> "name" .= title
|
|
<> "hash" .= hash
|
|
<> maybe
|
|
mempty
|
|
(\ desc -> "description" .= object
|
|
[ "content" .= desc
|
|
, "mediaType" .= ("text/plain" :: Text)
|
|
]
|
|
)
|
|
mdesc
|
|
<> "created" .= written
|
|
<> "committed" .=? mcommitted
|
|
|
|
data Branch u = Branch
|
|
{ branchName :: Text
|
|
, branchRef :: Text
|
|
, branchRepo :: LocalURI
|
|
}
|
|
|
|
instance ActivityPub Branch where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Branch" :: Text)) $
|
|
fail "type isn't Branch"
|
|
|
|
ObjURI a repo <- o .: "context"
|
|
fmap (a,) $
|
|
Branch
|
|
<$> o .: "name"
|
|
<*> o .: "ref"
|
|
<*> pure repo
|
|
|
|
toSeries authority (Branch name ref repo)
|
|
= "type" .= ("Branch" :: Text)
|
|
<> "name" .= name
|
|
<> "ref" .= ref
|
|
<> "context" .= ObjURI authority repo
|
|
|
|
data Role = RoleAdmin deriving Eq
|
|
|
|
instance FromJSON Role where
|
|
parseJSON = withText "Role" parse
|
|
where
|
|
parse "https://forgefed.org/ns#admin" = pure RoleAdmin
|
|
parse t = fail $ "Unknown role: " ++ T.unpack t
|
|
|
|
instance ToJSON Role where
|
|
toJSON = error "toJSON Role"
|
|
toEncoding r =
|
|
toEncoding $ case r of
|
|
RoleAdmin -> "https://forgefed.org/ns#admin" :: Text
|
|
|
|
data Accept u = Accept
|
|
{ acceptObject :: ObjURI u
|
|
, acceptResult :: Maybe LocalURI
|
|
}
|
|
|
|
parseAccept :: UriMode u => Authority u -> Object -> Parser (Accept u)
|
|
parseAccept a o =
|
|
Accept
|
|
<$> o .: "object"
|
|
<*> withAuthorityMaybeO a (o .:? "result")
|
|
|
|
encodeAccept :: UriMode u => Authority u -> Accept u -> Series
|
|
encodeAccept authority (Accept obj mresult)
|
|
= "object" .= obj
|
|
<> "result" .=? (ObjURI authority <$> mresult)
|
|
|
|
data AddObject u = AddBundle (NonEmpty (Patch u))
|
|
|
|
instance ActivityPub AddObject where
|
|
jsonldContext = error "jsonldContext AddObject"
|
|
parseObject o = do
|
|
(h, b) <- parseObject o
|
|
patches <-
|
|
case b of
|
|
BundleHosted _ _ -> fail "Patches specified as URIs"
|
|
BundleOffer mlocal pts -> do
|
|
for_ mlocal $ \ _ -> fail "Bundle 'id' specified"
|
|
return pts
|
|
return (h, AddBundle patches)
|
|
toSeries h (AddBundle ps) = toSeries h $ BundleOffer Nothing ps
|
|
|
|
data Add u = Add
|
|
{ addObject :: Either (ObjURI u) (AddObject u)
|
|
, addTarget :: ObjURI u
|
|
}
|
|
|
|
parseAdd :: UriMode u => Object -> Authority u -> Parser (Add u)
|
|
parseAdd o h = Add
|
|
<$> (bitraverse pure (withAuthorityD h . pure) =<<
|
|
toEither <$> o .: "object"
|
|
)
|
|
<*> o .: "target"
|
|
|
|
encodeAdd :: UriMode u => Authority u -> Add u -> Series
|
|
encodeAdd h (Add obj target)
|
|
= case obj of
|
|
Left u -> "object" .= u
|
|
Right o -> "object" `pair` pairs (toSeries h o)
|
|
<> "target" .= target
|
|
|
|
data Apply u = Apply
|
|
{ applyObject :: ObjURI u
|
|
, applyTarget :: Either (ObjURI u) (Authority u, Branch u)
|
|
}
|
|
|
|
parseApply :: UriMode u => Object -> Parser (Apply u)
|
|
parseApply o =
|
|
Apply
|
|
<$> o .: "object"
|
|
<*> (second fromDoc <$> o .:+ "target")
|
|
where
|
|
fromDoc (Doc h v) = (h, v)
|
|
|
|
encodeApply :: UriMode u => Apply u -> Series
|
|
encodeApply (Apply obj target)
|
|
= "object" .= obj
|
|
<> "target" .=+ second (uncurry Doc) target
|
|
|
|
data CreateObject u
|
|
= CreateNote (Authority u) (Note u)
|
|
| CreateTicket (Authority u) (Ticket u)
|
|
| CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u))
|
|
| CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
|
|
| CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
|
|
|
|
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
|
|
parseCreateObject o
|
|
= uncurry CreateNote <$> parseObject o
|
|
<|> uncurry CreateTicket <$> parseObject o
|
|
<|> do d <- parseActorDetail o
|
|
unless (actorType d == ActorTypeTicketTracker) $
|
|
fail "type isn't TicketTracker"
|
|
ml <- parseActorLocal o
|
|
return $ CreateTicketTracker d ml
|
|
<|> do d <- parseActorDetail o
|
|
unless (actorType d == ActorTypeRepo) $
|
|
fail "type isn't Repository"
|
|
vcs <- o .: "versionControlSystem"
|
|
ml <- parseActorLocal o
|
|
return $ CreateRepository d vcs ml
|
|
<|> do d <- parseActorDetail o
|
|
unless (actorType d == ActorTypePatchTracker) $
|
|
fail "type isn't PatchTracker"
|
|
repos <- o .:*+ "tracksPatchesFor"
|
|
ml <- parseActorLocal o
|
|
return $ CreatePatchTracker d repos ml
|
|
|
|
encodeCreateObject :: UriMode u => CreateObject u -> Series
|
|
encodeCreateObject (CreateNote h note) = toSeries h note
|
|
encodeCreateObject (CreateTicket h ticket) = toSeries h ticket
|
|
encodeCreateObject (CreateTicketTracker d ml) =
|
|
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
|
encodeCreateObject (CreateRepository d vcs ml)
|
|
= encodeActorDetail d
|
|
<> "versionControlSystem" .= vcs
|
|
<> maybe mempty (uncurry encodeActorLocal) ml
|
|
encodeCreateObject (CreatePatchTracker d repos ml)
|
|
= encodeActorDetail d
|
|
<> "tracksPatchesFor" .=*+ repos
|
|
<> maybe mempty (uncurry encodeActorLocal) ml
|
|
|
|
data Create u = Create
|
|
{ createObject :: CreateObject u
|
|
, createTarget :: Maybe (ObjURI u)
|
|
}
|
|
|
|
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
|
|
parseCreate o a luActor = do
|
|
obj <- parseCreateObject =<< o .: "object"
|
|
case obj of
|
|
CreateNote h note ->
|
|
unless (a == h && luActor == noteAttrib note) $
|
|
fail "Create actor != note attrib"
|
|
CreateTicket h ticket ->
|
|
unless (a == h && luActor == ticketAttributedTo ticket) $
|
|
fail "Create actor != note attrib"
|
|
CreateTicketTracker _ _ -> return ()
|
|
CreateRepository _ _ _ -> return ()
|
|
CreatePatchTracker _ _ _ -> return ()
|
|
Create obj <$> o .:? "target"
|
|
|
|
encodeCreate :: UriMode u => Create u -> Series
|
|
encodeCreate (Create obj target)
|
|
= "object" `pair` pairs (encodeCreateObject obj)
|
|
<> "target" .=? target
|
|
|
|
data Follow u = Follow
|
|
{ followObject :: ObjURI u
|
|
, followContext :: Maybe (ObjURI u)
|
|
, followHide :: Bool
|
|
}
|
|
|
|
parseFollow :: UriMode u => Object -> Parser (Follow u)
|
|
parseFollow o =
|
|
Follow
|
|
<$> o .: "object"
|
|
<*> o .:? "context"
|
|
<*> o .:? "hide" .!= False
|
|
|
|
encodeFollow :: UriMode u => Follow u -> Series
|
|
encodeFollow (Follow obj mcontext hide)
|
|
= "object" .= obj
|
|
<> "context" .=? mcontext
|
|
<> "hide" .= hide
|
|
|
|
data Grant u = Grant
|
|
{ grantObject :: Either Role (ObjURI u)
|
|
, grantContext :: ObjURI u
|
|
, grantTarget :: ObjURI u
|
|
}
|
|
|
|
parseGrant :: UriMode u => Object -> Parser (Grant u)
|
|
parseGrant o =
|
|
Grant
|
|
<$> o .:+ "object"
|
|
<*> o .: "context"
|
|
<*> o .: "target"
|
|
|
|
encodeGrant :: UriMode u => Grant u -> Series
|
|
encodeGrant (Grant obj context target)
|
|
= "object" .=+ obj
|
|
<> "context" .= context
|
|
<> "target" .= target
|
|
|
|
data Invite u = Invite
|
|
{ inviteInstrument :: Either Role (ObjURI u)
|
|
, inviteObject :: ObjURI u
|
|
, inviteTarget :: ObjURI u
|
|
}
|
|
|
|
parseInvite :: UriMode u => Object -> Parser (Invite u)
|
|
parseInvite o =
|
|
Invite
|
|
<$> o .:+ "instrument"
|
|
<*> o .: "object"
|
|
<*> o .: "target"
|
|
|
|
encodeInvite :: UriMode u => Invite u -> Series
|
|
encodeInvite (Invite obj context target)
|
|
= "object" .=+ obj
|
|
<> "context" .= context
|
|
<> "target" .= target
|
|
|
|
data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u)
|
|
|
|
instance ActivityPub OfferObject where
|
|
jsonldContext = error "jsonldContext OfferObject"
|
|
parseObject o
|
|
= second OfferTicket <$> parseObject o
|
|
<|> second OfferDep <$> parseObject o
|
|
toSeries h (OfferTicket t) = toSeries h t
|
|
toSeries h (OfferDep d) = toSeries h d
|
|
|
|
data Offer u = Offer
|
|
{ offerObject :: OfferObject u
|
|
, offerTarget :: ObjURI u
|
|
}
|
|
|
|
parseOffer :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Offer u)
|
|
parseOffer o a luActor = do
|
|
obj <- withAuthorityT a $ parseObject =<< o .: "object"
|
|
target@(ObjURI hTarget luTarget) <- o .: "target"
|
|
case obj of
|
|
OfferTicket ticket -> do
|
|
unless (luActor == ticketAttributedTo ticket) $
|
|
fail "Offer actor != Ticket attrib"
|
|
for_ (ticketContext ticket) $ \ (ObjURI hContext luContext) -> do
|
|
unless (hTarget == hContext) $
|
|
fail "Offer target host != Ticket context host"
|
|
unless (luTarget == luContext) $
|
|
fail "Offer target != Ticket context"
|
|
OfferDep dep -> do
|
|
unless (luActor == ticketDepAttributedTo dep) $
|
|
fail "Offer actor != TicketDependency attrib"
|
|
return $ Offer obj target
|
|
|
|
encodeOffer :: UriMode u => Authority u -> LocalURI -> Offer u -> Series
|
|
encodeOffer authority actor (Offer obj target)
|
|
= "object" `pair` pairs (toSeries authority obj)
|
|
<> "target" .= target
|
|
|
|
data Push u = Push
|
|
{ pushCommitsLast :: NonEmpty (Commit u)
|
|
, pushCommitsFirst :: Maybe (NonEmpty (Commit u))
|
|
, pushCommitsTotal :: Int
|
|
, pushTarget :: LocalURI
|
|
, pushContext :: LocalURI
|
|
, pushHashBefore :: Maybe Text
|
|
, pushHashAfter :: Maybe Text
|
|
}
|
|
|
|
parsePush :: UriMode u => Authority u -> Object -> Parser (Push u)
|
|
parsePush a o = do
|
|
c <- o .: "object"
|
|
Push
|
|
<$> (traverse (withAuthorityT a . parseObject) =<< c .: "items" <|> c .: "orderedItems")
|
|
<*> (traverse (traverse $ withAuthorityT a . parseObject) =<< c .:? "earlyItems")
|
|
<*> c .: "totalItems"
|
|
<*> withAuthorityO a (o .: "target")
|
|
<*> withAuthorityO a (o .: "context")
|
|
<*> o .:? "hashBefore"
|
|
<*> o .:? "hashAfter"
|
|
|
|
encodePush :: UriMode u => Authority u -> Push u -> Series
|
|
encodePush a (Push lateCommits earlyCommits total target context before after)
|
|
= "object" `pair` pairs
|
|
( "type" .= ("OrderedCollection" :: Text)
|
|
<> pair "orderedItems" (objectList lateCommits)
|
|
<> maybe mempty (pair "earlyItems" . objectList) earlyCommits
|
|
<> "totalItems" .= total
|
|
)
|
|
<> "target" .= ObjURI a target
|
|
<> "context" .= ObjURI a context
|
|
<> "hashBefore" .=? before
|
|
<> "hashAfter" .=? after
|
|
where
|
|
objectList items = listEncoding (pairs . toSeries a) (NE.toList items)
|
|
|
|
data Reject u = Reject
|
|
{ rejectObject :: ObjURI u
|
|
}
|
|
|
|
parseReject :: UriMode u => Object -> Parser (Reject u)
|
|
parseReject o = Reject <$> o .: "object"
|
|
|
|
encodeReject :: UriMode u => Reject u -> Series
|
|
encodeReject (Reject obj) = "object" .= obj
|
|
|
|
data Resolve u = Resolve
|
|
{ resolveObject :: ObjURI u
|
|
}
|
|
|
|
parseResolve :: UriMode u => Object -> Parser (Resolve u)
|
|
parseResolve o = Resolve <$> o .: "object"
|
|
|
|
encodeResolve :: UriMode u => Resolve u -> Series
|
|
encodeResolve (Resolve obj) = "object" .= obj
|
|
|
|
data Undo u = Undo
|
|
{ undoObject :: ObjURI u
|
|
}
|
|
|
|
parseUndo :: UriMode u => Authority u -> Object -> Parser (Undo u)
|
|
parseUndo a o = Undo <$> o .: "object"
|
|
|
|
encodeUndo :: UriMode u => Authority u -> Undo u -> Series
|
|
encodeUndo a (Undo obj) = "object" .= obj
|
|
|
|
data SpecificActivity u
|
|
= AcceptActivity (Accept u)
|
|
| AddActivity (Add u)
|
|
| ApplyActivity (Apply u)
|
|
| CreateActivity (Create u)
|
|
| FollowActivity (Follow u)
|
|
| GrantActivity (Grant u)
|
|
| InviteActivity (Invite u)
|
|
| OfferActivity (Offer u)
|
|
| PushActivity (Push u)
|
|
| RejectActivity (Reject u)
|
|
| ResolveActivity (Resolve u)
|
|
| UndoActivity (Undo u)
|
|
|
|
data Action u = Action
|
|
{ actionCapability :: Maybe (ObjURI u)
|
|
, actionSummary :: Maybe HTML
|
|
, actionAudience :: Audience u
|
|
, actionFulfills :: [ObjURI u]
|
|
, actionSpecific :: SpecificActivity u
|
|
}
|
|
|
|
makeActivity :: LocalURI -> LocalURI -> Action u -> Activity u
|
|
makeActivity luId luActor Action{..} = Activity
|
|
{ activityId = Just luId
|
|
, activityActor = luActor
|
|
, activityCapability = actionCapability
|
|
, activitySummary = actionSummary
|
|
, activityAudience = actionAudience
|
|
, activityFulfills = actionFulfills
|
|
, activitySpecific = actionSpecific
|
|
}
|
|
|
|
data Activity u = Activity
|
|
{ activityId :: Maybe LocalURI
|
|
, activityActor :: LocalURI
|
|
, activityCapability :: Maybe (ObjURI u)
|
|
, activitySummary :: Maybe HTML
|
|
, activityAudience :: Audience u
|
|
, activityFulfills :: [ObjURI u]
|
|
, activitySpecific :: SpecificActivity u
|
|
}
|
|
|
|
instance ActivityPub Activity where
|
|
jsonldContext _ = [as2Context, forgeContext]
|
|
parseObject o = do
|
|
ObjURI a actor <- o .: "actor"
|
|
fmap (a,) $
|
|
Activity
|
|
<$> withAuthorityMaybeO a (o .:? "id")
|
|
<*> pure actor
|
|
<*> o .:? "capability"
|
|
<*> o .:? "summary"
|
|
<*> parseAudience o
|
|
<*> o .:? "fulfills" .!= []
|
|
<*> do
|
|
typ <- o .: "type"
|
|
case typ of
|
|
"Accept" -> AcceptActivity <$> parseAccept a o
|
|
"Add" -> AddActivity <$> parseAdd o a
|
|
"Apply" -> ApplyActivity <$> parseApply o
|
|
"Create" -> CreateActivity <$> parseCreate o a actor
|
|
"Follow" -> FollowActivity <$> parseFollow o
|
|
"Grant" -> GrantActivity <$> parseGrant o
|
|
"Invite" -> InviteActivity <$> parseInvite o
|
|
"Offer" -> OfferActivity <$> parseOffer o a actor
|
|
"Push" -> PushActivity <$> parsePush a o
|
|
"Reject" -> RejectActivity <$> parseReject o
|
|
"Resolve" -> ResolveActivity <$> parseResolve o
|
|
"Undo" -> UndoActivity <$> parseUndo a o
|
|
_ ->
|
|
fail $
|
|
"Unrecognized activity type: " ++ T.unpack typ
|
|
toSeries authority (Activity id_ actor mcap summary audience fulfills specific)
|
|
= "type" .= activityType specific
|
|
<> "id" .=? (ObjURI authority <$> id_)
|
|
<> "actor" .= ObjURI authority actor
|
|
<> "capability" .=? mcap
|
|
<> "summary" .=? summary
|
|
<> encodeAudience audience
|
|
<> "fulfills" .=% fulfills
|
|
<> encodeSpecific authority actor specific
|
|
where
|
|
activityType :: SpecificActivity u -> Text
|
|
activityType (AcceptActivity _) = "Accept"
|
|
activityType (AddActivity _) = "Add"
|
|
activityType (ApplyActivity _) = "Apply"
|
|
activityType (CreateActivity _) = "Create"
|
|
activityType (FollowActivity _) = "Follow"
|
|
activityType (GrantActivity _) = "Grant"
|
|
activityType (InviteActivity _) = "Invite"
|
|
activityType (OfferActivity _) = "Offer"
|
|
activityType (PushActivity _) = "Push"
|
|
activityType (RejectActivity _) = "Reject"
|
|
activityType (ResolveActivity _) = "Resolve"
|
|
activityType (UndoActivity _) = "Undo"
|
|
encodeSpecific h _ (AcceptActivity a) = encodeAccept h a
|
|
encodeSpecific h _ (AddActivity a) = encodeAdd h a
|
|
encodeSpecific _ _ (ApplyActivity a) = encodeApply a
|
|
encodeSpecific _ _ (CreateActivity a) = encodeCreate a
|
|
encodeSpecific _ _ (FollowActivity a) = encodeFollow a
|
|
encodeSpecific _ _ (GrantActivity a) = encodeGrant a
|
|
encodeSpecific _ _ (InviteActivity a) = encodeInvite a
|
|
encodeSpecific h u (OfferActivity a) = encodeOffer h u a
|
|
encodeSpecific h _ (PushActivity a) = encodePush h a
|
|
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
|
encodeSpecific _ _ (ResolveActivity a) = encodeResolve a
|
|
encodeSpecific h _ (UndoActivity a) = encodeUndo h a
|
|
|
|
emptyAudience :: Audience u
|
|
emptyAudience = Audience [] [] [] [] [] []
|
|
|
|
emptyActivity :: Activity u
|
|
emptyActivity = Activity
|
|
{ activityId = Nothing
|
|
, activityActor = topLocalURI
|
|
, activityCapability = Nothing
|
|
, activitySummary = Nothing
|
|
, activityAudience = emptyAudience
|
|
, activityFulfills = []
|
|
, activitySpecific =
|
|
RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI
|
|
}
|
|
|
|
typeActivityStreams2 :: ContentType
|
|
typeActivityStreams2 = "application/activity+json"
|
|
|
|
typeActivityStreams2LD :: ContentType
|
|
typeActivityStreams2LD =
|
|
"application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\""
|
|
|
|
hActivityPubActor :: HeaderName
|
|
hActivityPubActor = "ActivityPub-Actor"
|
|
|
|
provideAP :: (Monad m, ToJSON a) => m a -> Writer (Endo [ProvidedRep m]) ()
|
|
provideAP mk =
|
|
-- let enc = toEncoding v
|
|
-- provideRepType typeActivityStreams2 $ return enc
|
|
provideRepType typeActivityStreams2LD $ toEncoding <$> mk
|
|
|
|
provideAP' :: Monad m => m ByteString -> Writer (Endo [ProvidedRep m]) ()
|
|
provideAP' = provideRepType typeActivityStreams2LD
|
|
|
|
data APGetError
|
|
= APGetErrorHTTP HttpException
|
|
| APGetErrorJSON JSONException
|
|
| APGetErrorContentType Text
|
|
deriving Show
|
|
|
|
instance Exception APGetError
|
|
|
|
-- | Perform an HTTP GET request to fetch an ActivityPub object.
|
|
--
|
|
-- * Verify the URI scheme is _https:_ and authority part is present
|
|
-- * Set _Accept_ request header
|
|
-- * Perform the GET request
|
|
-- * Verify the _Content-Type_ response header
|
|
-- * Parse the JSON response body
|
|
httpGetAP
|
|
:: (MonadIO m, UriMode u, FromJSON a)
|
|
=> Manager
|
|
-> Either (ObjURI u) (SubURI u)
|
|
-> m (Either APGetError (Response a))
|
|
httpGetAP manager uri =
|
|
liftIO $
|
|
mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri))
|
|
where
|
|
toURI = either uriFromObjURI uriFromSubURI
|
|
lookup' x = map snd . filter ((== x) . fst)
|
|
mkResult (Left e) = Left $ APGetErrorHTTP e
|
|
mkResult (Right r) =
|
|
case lookup' hContentType $ responseHeaders r of
|
|
[] -> Left $ APGetErrorContentType "No Content-Type"
|
|
[b] -> if b == typeActivityStreams2LD || b == typeActivityStreams2
|
|
then case responseBody r of
|
|
Left e -> Left $ APGetErrorJSON e
|
|
Right v -> Right $ v <$ r
|
|
else Left $ APGetErrorContentType $ "Non-AP Content-Type: " <> decodeUtf8 b
|
|
_ -> Left $ APGetErrorContentType "Multiple Content-Type"
|
|
|
|
data APPostError
|
|
= APPostErrorSig S.HttpSigGenError
|
|
| APPostErrorHTTP HttpException
|
|
deriving Show
|
|
|
|
instance Exception APPostError
|
|
|
|
hActivityPubForwarder :: HeaderName
|
|
hActivityPubForwarder = "ActivityPub-Forwarder"
|
|
|
|
hForwardingSignature :: HeaderName
|
|
hForwardingSignature = "Forwarding-Signature"
|
|
|
|
hForwardedSignature :: HeaderName
|
|
hForwardedSignature = "Forwarded-Signature"
|
|
|
|
-- | Perform an HTTP POST request to submit an ActivityPub object.
|
|
--
|
|
-- * Verify the URI scheme is _https:_ and authority part is present
|
|
-- * Set _Content-Type_ request header
|
|
-- * Set _ActivityPub-Actor_ request header
|
|
-- * Set _Digest_ request header using SHA-256 hash
|
|
-- * If recipient is given, set _ActivityPub-Forwarder_ header and compute
|
|
-- _Forwarding-Signature_ header
|
|
-- * If forwarded signature is given, set set _ActivityPub-Forwarder_ and
|
|
-- _Forwarded-Signature_ headers
|
|
-- * Compute HTTP signature and add _Signature_ request header
|
|
-- * Perform the POST request
|
|
-- * Verify the response status is 2xx
|
|
{-
|
|
httpPostAP
|
|
:: (MonadIO m, UriMode u, ToJSON a)
|
|
=> Manager
|
|
-> NonEmpty HeaderName
|
|
-> S.KeyId
|
|
-> (ByteString -> S.Signature)
|
|
-> Text
|
|
-> a
|
|
-> ObjURI u
|
|
-> Maybe (Either (ObjURI u) ByteString)
|
|
-> m (Either APPostError (Response ()))
|
|
httpPostAP manager headers keyid sign uSender value =
|
|
httpPostAPBytes manager headers keyid sign uSender $ encode value
|
|
-}
|
|
|
|
data ForwardMode u
|
|
= SendNoForward
|
|
| SendAllowForward LocalURI
|
|
| ForwardBy (ObjURI u) ByteString
|
|
|
|
data Envelope u = Envelope
|
|
{ envelopeKey :: RefURI u
|
|
, envelopeSign :: ByteString -> S.Signature
|
|
, envelopeHolder :: Maybe LocalURI
|
|
, envelopeBody :: BL.ByteString
|
|
}
|
|
|
|
data Errand u = Errand
|
|
{ errandKey :: RefURI u
|
|
, errandSign :: ByteString -> S.Signature
|
|
, errandHolder :: Bool
|
|
, errandFwder :: LocalURI
|
|
, errandBody :: BL.ByteString
|
|
, errandProof :: ByteString
|
|
}
|
|
|
|
-- | Like 'httpPostAP', except it takes the object as a raw lazy
|
|
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
|
|
httpPostAPBytes
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-> NonEmpty HeaderName
|
|
-> RefURI u
|
|
-> (ByteString -> S.Signature)
|
|
-> Maybe LocalURI
|
|
-> BL.ByteString
|
|
-> ForwardMode u
|
|
-> ObjURI u
|
|
-> m (Either APPostError (Response ()))
|
|
httpPostAPBytes manager headers ruKey@(RefURI hKey _) sign mluHolder body fwd uInbox@(ObjURI hInbox _) =
|
|
liftIO $ runExceptT $ do
|
|
req <- requestFromURI $ uriFromObjURI uInbox
|
|
let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
|
req' =
|
|
setRequestCheckStatus $
|
|
consHeader hContentType typeActivityStreams2LD $
|
|
maybe id (consHeader hActivityPubActor . TE.encodeUtf8 . renderObjURI . ObjURI hKey) mluHolder $
|
|
consHeader hDigest digest $
|
|
req { method = "POST"
|
|
, requestBody = RequestBodyLBS body
|
|
}
|
|
keyid = S.KeyId $ TE.encodeUtf8 $ renderRefURI ruKey
|
|
now <- lift getCurrentTime
|
|
req'' <- except $ first APPostErrorSig $ signRequest headers Nothing keyid sign now req'
|
|
req''' <-
|
|
case fwd of
|
|
SendNoForward -> return req''
|
|
SendAllowForward luRecip ->
|
|
except $ first APPostErrorSig $
|
|
signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign now $
|
|
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI $ ObjURI hInbox luRecip) req''
|
|
ForwardBy uSender sig ->
|
|
return $
|
|
consHeader hForwardedSignature sig $
|
|
consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uSender)
|
|
req''
|
|
tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
|
|
where
|
|
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
|
tryExceptT adapt action = ExceptT $ first adapt <$> try action
|
|
|
|
sending
|
|
:: UriMode u
|
|
=> LocalRefURI
|
|
-> (ByteString -> S.Signature)
|
|
-> Bool
|
|
-> ObjURI u
|
|
-> LocalURI
|
|
-> Action u
|
|
-> Envelope u
|
|
sending lruKey sign holder uActor@(ObjURI hActor luActor) luId action =
|
|
Envelope
|
|
{ envelopeKey = RefURI hActor lruKey
|
|
, envelopeSign = sign
|
|
, envelopeHolder = guard holder >> Just luActor
|
|
, envelopeBody = encode $ Doc hActor $ makeActivity luId luActor action
|
|
}
|
|
|
|
retrying
|
|
:: RefURI u
|
|
-> (ByteString -> S.Signature)
|
|
-> Maybe LocalURI
|
|
-> BL.ByteString
|
|
-> Envelope u
|
|
retrying = Envelope
|
|
|
|
forwarding
|
|
:: LocalRefURI
|
|
-> (ByteString -> S.Signature)
|
|
-> Bool
|
|
-> ObjURI u
|
|
-> BL.ByteString
|
|
-> ByteString
|
|
-> Errand u
|
|
forwarding lruKey sign holder (ObjURI hFwder luFwder) body sig =
|
|
Errand
|
|
{ errandKey = RefURI hFwder lruKey
|
|
, errandSign = sign
|
|
, errandHolder = holder
|
|
, errandFwder = luFwder
|
|
, errandBody = body
|
|
, errandProof = sig
|
|
}
|
|
|
|
deliver
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-> NonEmpty HeaderName
|
|
-> Envelope u
|
|
-> Maybe LocalURI
|
|
-> ObjURI u
|
|
-> m (Either APPostError (Response ()))
|
|
deliver manager headers (Envelope ruKey sign mluHolder body) mluFwd uInbox =
|
|
httpPostAPBytes
|
|
manager
|
|
headers
|
|
ruKey
|
|
sign
|
|
mluHolder
|
|
body
|
|
(maybe SendNoForward SendAllowForward mluFwd)
|
|
uInbox
|
|
|
|
forward
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-> NonEmpty HeaderName
|
|
-> Errand u
|
|
-> ObjURI u
|
|
-> m (Either APPostError (Response ()))
|
|
forward manager headers (Errand ruKey@(RefURI hKey _) sign holder luFwder body sig) uInbox =
|
|
httpPostAPBytes
|
|
manager
|
|
headers
|
|
ruKey
|
|
sign
|
|
(guard holder >> Just luFwder)
|
|
body
|
|
(ForwardBy (ObjURI hKey luFwder) sig)
|
|
uInbox
|
|
|
|
-- | Result of GETing the keyId URI and processing the JSON document.
|
|
data Fetched = Fetched
|
|
{ fetchedPublicKey :: PublicVerifKey
|
|
-- ^ The Ed25519 or RSA public key corresponding to the URI we requested.
|
|
, fetchedKeyExpires :: Maybe UTCTime
|
|
-- ^ Optional expiration time declared for the key we received.
|
|
, fetchedActorId :: LocalURI
|
|
-- ^ The @id URI of the actor for whom the key's signature applies.
|
|
, fetchedActorName :: Maybe Text
|
|
-- ^ Name of the actor for whom the key's signature applies.
|
|
, fetchedActorInbox :: LocalURI
|
|
-- ^ The inbox URI of the actor for whom the key's signature applies.
|
|
, fetchedActorFollowers :: Maybe LocalURI
|
|
-- ^ The follower collection URI of the actor for whom the key's
|
|
-- signature applies.
|
|
, fetchedKeyShared :: Bool
|
|
-- ^ Whether the key we received is shared. A shared key can sign
|
|
-- requests for any actor on the same instance, while a personal key is
|
|
-- only for one actor. Knowing whether the key is shared will allow us
|
|
-- when receiving more requests, whether to accept signatures made on
|
|
-- different actors, or allow only a single permanent actor for the key
|
|
-- we received.
|
|
}
|
|
|
|
fetchAP' :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT APGetError m a
|
|
fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u
|
|
|
|
fetchAP :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT String m a
|
|
fetchAP m u = withExceptT displayException $ fetchAP' m u
|
|
|
|
fetchAP_T :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT Text m a
|
|
fetchAP_T m u = withExceptT T.pack $ fetchAP m u
|
|
|
|
{-
|
|
fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a
|
|
fetchAPH m h lu = do
|
|
Doc h' v <- fetchAP m $ l2f h lu
|
|
if h == h'
|
|
then return v
|
|
else throwE "Object @id URI's host doesn't match the URI we fetched"
|
|
-}
|
|
|
|
fetchAPID' :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (a u))
|
|
fetchAPID' m getId h lu = runExceptT $ do
|
|
Doc h' v <- withExceptT Just $ fetchAP' m $ Left $ ObjURI h lu
|
|
if h == h' && getId v == lu
|
|
then return v
|
|
else throwE Nothing
|
|
|
|
fetchTip :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Either (Repo u) (Branch u)))
|
|
fetchTip m h lu = runExceptT $ do
|
|
tip <- fmap toEither $ withExceptT Just $ fetchAP' m $ Left $ ObjURI h lu
|
|
bitraverse
|
|
(\ (Doc h' repo) ->
|
|
if h == h' && actorId (actorLocal $ repoActor repo) == lu
|
|
then return repo
|
|
else throwE Nothing
|
|
)
|
|
(\ (Doc _ branch) -> pure branch)
|
|
tip
|
|
|
|
fetchRecipient :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Recipient u))
|
|
fetchRecipient m = fetchAPID' m getId
|
|
where
|
|
getId (RecipientActor a) = actorId $ actorLocal a
|
|
getId (RecipientCollection c) = collectionId c
|
|
|
|
fetchResource :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Resource u))
|
|
fetchResource m = fetchAPID' m getId
|
|
where
|
|
getId (ResourceActor a) = actorId $ actorLocal a
|
|
getId (ResourceChild luId _) = luId
|
|
|
|
fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u))
|
|
fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
|
|
where
|
|
showError Nothing = "Object @id doesn't match the URI we fetched"
|
|
showError (Just e) = displayException e
|
|
|
|
data FetchAPError
|
|
= FetchAPErrorGet APGetError
|
|
-- Object @id doesn't match the URI we fetched
|
|
| FetchAPErrorIdMismatch
|
|
-- Object @id URI's host doesn't match the URI we fetched
|
|
| FetchAPErrorHostMismatch
|
|
deriving Show
|
|
|
|
fetchAPIDOrH'
|
|
:: (MonadIO m, UriMode u, ActivityPub a, ActivityPub b)
|
|
=> Manager
|
|
-> (a u -> LocalRefURI)
|
|
-> Authority u
|
|
-> LocalRefURI
|
|
-> ExceptT FetchAPError m (Either (a u) (b u))
|
|
fetchAPIDOrH' m getId h (LocalRefURI lu) = do
|
|
e <- withExceptT FetchAPErrorGet $ fetchAP' m $ bimap (ObjURI h) (SubURI h) lu
|
|
case e of
|
|
Left' (Doc h' x) ->
|
|
if h == h' && getId x == LocalRefURI lu
|
|
then return $ Left x
|
|
else throwE FetchAPErrorIdMismatch
|
|
Right' (Doc h' y) ->
|
|
if h == h'
|
|
then return $ Right y
|
|
else throwE FetchAPErrorHostMismatch
|
|
|
|
fetchAPIDOrH
|
|
:: (MonadIO m, UriMode u, ActivityPub a, ActivityPub b)
|
|
=> Manager
|
|
-> (a u -> LocalRefURI)
|
|
-> Authority u
|
|
-> LocalRefURI
|
|
-> ExceptT String m (Either (a u) (b u))
|
|
fetchAPIDOrH m getId h lu = withExceptT show $ fetchAPIDOrH' m getId h lu
|
|
|
|
-- | Fetches the given actor and checks whether it lists the given key (as a
|
|
-- URI, not as an embedded object). If it does, returns 'Right' the fetched
|
|
-- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an
|
|
-- error message.
|
|
keyListedByActor
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-> Authority u
|
|
-> LocalRefURI
|
|
-> LocalURI
|
|
-> m (Either String (Actor u))
|
|
keyListedByActor manager host luKey luActor = runExceptT $ do
|
|
actor <- ExceptT $ fetchAPID manager (actorId . actorLocal) host luActor
|
|
if keyUriListed luKey actor
|
|
then return actor
|
|
else throwE "Actor publicKey has no URI matching pkey @id"
|
|
where
|
|
keyUriListed (LocalRefURI uk) a =
|
|
let match (Left uri) = Left uri == uk
|
|
match (Right _) = False
|
|
in any match $ actorPublicKeys $ actorLocal a
|
|
|
|
matchKeyObj
|
|
:: (Foldable f, Monad m, UriMode u)
|
|
=> LocalRefURI
|
|
-> f (Either LocalURI (PublicKey u))
|
|
-> ExceptT String m (PublicKey u)
|
|
matchKeyObj luKey es =
|
|
case find' (match luKey) es of
|
|
Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
|
|
Just pk -> return pk
|
|
where
|
|
find' :: Foldable f => (a -> Maybe b) -> f a -> Maybe b
|
|
find' p = join . fmap getFirst . foldMap (Just . First . p)
|
|
match _ (Left _) = Nothing
|
|
match luk (Right pk) =
|
|
if publicKeyId pk == luk
|
|
then Just pk
|
|
else Nothing
|
|
|
|
verifyAlgo :: Maybe S.Algorithm -> PublicVerifKey -> Either String ()
|
|
verifyAlgo Nothing _ = Right ()
|
|
verifyAlgo (Just a) k =
|
|
case a of
|
|
S.AlgorithmEd25519 ->
|
|
case k of
|
|
PublicVerifKeyEd25519 _ -> Right ()
|
|
PublicVerifKeyRSA _ ->
|
|
Left "Algo mismatch, algo is Ed25519 but actual key is RSA"
|
|
S.AlgorithmRsaSha256 ->
|
|
case k of
|
|
PublicVerifKeyEd25519 _ ->
|
|
Left
|
|
"Algo mismatch, algo is RSA-SHA256 but actual key is \
|
|
\Ed25519"
|
|
PublicVerifKeyRSA _ -> Right ()
|
|
S.AlgorithmOther b -> Left $ concat
|
|
[ "Unrecognized algo "
|
|
, BC.unpack b
|
|
, ", actual key is "
|
|
, case k of
|
|
PublicVerifKeyEd25519 _ -> "Ed25519"
|
|
PublicVerifKeyRSA _ -> "RSA"
|
|
]
|
|
|
|
-- | Fetch a key we don't have cached locally.
|
|
fetchUnknownKey
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-- ^ Manager for making HTTP requests
|
|
-> Maybe S.Algorithm
|
|
-- ^ Signature algorithm possibly specified in the HTTP signature header
|
|
-> Authority u
|
|
-- ^ Instance host
|
|
-> Maybe LocalURI
|
|
-- ^ Actor URI possibly provided in the HTTP request's actor header
|
|
-> LocalRefURI
|
|
-- ^ Key URI provided in HTTP signature header
|
|
-> ExceptT String m Fetched
|
|
fetchUnknownKey manager malgo host mluActor luKey = do
|
|
obj <- fetchAPIDOrH manager publicKeyId host luKey
|
|
fetched <-
|
|
case obj of
|
|
Left pkey -> do
|
|
(oi, luActor) <-
|
|
case publicKeyOwner pkey of
|
|
OwnerInstance ->
|
|
case mluActor of
|
|
Nothing -> throwE "Key is shared but actor header not specified!"
|
|
Just u -> return (True, u)
|
|
OwnerActor owner -> do
|
|
for_ mluActor $ \ lu ->
|
|
if owner == lu
|
|
then return ()
|
|
else throwE "Key's owner doesn't match actor header"
|
|
return (False, owner)
|
|
Actor local detail <- ExceptT $ keyListedByActor manager host luKey luActor
|
|
return Fetched
|
|
{ fetchedPublicKey = publicKeyMaterial pkey
|
|
, fetchedKeyExpires = publicKeyExpires pkey
|
|
, fetchedActorId = luActor
|
|
, fetchedActorName = actorName detail <|> actorUsername detail
|
|
, fetchedActorInbox = actorInbox local
|
|
, fetchedActorFollowers = actorFollowers local
|
|
, fetchedKeyShared = oi
|
|
}
|
|
Right (Actor local detail) -> do
|
|
case luKey of
|
|
LocalRefURI (Right lsu) |
|
|
actorId local == localSubUriResource lsu -> return ()
|
|
_ -> throwE "Actor ID doesn't match the keyid URI we fetched"
|
|
for_ mluActor $ \ lu ->
|
|
if actorId local == lu
|
|
then return ()
|
|
else throwE "Key's owner doesn't match actor header"
|
|
pk <- matchKeyObj luKey $ actorPublicKeys local
|
|
owner <- case publicKeyOwner pk of
|
|
OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
|
|
OwnerActor owner ->
|
|
if owner == actorId local
|
|
then return owner
|
|
else throwE "Actor's publicKey's owner doesn't match the actor's ID"
|
|
return Fetched
|
|
{ fetchedPublicKey = publicKeyMaterial pk
|
|
, fetchedKeyExpires = publicKeyExpires pk
|
|
, fetchedActorId = owner
|
|
, fetchedActorName = actorName detail <|> actorUsername detail
|
|
, fetchedActorInbox = actorInbox local
|
|
, fetchedActorFollowers = actorFollowers local
|
|
, fetchedKeyShared = False
|
|
}
|
|
ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched
|
|
return fetched
|
|
|
|
keyDetail pk = (publicKeyMaterial pk, publicKeyExpires pk)
|
|
|
|
-- | Fetch a personal key we already have cached locally, but we'd like to
|
|
-- refresh the local copy by fetching the key again from the server.
|
|
fetchKnownPersonalKey
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-- ^ Manager for making HTTP requests
|
|
-> Maybe S.Algorithm
|
|
-- ^ Signature algorithm possibly specified in the HTTP signature header
|
|
-> Authority u
|
|
-- ^ Instance host
|
|
-> LocalURI
|
|
-- ^ Key owner actor ID URI
|
|
-> LocalRefURI
|
|
-- ^ Key URI
|
|
-> ExceptT String m (PublicVerifKey, Maybe UTCTime)
|
|
fetchKnownPersonalKey manager malgo host luOwner luKey@(LocalRefURI ek) = do
|
|
obj <- fetchAPIDOrH manager publicKeyId host luKey
|
|
(material, mexpires) <-
|
|
case obj of
|
|
Left pkey -> do
|
|
case publicKeyOwner pkey of
|
|
OwnerInstance -> throwE "Personal key became shared"
|
|
OwnerActor owner ->
|
|
when (luOwner /= owner) $ throwE "Key owner changed"
|
|
return $ keyDetail pkey
|
|
Right (Actor local detail) -> do
|
|
unless (Right (actorId local) == second localSubUriResource ek) $
|
|
throwE "Actor ID doesn't match the keyid URI we fetched"
|
|
unless (actorId local == luOwner) $
|
|
throwE "Key owner changed"
|
|
pk <- matchKeyObj luKey $ actorPublicKeys local
|
|
case publicKeyOwner pk of
|
|
OwnerInstance -> throwE "Personal key became shared"
|
|
OwnerActor owner ->
|
|
when (owner /= luOwner) $
|
|
throwE "Actor's publicKey's owner doesn't match the actor's ID"
|
|
return $ keyDetail pk
|
|
ExceptT . pure $ verifyAlgo malgo material
|
|
return (material, mexpires)
|
|
|
|
-- | Fetch a shared key we already have cached locally, but we'd like to
|
|
-- refresh the local copy by fetching the key again from the server.
|
|
fetchKnownSharedKey
|
|
:: (MonadIO m, UriMode u)
|
|
=> Manager
|
|
-- ^ Manager for making HTTP requests
|
|
-> Maybe S.Algorithm
|
|
-- ^ Signature algorithm possibly specified in the HTTP signature header
|
|
-> Authority u
|
|
-- ^ Instance host
|
|
-> LocalURI
|
|
-- ^ Actor ID from HTTP actor header
|
|
-> LocalRefURI
|
|
-- ^ Key URI
|
|
-> ExceptT String m (PublicVerifKey, Maybe UTCTime)
|
|
fetchKnownSharedKey manager malgo host luActor luKey = do
|
|
obj <- fetchAPIDOrH manager publicKeyId host luKey
|
|
pkey <-
|
|
case asKeyOrActor host obj of
|
|
Left pk -> return pk
|
|
Right _actor -> throwE "Expected stand-alone key, got embedded key"
|
|
case publicKeyOwner pkey of
|
|
OwnerInstance -> return ()
|
|
OwnerActor _owner -> throwE "Shared key became personal"
|
|
let (material, mexpires) = keyDetail pkey
|
|
ExceptT . pure $ verifyAlgo malgo material
|
|
return (material, mexpires)
|
|
where
|
|
asKeyOrActor
|
|
:: Authority u
|
|
-> Either (PublicKey u) (Actor u)
|
|
-> Either (PublicKey u) (Actor u)
|
|
asKeyOrActor _ = id
|
|
|
|
data Obj u = Obj
|
|
{ objId :: ObjURI u
|
|
, objType :: Text
|
|
|
|
, objContext :: Maybe (ObjURI u)
|
|
, objFollowers :: Maybe LocalURI
|
|
, objInbox :: Maybe LocalURI
|
|
, objTeam :: Maybe LocalURI
|
|
}
|
|
|
|
instance UriMode u => FromJSON (Obj u) where
|
|
parseJSON = withObject "Obj" $ \ o -> do
|
|
id_@(ObjURI h _) <- o .: "id" <|> o .: "@id"
|
|
Obj id_
|
|
<$> (o .: "type" <|> o .: "@type")
|
|
<*> o .:? "context"
|
|
<*> withAuthorityMaybeO h (o .:? "followers")
|
|
<*> withAuthorityMaybeO h (o .:? "inbox")
|
|
<*> withAuthorityMaybeO h (o .:? "team")
|