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}
+ #{msg}
+ #{intercalate " | " $ map BC.unpack ctypes}
+ #{decodeUtf8 body}
|]
getSharerInboxR :: ShrIdent -> Handler TypedContent
@@ -142,61 +133,66 @@ getSharerInboxR _ = error "TODO implement getSharerInboxR"
getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectInboxR _ _ = error "TODO implement getProjectInboxR"
-postInboxR :: Handler ()
-postInboxR = do
+postSharerInboxR :: ShrIdent -> Handler ()
+postSharerInboxR shrRecip = do
federation <- getsYesod $ appFederation . appSettings
unless federation badMethod
+ contentTypes <- lookupHeaders "Content-Type"
+ body <- requireJsonBody
now <- liftIO getCurrentTime
- r <- runExceptT $ getActivity now
- case r of
- Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) ->
- forkHandler (handleWorkerError now ct d) $ do
- (msg, stored) <- handleInboxActivity raw h iid rsid a
- if stored
- then recordUsed now msg
- else recordUnused now ct d msg
- Left e -> do
- recordError now e
- notAuthenticated
+ result <- go now contentTypes body
+ recordActivity now result contentTypes body
+ case result of
+ Left _ -> sendResponseStatus badRequest400 ()
+ Right _ -> return ()
where
- liftE = ExceptT . pure
- 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
+ go now ctypes (WithValue raw (Doc hActivity activity)) = runExceptT $ do
+ verifyContentType
+ HttpSigVerResult result <-
+ ExceptT $
+ first (T.pack . displayException) <$>
+ verifyRequestSignature now
+ ActorDetail uSender iid _raid <- ExceptT $ pure $ first T.pack result
+ let (hSender, luSender) = f2l uSender
+ unless (hSender == hActivity) $
+ throwE $ T.concat
+ [ "Activity host <", hActivity
+ , "> doesn't match signature key host <", hSender, ">"
+ ]
+ unless (activityActor activity == luSender) $
+ throwE $ T.concat
+ [ "Activity's actor <"
+ , renderFedURI $ l2f hActivity $ activityActor activity
+ , "> != Signature key's actor <", renderFedURI uSender, ">"
+ ]
+ handleSharerInbox now shrRecip iid raw activity
+ where
+ verifyContentType =
+ case ctypes of
+ [] -> throwE "Content-Type not specified"
+ [x] | x == typeAS -> return ()
+ | x == typeAS2 -> return ()
+ | otherwise ->
+ throwE $ "Not a recognized AP Content-Type: " <>
+ case decodeUtf8' x of
+ Left _ -> T.pack (show x)
+ Right t -> t
+ _ -> throwE "More than one Content-Type specified"
+ where
+ typeAS = "application/activity+json"
+ typeAS2 =
+ "application/ld+json; \
+ \profile=\"https://www.w3.org/ns/activitystreams\""
+ recordActivity now result contentTypes body = do
acts <- getsYesod appActivities
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
- let vec' = (now, item) `V.cons` vec
+ let msg = either id id result
+ formattedBody = encodePretty $ wvRaw body
+ item = ActivityReport now msg contentTypes formattedBody
+ vec' = 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, RemoteActorId)))
- getActivity now = do
- contentType <- do
- ctypes <- lookupHeaders "Content-Type"
- liftE $ case ctypes of
- [] -> Left "Content-Type not specified"
- [x] -> case x of
- "application/activity+json" -> Right x
- "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x
- _ -> Left "Unknown Content-Type"
- _ -> Left "More than one Content-Type given"
- HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
- (h, luActor) <- f2l . actorDetailId <$> liftE result
- ActorDetail uActor iid rsid <- liftE result
- let (h, luActor) = f2l uActor
- wv@(WithValue _ (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, (wv, (iid, rsid)))
-
-postSharerInboxR :: ShrIdent -> Handler ()
-postSharerInboxR _ = error "TODO implement postSharerInboxR"
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR _ _ = error "TODO implement postProjectInboxR"
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 25fd72a..2422c67 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -245,6 +245,14 @@ changes =
"errorSince"
-- 59
, addEntities model_2019_04_12
+ -- 60
+ , addEntities model_2019_04_22
+ -- 61
+ , addFieldRefRequiredEmpty "RemoteMessage" "create" "RemoteActivity"
+ -- 62
+ , removeField "RemoteMessage" "raw"
+ -- 63
+ , removeEntity "RemoteRawObject"
]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 807feeb..56c05da 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@@ -37,6 +37,7 @@ module Vervis.Migration.Model
, Ticket2019
, model_2019_04_11
, model_2019_04_12
+ , model_2019_04_22
)
where
@@ -98,3 +99,6 @@ model_2019_04_11 = $(schema "2019_04_11")
model_2019_04_12 :: [Entity SqlBackend]
model_2019_04_12 = $(schema "2019_04_12")
+
+model_2019_04_22 :: [Entity SqlBackend]
+model_2019_04_22 = $(schema "2019_04_22")