941 lines
32 KiB
Haskell
941 lines
32 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019 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 (..)
|
|
, Actor (..)
|
|
|
|
-- * Activity
|
|
, Note (..)
|
|
, Accept (..)
|
|
, Create (..)
|
|
, Follow (..)
|
|
, Reject (..)
|
|
, Audience (..)
|
|
, SpecificActivity (..)
|
|
, Activity (..)
|
|
|
|
-- * Utilities
|
|
, publicURI
|
|
, deliverTo
|
|
, hActivityPubActor
|
|
, provideAP
|
|
, APGetError (..)
|
|
, httpGetAP
|
|
, APPostError (..)
|
|
, httpPostAP
|
|
, Fetched (..)
|
|
, fetchAPID
|
|
, fetchAPID'
|
|
, keyListedByActor
|
|
, fetchUnknownKey
|
|
, fetchKnownPersonalKey
|
|
, fetchKnownSharedKey
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Applicative ((<|>), optional)
|
|
import Control.Exception (Exception, displayException, try)
|
|
import Control.Monad (when, unless, (<=<), join)
|
|
import Control.Monad.IO.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 (bitraverse)
|
|
import Data.ByteString (ByteString)
|
|
import Data.Foldable (for_)
|
|
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
|
|
import Data.Proxy
|
|
import Data.PEM
|
|
import Data.Semigroup (Endo, First (..))
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Data.Traversable
|
|
import Data.Vector (Vector)
|
|
import Network.HTTP.Client hiding (Proxy, proxy)
|
|
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
|
import Network.HTTP.Client.Signature (signRequest)
|
|
import Network.HTTP.Simple (JSONException)
|
|
import Network.HTTP.Types.Header (HeaderName, hContentType)
|
|
import Network.URI
|
|
import Yesod.Core.Content (ContentType)
|
|
import Yesod.Core.Handler (ProvidedRep, provideRepType)
|
|
|
|
import qualified Data.ByteString.Char8 as BC
|
|
import qualified Data.HashMap.Strict as M (lookup)
|
|
import qualified Data.Text as T (pack, unpack)
|
|
import qualified Data.Vector as V
|
|
import qualified Network.HTTP.Signature as S
|
|
|
|
import Crypto.PublicVerifKey
|
|
import Network.FedURI
|
|
import Network.HTTP.Digest
|
|
|
|
import Data.Aeson.Local
|
|
|
|
proxy :: a -> Proxy a
|
|
proxy _ = Proxy
|
|
|
|
as2context :: Text
|
|
as2context = "https://www.w3.org/ns/activitystreams"
|
|
|
|
secContext :: Text
|
|
secContext = "https://w3id.org/security/v1"
|
|
|
|
publicURI :: FedURI
|
|
publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public"
|
|
|
|
publicT :: Text
|
|
publicT = renderFedURI publicURI
|
|
|
|
actorContext :: [Text]
|
|
actorContext = [as2context, secContext]
|
|
|
|
data Context = ContextAS2 | ContextPKey | ContextActor deriving Eq
|
|
|
|
instance FromJSON Context where
|
|
parseJSON (String t)
|
|
| t == as2context = return ContextAS2
|
|
| t == secContext = return ContextPKey
|
|
parseJSON (Array v)
|
|
| V.toList v == map String actorContext = return ContextActor
|
|
parseJSON _ = fail "Unrecognized @context"
|
|
|
|
instance ToJSON Context where
|
|
toJSON = error "toJSON Context"
|
|
toEncoding ContextAS2 = toEncoding as2context
|
|
toEncoding ContextPKey = toEncoding secContext
|
|
toEncoding ContextActor = toEncoding actorContext
|
|
|
|
class ActivityPub a where
|
|
jsonldContext :: Proxy a -> Context
|
|
parseObject :: Object -> Parser (Text, a)
|
|
toSeries :: Text -> a -> Series
|
|
|
|
data Doc a = Doc
|
|
{ docHost :: Text
|
|
, docValue :: a
|
|
}
|
|
|
|
instance ActivityPub a => FromJSON (Doc a) where
|
|
parseJSON = withObject "Doc" $ \ o -> do
|
|
(h, v) <- parseObject o
|
|
ctx <- o .: "@context"
|
|
if ctx == jsonldContext (proxy v)
|
|
then return $ Doc h v
|
|
else fail "@context doesn't match"
|
|
|
|
instance ActivityPub a => ToJSON (Doc a) where
|
|
toJSON = error "toJSON Doc"
|
|
toEncoding (Doc h v) =
|
|
pairs
|
|
$ "@context" .= jsonldContext (proxy v)
|
|
<> toSeries h v
|
|
|
|
data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
|
|
|
|
instance FromJSON ActorType where
|
|
parseJSON = withText "ActorType" $ pure . parse
|
|
where
|
|
parse t
|
|
| t == "Person" = ActorTypePerson
|
|
| t == frg <> "Project" = ActorTypeProject
|
|
| otherwise = ActorTypeOther t
|
|
|
|
instance ToJSON ActorType where
|
|
toJSON = error "toJSON ActorType"
|
|
toEncoding at =
|
|
toEncoding $ case at of
|
|
ActorTypePerson -> "Person"
|
|
ActorTypeProject -> frg <> "Project"
|
|
ActorTypeOther t -> t
|
|
|
|
{-
|
|
data Algorithm = AlgorithmEd25519 | AlgorithmRsaSha256 | AlgorithmOther Text
|
|
|
|
instance FromJSON Algorithm where
|
|
parseJSON = withText "Algorithm" $ \ t -> pure
|
|
| t == frg <> "ed25519" = AlgorithmEd25519
|
|
| t == frg <> "rsa-sha256" = AlgorithmRsaSha256
|
|
| otherwise = AlgorithmOther t
|
|
|
|
instance ToJSON Algorithm where
|
|
toJSON = error "toJSON Algorithm"
|
|
toEncoding algo =
|
|
toEncoding $ case algo of
|
|
AlgorithmEd25519 -> frg <> "ed25519"
|
|
AlgorithmRsaSha256 -> frg <> "rsa-sha256"
|
|
AlgorithmOther t -> t
|
|
-}
|
|
|
|
data Owner = OwnerInstance | OwnerActor LocalURI
|
|
|
|
ownerShared :: Owner -> Bool
|
|
ownerShared OwnerInstance = True
|
|
ownerShared (OwnerActor _) = False
|
|
|
|
data PublicKey = PublicKey
|
|
{ publicKeyId :: LocalURI
|
|
, publicKeyExpires :: Maybe UTCTime
|
|
, publicKeyOwner :: Owner
|
|
, publicKeyMaterial :: PublicVerifKey
|
|
--, publicKeyAlgo :: Maybe Algorithm
|
|
}
|
|
|
|
instance ActivityPub PublicKey where
|
|
jsonldContext _ = ContextPKey
|
|
parseObject o = do
|
|
mtyp <- optional $ o .: "@type" <|> o .: "type"
|
|
for_ mtyp $ \ t ->
|
|
when (t /= ("Key" :: Text)) $
|
|
fail "PublicKey @type isn't Key"
|
|
(host, id_) <- f2l <$> (o .: "@id" <|> o .: "id")
|
|
shared <- o .:? (frg <> "isShared") .!= False
|
|
fmap (host,) $
|
|
PublicKey id_
|
|
<$> o .:? "expires"
|
|
<*> (mkOwner shared =<< withHost host o "owner")
|
|
<*> (either fail return . decodePublicVerifKeyPEM =<<
|
|
o .: "publicKeyPem"
|
|
)
|
|
-- <*> o .:? (frg <> "algorithm")
|
|
where
|
|
withHost h o t = do
|
|
(h', lu) <- f2l <$> o .: t
|
|
if h == h'
|
|
then return lu
|
|
else fail "URI host mismatch"
|
|
mkOwner True (LocalURI "" "") = return OwnerInstance
|
|
mkOwner True _ = fail "Shared key but owner isn't instance URI"
|
|
mkOwner False lu = return $ OwnerActor lu
|
|
toSeries host (PublicKey id_ mexpires owner mat)
|
|
= "@id" .= l2f host id_
|
|
<> "expires" .=? mexpires
|
|
<> "owner" .= mkOwner host owner
|
|
<> "publicKeyPem" .= encodePublicVerifKeyPEM mat
|
|
-- <> (frg <> "algorithm") .=? malgo
|
|
<> (frg <> "isShared") .= ownerShared owner
|
|
where
|
|
mkOwner h OwnerInstance = FedURI h "" ""
|
|
mkOwner h (OwnerActor lu) = l2f h lu
|
|
|
|
parsePublicKeySet :: Value -> Parser (Text, [Either LocalURI PublicKey])
|
|
parsePublicKeySet v =
|
|
case v of
|
|
Array a ->
|
|
case V.toList a of
|
|
[] -> fail "No public keys"
|
|
k : ks -> do
|
|
(h, e) <- parseKey k
|
|
es <- traverse (withHost h . parseKey) ks
|
|
return (h, e : es)
|
|
_ -> second (: []) <$> parseKey v
|
|
where
|
|
parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t)
|
|
parseKey (Object o) = second Right <$> parseObject o
|
|
parseKey v = typeMismatch "PublicKeySet Item" v
|
|
withHost h a = do
|
|
(h', v) <- a
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
|
|
encodePublicKeySet :: Text -> [Either LocalURI PublicKey] -> Encoding
|
|
encodePublicKeySet host es =
|
|
case es of
|
|
[e] -> renderKey e
|
|
_ -> listEncoding renderKey es
|
|
where
|
|
renderKey (Left lu) = toEncoding $ l2f host lu
|
|
renderKey (Right pk) = pairs $ toSeries host pk
|
|
|
|
data Actor = Actor
|
|
{ actorId :: LocalURI
|
|
, actorType :: ActorType
|
|
, actorUsername :: Maybe Text
|
|
, actorName :: Maybe Text
|
|
, actorSummary :: Maybe Text
|
|
, actorInbox :: LocalURI
|
|
, actorPublicKeys :: [Either LocalURI PublicKey]
|
|
}
|
|
|
|
instance ActivityPub Actor where
|
|
jsonldContext _ = ContextActor
|
|
parseObject o = do
|
|
(host, id_) <- f2l <$> o .: "id"
|
|
fmap (host,) $
|
|
Actor id_
|
|
<$> o .: "type"
|
|
<*> o .:? "preferredUsername"
|
|
<*> o .:? "name"
|
|
<*> o .:? "summary"
|
|
<*> withHost host (f2l <$> o .: "inbox")
|
|
<*> withHost host (parsePublicKeySet =<< o .: "publicKey")
|
|
where
|
|
withHost h a = do
|
|
(h', v) <- a
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
toSeries host (Actor id_ typ musername mname msummary inbox pkeys)
|
|
= "id" .= l2f host id_
|
|
<> "type" .= typ
|
|
<> "preferredUsername" .=? musername
|
|
<> "name" .=? mname
|
|
<> "summary" .=? msummary
|
|
<> "inbox" .= l2f host inbox
|
|
<> "publicKey" `pair` encodePublicKeySet host pkeys
|
|
|
|
data Audience = Audience
|
|
{ audienceTo :: [FedURI]
|
|
, audienceBto :: [FedURI]
|
|
, audienceCc :: [FedURI]
|
|
, audienceBcc :: [FedURI]
|
|
, audienceGeneral :: [FedURI]
|
|
}
|
|
|
|
deliverTo :: FedURI -> Audience
|
|
deliverTo to = Audience
|
|
{ audienceTo = [to]
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
}
|
|
|
|
newtype AdaptAudience = AdaptAudience
|
|
{ unAdapt :: FedURI
|
|
}
|
|
|
|
instance FromJSON AdaptAudience where
|
|
parseJSON = parseJSON . adapt
|
|
where
|
|
adapt v =
|
|
case v of
|
|
String t
|
|
| t == "Public" -> String publicT
|
|
| t == "as:Public" -> String publicT
|
|
_ -> v
|
|
|
|
parseAudience :: Object -> Parser Audience
|
|
parseAudience o =
|
|
Audience
|
|
<$> o .:& "to"
|
|
<*> o .:& "bto"
|
|
<*> o .:& "cc"
|
|
<*> o .:& "bcc"
|
|
<*> o .:& "audience"
|
|
where
|
|
obj .:& key = do
|
|
l <- obj .:? key .!= []
|
|
return $ map unAdapt l
|
|
|
|
encodeAudience :: Audience -> Series
|
|
encodeAudience (Audience to bto cc bcc aud)
|
|
= "to" .=% to
|
|
<> "bto" .=% bto
|
|
<> "cc" .=% cc
|
|
<> "bcc" .=% bcc
|
|
<> "audience" .=% aud
|
|
where
|
|
t .=% v =
|
|
if null v
|
|
then mempty
|
|
else t .= v
|
|
|
|
data Note = Note
|
|
{ noteId :: Maybe LocalURI
|
|
, noteAttrib :: LocalURI
|
|
, noteAudience :: Audience
|
|
, noteReplyTo :: Maybe FedURI
|
|
, noteContext :: Maybe FedURI
|
|
, notePublished :: Maybe UTCTime
|
|
, noteContent :: Text
|
|
}
|
|
|
|
withHost h a = do
|
|
(h', v) <- a
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
|
|
withHostM h a = do
|
|
mp <- a
|
|
for mp $ \ (h', v) ->
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
|
|
instance ActivityPub Note where
|
|
jsonldContext _ = ContextAS2
|
|
parseObject o = do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
|
|
(h, attrib) <- f2l <$> o .: "attributedTo"
|
|
(h, id_) <- f2l <$> o .: "id"
|
|
fmap (h,) $
|
|
Note
|
|
<$> withHostM h (fmap f2l <$> o .:? "id")
|
|
<*> pure attrib
|
|
<*> parseAudience o
|
|
<*> o .:? "inReplyTo"
|
|
<*> o .:? "context"
|
|
<*> o .:? "published"
|
|
<*> o .: "content"
|
|
toSeries host (Note mid attrib aud mreply mcontext mpublished content)
|
|
= "type" .= ("Note" :: Text)
|
|
<> "id" .=? (l2f host <$> mid)
|
|
<> "attributedTo" .= l2f host attrib
|
|
<> encodeAudience aud
|
|
<> "inReplyTo" .=? mreply
|
|
<> "context" .=? mcontext
|
|
<> "published" .=? mpublished
|
|
<> "content" .= content
|
|
|
|
{-
|
|
parseNote :: Value -> Parser (Text, (Note, LocalURI))
|
|
parseNote = withObject "Note" $ \ o -> do
|
|
typ <- o .: "type"
|
|
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
|
|
(h, id_) <- f2l <$> o .: "id"
|
|
fmap (h,) $
|
|
(,) <$> (Note id_
|
|
<$> o .:? "inReplyTo"
|
|
<*> o .:? "context"
|
|
<*> o .:? "published"
|
|
<*> o .: "content"
|
|
)
|
|
<*> withHost h (f2l <$> o .: "attributedTo")
|
|
where
|
|
withHost h a = do
|
|
(h', v) <- a
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
|
|
encodeNote :: Text -> Note -> LocalURI -> Encoding
|
|
encodeNote host (Note id_ mreply mcontext mpublished content) attrib =
|
|
pairs
|
|
$ "type" .= ("Note" :: Text)
|
|
<> "id" .= l2f host id_
|
|
<> "attributedTo" .= l2f host attrib
|
|
<> "inReplyTo" .=? mreply
|
|
<> "context" .=? mcontext
|
|
<> "published" .=? mpublished
|
|
<> "content" .= content
|
|
-}
|
|
|
|
data Accept = Accept
|
|
{ acceptObject :: FedURI
|
|
}
|
|
|
|
parseAccept :: Object -> Parser Accept
|
|
parseAccept o = Accept <$> o .: "object"
|
|
|
|
encodeAccept :: Accept -> Series
|
|
encodeAccept (Accept obj) = "object" .= obj
|
|
|
|
data Create = Create
|
|
{ createObject :: Note
|
|
}
|
|
|
|
parseCreate :: Object -> Text -> LocalURI -> Parser Create
|
|
parseCreate o h luActor = do
|
|
note <- withHost h $ parseObject =<< o .: "object"
|
|
unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib"
|
|
return $ Create note
|
|
where
|
|
withHost h a = do
|
|
(h', v) <- a
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
|
|
encodeCreate :: Text -> LocalURI -> Create -> Series
|
|
encodeCreate host actor (Create obj) =
|
|
"object" `pair` pairs (toSeries host obj)
|
|
|
|
data Follow = Follow
|
|
{ followObject :: FedURI
|
|
, followHide :: Bool
|
|
}
|
|
|
|
parseFollow :: Object -> Parser Follow
|
|
parseFollow o =
|
|
Follow
|
|
<$> o .: "object"
|
|
<*> o .: (frg <> "hide")
|
|
|
|
encodeFollow :: Follow -> Series
|
|
encodeFollow (Follow obj hide)
|
|
= "object" .= obj
|
|
<> (frg <> "hide") .= hide
|
|
|
|
data Reject = Reject
|
|
{ rejectObject :: FedURI
|
|
}
|
|
|
|
parseReject :: Object -> Parser Reject
|
|
parseReject o = Reject <$> o .: "object"
|
|
|
|
encodeReject :: Reject -> Series
|
|
encodeReject (Reject obj) = "object" .= obj
|
|
|
|
data SpecificActivity
|
|
= AcceptActivity Accept
|
|
| CreateActivity Create
|
|
| FollowActivity Follow
|
|
| RejectActivity Reject
|
|
|
|
data Activity = Activity
|
|
{ activityId :: LocalURI
|
|
, activityActor :: LocalURI
|
|
, activityAudience :: Audience
|
|
, activitySpecific :: SpecificActivity
|
|
}
|
|
|
|
instance ActivityPub Activity where
|
|
jsonldContext _ = ContextAS2
|
|
parseObject o = do
|
|
(h, id_) <- f2l <$> o .: "id"
|
|
actor <- withHost h $ f2l <$> o .: "actor"
|
|
fmap (h,) $
|
|
Activity id_ actor
|
|
<$> parseAudience o
|
|
<*> do
|
|
typ <- o .: "type"
|
|
case typ of
|
|
"Accept" -> AcceptActivity <$> parseAccept o
|
|
"Create" -> CreateActivity <$> parseCreate o h actor
|
|
"Follow" -> FollowActivity <$> parseFollow o
|
|
"Reject" -> RejectActivity <$> parseReject o
|
|
_ ->
|
|
fail $
|
|
"Unrecognized activity type: " ++ T.unpack typ
|
|
where
|
|
withHost h a = do
|
|
(h', v) <- a
|
|
if h == h'
|
|
then return v
|
|
else fail "URI host mismatch"
|
|
toSeries host (Activity id_ actor audience specific)
|
|
= "type" .= activityType specific
|
|
<> "id" .= l2f host id_
|
|
<> "actor" .= l2f host actor
|
|
<> encodeAudience audience
|
|
<> encodeSpecific host actor specific
|
|
where
|
|
activityType :: SpecificActivity -> Text
|
|
activityType (AcceptActivity _) = "Accept"
|
|
activityType (CreateActivity _) = "Create"
|
|
activityType (FollowActivity _) = "Follow"
|
|
activityType (RejectActivity _) = "Reject"
|
|
encodeSpecific _ _ (AcceptActivity a) = encodeAccept a
|
|
encodeSpecific h u (CreateActivity a) = encodeCreate h u a
|
|
encodeSpecific _ _ (FollowActivity a) = encodeFollow a
|
|
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
|
|
|
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
|
|
|
|
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, FromJSON a)
|
|
=> Manager
|
|
-> FedURI
|
|
-> m (Either APGetError (Response a))
|
|
httpGetAP manager uri =
|
|
liftIO $
|
|
mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri))
|
|
where
|
|
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
|
|
|
|
-- | 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
|
|
-- * Compute HTTP signature and add _Signature_ request header
|
|
-- * Perform the POST request
|
|
-- * Verify the response status is 2xx
|
|
httpPostAP
|
|
:: (MonadIO m, ToJSON a)
|
|
=> Manager
|
|
-> FedURI
|
|
-> NonEmpty HeaderName
|
|
-> (ByteString -> (S.KeyId, S.Signature))
|
|
-> Text
|
|
-> a
|
|
-> m (Either APPostError (Response ()))
|
|
httpPostAP manager uri headers sign uActor value = liftIO $ do
|
|
req <- requestFromURI $ toURI uri
|
|
let body = encode value
|
|
digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
|
req' =
|
|
setRequestCheckStatus $
|
|
consHeader hContentType typeActivityStreams2LD $
|
|
consHeader hActivityPubActor (encodeUtf8 uActor) $
|
|
consHeader hDigest digest $
|
|
req { method = "POST"
|
|
, requestBody = RequestBodyLBS body
|
|
}
|
|
sign' b =
|
|
let (k, s) = sign b
|
|
in (Nothing, k, s)
|
|
ereq <- try $ signRequest headers sign' Nothing req'
|
|
case ereq of
|
|
Left sigErr -> return $ Left $ APPostErrorSig sigErr
|
|
Right req'' -> first APPostErrorHTTP <$> try (httpNoBody req'' manager)
|
|
where
|
|
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
|
|
|
-- | 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.
|
|
, fetchedActorInbox :: LocalURI
|
|
-- ^ The inbox 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, FromJSON a) => Manager -> FedURI -> ExceptT APGetError m a
|
|
fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u
|
|
|
|
fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a
|
|
fetchAP m u = withExceptT displayException $ 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, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either (Maybe APGetError) a)
|
|
fetchAPID' m getId h lu = runExceptT $ do
|
|
Doc h' v <- withExceptT Just $ fetchAP' m $ l2f h lu
|
|
if h == h' && getId v == lu
|
|
then return v
|
|
else throwE Nothing
|
|
|
|
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
|
|
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, ActivityPub a, ActivityPub b)
|
|
=> Manager
|
|
-> (a -> LocalURI)
|
|
-> Text
|
|
-> LocalURI
|
|
-> ExceptT FetchAPError m (Either a b)
|
|
fetchAPIDOrH' m getId h lu = do
|
|
e <- withExceptT FetchAPErrorGet $ fetchAP' m $ l2f h lu
|
|
case e of
|
|
Left' (Doc h' x) ->
|
|
if h == h' && getId x == 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, ActivityPub a, ActivityPub b)
|
|
=> Manager
|
|
-> (a -> LocalURI)
|
|
-> Text
|
|
-> LocalURI
|
|
-> ExceptT String m (Either a b)
|
|
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 => Manager -> Text -> LocalURI -> LocalURI -> m (Either String Actor)
|
|
keyListedByActor manager host luKey luActor = runExceptT $ do
|
|
actor <- ExceptT $ fetchAPID manager actorId host luActor
|
|
if keyUriListed luKey actor
|
|
then return actor
|
|
else throwE "Actor publicKey has no URI matching pkey @id"
|
|
where
|
|
keyUriListed uk a =
|
|
let match (Left uri) = uri == uk
|
|
match (Right _) = False
|
|
in any match $ actorPublicKeys a
|
|
|
|
matchKeyObj :: (Foldable f, Monad m) => LocalURI -> f (Either LocalURI PublicKey) -> ExceptT String m PublicKey
|
|
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
|
|
=> Manager
|
|
-- ^ Manager for making HTTP requests
|
|
-> Maybe S.Algorithm
|
|
-- ^ Signature algorithm possibly specified in the HTTP signature header
|
|
-> Text
|
|
-- ^ Instance host
|
|
-> Maybe LocalURI
|
|
-- ^ Actor URI possibly provided in the HTTP request's actor header
|
|
-> LocalURI
|
|
-- ^ 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)
|
|
inbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
|
|
return Fetched
|
|
{ fetchedPublicKey = publicKeyMaterial pkey
|
|
, fetchedKeyExpires = publicKeyExpires pkey
|
|
, fetchedActorId = luActor
|
|
, fetchedActorInbox = inbox
|
|
, fetchedKeyShared = oi
|
|
}
|
|
Right actor -> do
|
|
if actorId actor == luKey { luriFragment = "" }
|
|
then return ()
|
|
else throwE "Actor ID doesn't match the keyid URI we fetched"
|
|
for_ mluActor $ \ lu ->
|
|
if actorId actor == lu
|
|
then return ()
|
|
else throwE "Key's owner doesn't match actor header"
|
|
pk <- matchKeyObj luKey $ actorPublicKeys actor
|
|
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 actor
|
|
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
|
|
, fetchedActorInbox = actorInbox actor
|
|
, 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
|
|
=> Manager
|
|
-- ^ Manager for making HTTP requests
|
|
-> Maybe S.Algorithm
|
|
-- ^ Signature algorithm possibly specified in the HTTP signature header
|
|
-> Text
|
|
-- ^ Instance host
|
|
-> LocalURI
|
|
-- ^ Key owner actor ID URI
|
|
-> LocalURI
|
|
-- ^ Key URI
|
|
-> ExceptT String m (PublicVerifKey, Maybe UTCTime)
|
|
fetchKnownPersonalKey manager malgo host luOwner luKey = 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 -> do
|
|
when (actorId actor /= luKey { luriFragment = "" }) $
|
|
throwE "Actor ID doesn't match the keyid URI we fetched"
|
|
when (actorId actor /= luOwner) $
|
|
throwE "Key owner changed"
|
|
pk <- matchKeyObj luKey $ actorPublicKeys actor
|
|
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
|
|
=> Manager
|
|
-- ^ Manager for making HTTP requests
|
|
-> Maybe S.Algorithm
|
|
-- ^ Signature algorithm possibly specified in the HTTP signature header
|
|
-> Text
|
|
-- ^ Instance host
|
|
-> LocalURI
|
|
-- ^ Actor ID from HTTP actor header
|
|
-> LocalURI
|
|
-- ^ Key URI
|
|
-> ExceptT String m (PublicVerifKey, Maybe UTCTime)
|
|
fetchKnownSharedKey manager malgo host luActor luKey = do
|
|
obj <- fetchAPIDOrH manager publicKeyId host luKey
|
|
pkey <-
|
|
case obj :: Either PublicKey Actor 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)
|