diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index f77e04b..0553215 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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." diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9dde4cc..39ec6a4 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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"