Adapt Activity/Create/Note to new ActivityPub typeclass and add safety checks
This commit is contained in:
fr33domlover
parent
61d1aa6720
commit
ef57f29a54
2 changed files with 75 additions and 81 deletions
|
|
@ -28,9 +28,10 @@ import Prelude
|
|||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
|
||||
import Control.Exception (displayException)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.STM (atomically)
|
||||
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Crypto.Error (CryptoFailable (..))
|
||||
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
||||
|
|
@ -129,7 +130,7 @@ postInboxR = do
|
|||
Left _ -> notAuthenticated
|
||||
where
|
||||
liftE = ExceptT . pure
|
||||
getActivity :: UTCTime -> ExceptT String Handler (ContentType, Activity)
|
||||
getActivity :: UTCTime -> ExceptT String Handler (ContentType, Doc Activity)
|
||||
getActivity now = do
|
||||
contentType <- do
|
||||
ctypes <- lookupHeaders "Content-Type"
|
||||
|
|
@ -141,16 +142,13 @@ postInboxR = do
|
|||
_ -> Left "Unknown Content-Type"
|
||||
_ -> Left "More than one Content-Type given"
|
||||
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
|
||||
uActor <- liftE result
|
||||
a@(CreateActivity c) <- requireJsonBody
|
||||
liftE $ do
|
||||
if createActor c == uActor
|
||||
then Right ()
|
||||
else Left "Activity's actor != Signature key's actor"
|
||||
if noteAttrib (createObject c) == uActor
|
||||
then Right ()
|
||||
else Left "Activity object's actor doesn't match activity's actor"
|
||||
return (contentType, a)
|
||||
(h, luActor) <- f2l <$> liftE result
|
||||
d@(Doc h' (CreateActivity c)) <- requireJsonBody
|
||||
unless (h == h') $
|
||||
throwE "Activity host doesn't match signature key host"
|
||||
unless (createActor c == luActor) $
|
||||
throwE "Activity's actor != Signature key's actor"
|
||||
return (contentType, d)
|
||||
|
||||
{-
|
||||
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
|
||||
|
|
@ -217,17 +215,15 @@ postOutboxR = do
|
|||
return $ sharerIdent sharer
|
||||
renderUrl <- getUrlRender
|
||||
let route2uri = route2uri' renderUrl
|
||||
actor = route2uri $ SharerR shr
|
||||
(h, actor) = f2l $ route2uri $ SharerR shr
|
||||
actorID = renderUrl $ SharerR shr
|
||||
appendPath u t = u { furiPath = furiPath u <> t }
|
||||
appendPath u t = u { luriPath = luriPath u <> t }
|
||||
activity = CreateActivity Create
|
||||
{ createId = appendPath actor "/fake-activity"
|
||||
, createTo = to
|
||||
, createActor = actor
|
||||
, createObject = Note
|
||||
{ noteId = appendPath actor "/fake-note"
|
||||
, noteAttrib = actor
|
||||
, noteTo = to
|
||||
, noteReplyTo = Nothing
|
||||
, noteContent = msg
|
||||
}
|
||||
|
|
@ -242,7 +238,7 @@ postOutboxR = do
|
|||
then (renderUrl ActorKey1R, akey1)
|
||||
else (renderUrl ActorKey2R, akey2)
|
||||
sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
|
||||
eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity
|
||||
eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID $ Doc h activity
|
||||
case eres' of
|
||||
Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
|
||||
Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ module Web.ActivityPub
|
|||
, Algorithm (..)
|
||||
, Owner (..)
|
||||
, PublicKey (..)
|
||||
--, PublicKeySet (..)
|
||||
, Actor (..)
|
||||
|
||||
-- * Activity
|
||||
|
|
@ -236,13 +235,6 @@ instance ActivityPub PublicKey where
|
|||
mkOwner h OwnerInstance = FedURI h "" ""
|
||||
mkOwner h (OwnerActor lu) = l2f h lu
|
||||
|
||||
{-
|
||||
data PublicKeySet = PublicKeySet
|
||||
{ publicKey1 :: Either LocalURI PublicKey
|
||||
, publicKey2 :: Maybe (Either LocalURI PublicKey)
|
||||
}
|
||||
-}
|
||||
|
||||
parsePublicKeySet :: Value -> Parser (Text, NonEmpty (Either LocalURI PublicKey))
|
||||
parsePublicKeySet v =
|
||||
case v of
|
||||
|
|
@ -303,81 +295,87 @@ instance ActivityPub Actor where
|
|||
<> "preferredUsername" .= username
|
||||
<> "inbox" .= l2f host inbox
|
||||
<> "publicKey" `pair` encodePublicKeySet host pkeys
|
||||
|
||||
data Note = Note
|
||||
{ noteId :: FedURI
|
||||
, noteAttrib :: FedURI
|
||||
, noteTo :: FedURI
|
||||
{ noteId :: LocalURI
|
||||
--, noteAttrib :: LocalURI
|
||||
--, noteTo :: FedURI
|
||||
, noteReplyTo :: Maybe FedURI
|
||||
, noteContent :: Text
|
||||
}
|
||||
|
||||
instance FromJSON Note where
|
||||
parseJSON = withObject "Note" $ \ o -> do
|
||||
typ <- o .: "type"
|
||||
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
|
||||
Note
|
||||
<$> o .: "id"
|
||||
<*> o .: "attributedTo"
|
||||
<*> o .: "to"
|
||||
<*> o .:? "inReplyTo"
|
||||
<*> o .: "content"
|
||||
parseNote :: Value -> Parser (Text, (Note, LocalURI, FedURI))
|
||||
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 .: "content"
|
||||
)
|
||||
<*> withHost h (f2l <$> o .: "attributedTo")
|
||||
<*> o .: "to"
|
||||
where
|
||||
withHost h a = do
|
||||
(h', v) <- a
|
||||
if h == h'
|
||||
then return v
|
||||
else fail "URI host mismatch"
|
||||
|
||||
instance ToJSON Note where
|
||||
toJSON = error "toJSON Note"
|
||||
toEncoding (Note id_ attrib to mreply content) =
|
||||
pairs
|
||||
$ "type" .= ("Note" :: Text)
|
||||
<> "id" .= id_
|
||||
<> "attributedTo" .= attrib
|
||||
<> "to" .= to
|
||||
<> "inReplyTo" .=? mreply
|
||||
<> "content" .= content
|
||||
encodeNote :: Text -> Note -> LocalURI -> FedURI -> Encoding
|
||||
encodeNote host (Note id_ mreply content) attrib to =
|
||||
pairs
|
||||
$ "type" .= ("Note" :: Text)
|
||||
<> "id" .= l2f host id_
|
||||
<> "attributedTo" .= l2f host attrib
|
||||
<> "to" .= to
|
||||
<> "inReplyTo" .=? mreply
|
||||
<> "content" .= content
|
||||
|
||||
data Create = Create
|
||||
{ createId :: FedURI
|
||||
{ createId :: LocalURI
|
||||
, createTo :: FedURI
|
||||
, createActor :: FedURI
|
||||
, createActor :: LocalURI
|
||||
, createObject :: Note
|
||||
}
|
||||
|
||||
instance FromJSON Create where
|
||||
parseJSON = withObject "Create" $ \ o -> do
|
||||
typ <- o .: "type"
|
||||
unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
|
||||
Create
|
||||
<$> o .: "id"
|
||||
<*> o .: "to"
|
||||
<*> o .: "actor"
|
||||
<*> o .: "object"
|
||||
parseCreate :: Object -> Parser (Text, Create)
|
||||
parseCreate o = do
|
||||
typ <- o .: "type"
|
||||
unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
|
||||
(h, id_) <- f2l <$> o .: "id"
|
||||
luActor <- withHost h $ f2l <$> o .: "actor"
|
||||
(note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object"
|
||||
unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
|
||||
uTo' <- o .: "to"
|
||||
unless (uTo == uTo') $ fail "Create to != Note to"
|
||||
return (h, Create id_ uTo luActor note)
|
||||
where
|
||||
withHost h a = do
|
||||
(h', v) <- a
|
||||
if h == h'
|
||||
then return v
|
||||
else fail "URI host mismatch"
|
||||
|
||||
instance ToJSON Create where
|
||||
toJSON = error "toJSON Create"
|
||||
toEncoding (Create id_ to actor obj) =
|
||||
pairs
|
||||
$ "@context" .= as2context
|
||||
<> "type" .= ("Create" :: Text)
|
||||
<> "id" .= id_
|
||||
<> "to" .= to
|
||||
<> "actor" .= actor
|
||||
<> "object" .= obj
|
||||
encodeCreate :: Text -> Create -> Series
|
||||
encodeCreate host (Create id_ to actor obj)
|
||||
= "type" .= ("Create" :: Text)
|
||||
<> "id" .= l2f host id_
|
||||
<> "to" .= to
|
||||
<> "actor" .= l2f host actor
|
||||
<> "object" `pair` encodeNote host obj actor to
|
||||
|
||||
data Activity = CreateActivity Create
|
||||
|
||||
instance FromJSON Activity where
|
||||
parseJSON = withObject "Activity" $ \ o -> do
|
||||
ctx <- o .: "@context"
|
||||
if ctx == as2context
|
||||
then return ()
|
||||
else fail "@context isn't the AS2 context URI"
|
||||
instance ActivityPub Activity where
|
||||
jsonldContext _ = ContextAS2
|
||||
parseObject o = do
|
||||
typ <- o .: "type"
|
||||
let v = Object o
|
||||
case typ of
|
||||
"Create" -> CreateActivity <$> parseJSON v
|
||||
"Create" -> second CreateActivity <$> parseCreate o
|
||||
_ -> fail $ "Unrecognized activity type: " ++ T.unpack typ
|
||||
|
||||
instance ToJSON Activity where
|
||||
toJSON = error "toJSON Activity"
|
||||
toEncoding (CreateActivity c) = toEncoding c
|
||||
toSeries host (CreateActivity c) = encodeCreate host c
|
||||
|
||||
typeActivityStreams2 :: ContentType
|
||||
typeActivityStreams2 = "application/activity+json"
|
||||
|
|
|
|||
Loading…
Reference in a new issue