Last 10 activities posted:
#{BC.unpack ct}
#{decodeUtf8 o}
+ #{displayException e}
+ $of ActivityReportUsed msg
+ #{msg}
+ $of ActivityReportUnused ct o msg
+ #{BC.unpack ct}
+ #{decodeUtf8 o}
+ #{msg}
|]
postInboxR :: Handler ()
postInboxR = do
now <- liftIO getCurrentTime
r <- runExceptT $ getActivity now
- let item = (now, second (second encodePretty) r)
- acts <- getsYesod appActivities
- liftIO $ atomically $ modifyTVar' acts $ \ vec ->
- let vec' = item `V.cons` vec
- in if V.length vec' > 10
- then V.init vec'
- else vec'
case r of
- Right _ -> return ()
- Left _ -> notAuthenticated
+ Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) ->
+ forkHandler (handleWorkerError now ct d) $ do
+ (msg, stored) <- handleActivity raw h iid rsid a
+ if stored
+ then recordUsed now msg
+ else recordUnused now ct d msg
+ Left e -> do
+ recordError now e
+ notAuthenticated
where
liftE = ExceptT . pure
- getActivity :: UTCTime -> ExceptT String Handler (ContentType, Doc Activity)
+ handleWorkerError now ct d e = do
+ logError $ "postInboxR worker error: " <> T.pack (displayException e)
+ recordActivity now $ ActivityReportWorkerError ct (encodePretty d) e
+ recordActivity now item = do
+ acts <- getsYesod appActivities
+ liftIO $ atomically $ modifyTVar' acts $ \ vec ->
+ let vec' = (now, item) `V.cons` vec
+ in if V.length vec' > 10
+ then V.init vec'
+ else vec'
+ recordUsed now msg = recordActivity now $ ActivityReportUsed msg
+ recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg
+ recordError now e = recordActivity now $ ActivityReportHandlerError e
+ getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteSharerId)))
getActivity now = do
contentType <- do
ctypes <- lookupHeaders "Content-Type"
@@ -143,12 +167,14 @@ postInboxR = do
_ -> Left "More than one Content-Type given"
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
(h, luActor) <- f2l . actorDetailId <$> liftE result
- d@(Doc h' a) <- requireJsonBody
+ ActorDetail uActor iid rsid <- liftE result
+ let (h, luActor) = f2l uActor
+ wv@(WithValue v (Doc h' a)) <- requireJsonBody
unless (h == h') $
throwE "Activity host doesn't match signature key host"
unless (activityActor a == luActor) $
throwE "Activity's actor != Signature key's actor"
- return (contentType, d)
+ return (contentType, (wv, (iid, rsid)))
{-
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 08fb209..b76c6c1 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@@ -35,6 +35,7 @@ where
import Prelude
+import Data.Aeson (Value)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Time (UTCTime)
diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs
index 8206df2..9f68b7a 100644
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@@ -28,6 +28,7 @@ import Yesod.Auth.Account (PersistUserCredentials (..))
import Crypto.PublicVerifKey
import Database.Persist.EmailAddress
import Database.Persist.Graph.Class
+import Database.Persist.Postgresql.JSON ()
import Network.FedURI (FedURI, LocalURI)
import Vervis.Model.Group
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 9afa62a..ff9a462 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -316,11 +316,13 @@ instance ActivityPub Actor where
<> "publicKey" `pair` encodePublicKeySet host pkeys
data Note = Note
- { noteId :: LocalURI
+ { noteId :: LocalURI
--, noteAttrib :: LocalURI
--, noteTo :: FedURI
- , noteReplyTo :: Maybe FedURI
- , noteContent :: Text
+ , noteReplyTo :: Maybe FedURI
+ , noteContext :: Maybe FedURI
+ , notePublished :: Maybe UTCTime
+ , noteContent :: Text
}
parseNote :: Value -> Parser (Text, (Note, LocalURI))
@@ -331,6 +333,8 @@ parseNote = withObject "Note" $ \ o -> do
fmap (h,) $
(,) <$> (Note id_
<$> o .:? "inReplyTo"
+ <*> o .:? "context"
+ <*> o .:? "published"
<*> o .: "content"
)
<*> withHost h (f2l <$> o .: "attributedTo")
@@ -342,12 +346,14 @@ parseNote = withObject "Note" $ \ o -> do
else fail "URI host mismatch"
encodeNote :: Text -> Note -> LocalURI -> Encoding
-encodeNote host (Note id_ mreply content) attrib =
+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
diff --git a/vervis.cabal b/vervis.cabal
index 1301209..b9972af 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -111,6 +111,7 @@ library
Vervis.Content
Vervis.Darcs
Vervis.Discussion
+ Vervis.Federation
Vervis.Field.Key
Vervis.Field.Person
Vervis.Field.Project