Add activity types Follow, Accept, Reject

src/Vervis/Handler/Inbox.hs

@@ -143,10 +143,10 @@ postInboxR = do
                 _ -> Left "More than one Content-Type given"
         HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
         (h, luActor) <- f2l <$> liftE result
-        d@(Doc h' (CreateActivity c)) <- requireJsonBody
+        d@(Doc h' a) <- requireJsonBody
         unless (h == h') $
             throwE "Activity host doesn't match signature key host"
-        unless (createActor c == luActor) $
+        unless (activityActor a == luActor) $
             throwE "Activity's actor != Signature key's actor"
         return (contentType, d)
 
@@ -218,14 +218,16 @@ postOutboxR = do
                 (h, actor) = f2l $ route2uri $ SharerR shr
                 actorID = renderUrl $ SharerR shr
                 appendPath u t = u { luriPath = luriPath u <> t }
-                activity = CreateActivity Create
+                activity = Activity
-                    { createId     = appendPath actor "/fake-activity"
+                    { activityId       = appendPath actor "/fake-activity"
-                    , createTo     = to
+                    , activityActor    = actor
-                    , createActor  = actor
+                    , activitySpecific = CreateActivity Create
-                    , createObject = Note
+                        { createTo     = to
-                        { noteId      = appendPath actor "/fake-note"
+                        , createObject = Note
-                        , noteReplyTo = Nothing
+                            { noteId      = appendPath actor "/fake-note"
-                        , noteContent = msg
+                            , noteReplyTo = Nothing
+                            , noteContent = msg
+                            }
                         }
                     }
             manager <- getsYesod appHttpManager

src/Web/ActivityPub.hs

@@ -34,7 +34,11 @@ module Web.ActivityPub
 
       -- * Activity
     , Note (..)
+    , Accept (..)
     , Create (..)
+    , Follow (..)
+    , Reject (..)
+    , SpecificActivity (..)
     , Activity (..)
 
       -- * Utilities
@@ -330,24 +334,28 @@ encodeNote host (Note id_ mreply content) attrib to =
         <> "inReplyTo"    .=? mreply
         <> "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
-    { createId     :: LocalURI
+    { createTo     :: FedURI
-    , createTo     :: FedURI
-    , createActor  :: LocalURI
     , createObject :: Note
     }
 
-parseCreate :: Object -> Parser (Text, Create)
+parseCreate :: Object -> Text -> LocalURI -> Parser Create
-parseCreate o = do
+parseCreate o h luActor = 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)
+    return $ Create uTo note
     where
     withHost h a = do
         (h', v) <- a
@@ -355,24 +363,83 @@ parseCreate o = do
             then return v
             else fail "URI host mismatch"
 
-encodeCreate :: Text -> Create -> Series
+encodeCreate :: Text -> LocalURI -> Create -> Series
-encodeCreate host (Create id_ to actor obj)
+encodeCreate host actor (Create to obj)
-    =  "type"     .=     ("Create" :: Text)
+    =  "to"       .=     to
-    <> "id"       .=     l2f host id_
-    <> "to"       .=     to
-    <> "actor"    .=     l2f host actor
     <> "object"   `pair` encodeNote host obj actor to
 
-data Activity = CreateActivity Create
+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
+    , activitySpecific :: SpecificActivity
+    }
 
 instance ActivityPub Activity where
     jsonldContext _ = ContextAS2
     parseObject o = do
-        typ <- o .: "type"
+        (h, id_) <- f2l <$> o .: "id"
-        case typ of
+        actor <- withHost h $ f2l <$> o .: "actor"
-            "Create" -> second CreateActivity <$> parseCreate o
+        (,) h . Activity id_ actor <$> do
-            _        -> fail $ "Unrecognized activity type: " ++ T.unpack typ
+            typ <- o .: "type"
-    toSeries host (CreateActivity c) = encodeCreate host c
+            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 specific)
+        =  "type"  .= activityType specific
+        <> "id"    .= l2f host id_
+        <> "actor" .= l2f host actor
+        <> 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"