Adapt Activity/Create/Note to new ActivityPub typeclass and add safety checks

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
+        (h, luActor) <- f2l <$> liftE result
-        a@(CreateActivity c) <- requireJsonBody
+        d@(Doc h' (CreateActivity c)) <- requireJsonBody
-        liftE $ do
+        unless (h == h') $
-            if createActor c == uActor
+            throwE "Activity host doesn't match signature key host"
-                then Right ()
+        unless (createActor c == luActor) $
-                else Left "Activity's actor != Signature key's actor"
+            throwE "Activity's actor != Signature key's actor"
-            if noteAttrib (createObject c) == uActor
+        return (contentType, d)
-                then Right ()
-                else Left "Activity object's actor doesn't match activity's actor"
-        return (contentType, a)
 
 {-
 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."

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
+    { noteId      :: LocalURI
-    , noteAttrib  :: FedURI
+    --, noteAttrib  :: LocalURI
-    , noteTo      :: FedURI
+    --, noteTo      :: FedURI
     , noteReplyTo :: Maybe FedURI
     , noteContent :: Text
     }
 
-instance FromJSON Note where
+parseNote :: Value -> Parser (Text, (Note, LocalURI, FedURI))
-    parseJSON = withObject "Note" $ \ o -> do
+parseNote = withObject "Note" $ \ o -> do
     typ <- o .: "type"
     unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
-        Note
+    (h, id_) <- f2l <$> o .: "id"
-            <$> o .:  "id"
+    fmap (h,) $
-            <*> o .:  "attributedTo"
+        (,,) <$> (Note id_
-            <*> o .:  "to"
+                    <$> o .:? "inReplyTo"
-            <*> 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
+encodeNote :: Text -> Note -> LocalURI -> FedURI -> Encoding
-    toJSON = error "toJSON Note"
+encodeNote host (Note id_ mreply content) attrib to =
-    toEncoding (Note id_ attrib to mreply content) =
     pairs
         $  "type"         .=  ("Note" :: Text)
-            <> "id"           .=  id_
+        <> "id"           .=  l2f host id_
-            <> "attributedTo" .=  attrib
+        <> "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
+parseCreate :: Object -> Parser (Text, Create)
-    parseJSON = withObject "Create" $ \ o -> do
+parseCreate o = do
     typ <- o .: "type"
     unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
-        Create
+    (h, id_) <- f2l <$> o .: "id"
-            <$> o .: "id"
+    luActor <- withHost h $ f2l <$> o .: "actor"
-            <*> o .: "to"
+    (note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object"
-            <*> o .: "actor"
+    unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
-            <*> o .: "object"
+    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
+encodeCreate :: Text -> Create -> Series
-    toJSON = error "toJSON Create"
+encodeCreate host (Create id_ to actor obj)
-    toEncoding (Create id_ to actor obj) =
+    =  "type"     .=     ("Create" :: Text)
-        pairs
+    <> "id"       .=     l2f host id_
-            $  "@context" .= as2context
-            <> "type"     .= ("Create" :: Text)
-            <> "id"       .= id_
     <> "to"       .=     to
-            <> "actor"    .= actor
+    <> "actor"    .=     l2f host actor
-            <> "object"   .= obj
+    <> "object"   `pair` encodeNote host obj actor to
 
 data Activity = CreateActivity Create
 
-instance FromJSON Activity where
+instance ActivityPub Activity where
-    parseJSON = withObject "Activity" $ \ o -> do
+    jsonldContext _ = ContextAS2
-        ctx <- o .: "@context"
+    parseObject o = do
-        if ctx == as2context
-            then return ()
-            else fail "@context isn't the AS2 context URI"
         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
-
+    toSeries host (CreateActivity c) = encodeCreate host c
-instance ToJSON Activity where
-    toJSON = error "toJSON Activity"
-    toEncoding (CreateActivity c) = toEncoding c
 
 typeActivityStreams2 :: ContentType
 typeActivityStreams2 = "application/activity+json"