From 754709833adbc0c1dad7294f8a6b697dd4517b11 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 12 Feb 2019 11:53:24 +0000 Subject: [PATCH] When a client posts to their outbox, allow only Create Note, not near-any JSON --- src/Vervis/Handler/Inbox.hs | 154 +++++++++++++++--------------------- src/Vervis/Migration.hs | 4 +- src/Web/ActivityPub.hs | 121 ++++++++++++++++------------ 3 files changed, 136 insertions(+), 143 deletions(-) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 995f36e..e02e204 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -34,7 +34,6 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Data.Aeson -import Data.Aeson.Encode.Pretty.ToEncoding import Data.Bifunctor (first, second) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) @@ -50,15 +49,16 @@ import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) import Network.HTTP.Types.Header (hDate, hHost) import Text.Blaze.Html (Html) +import Text.Shakespeare.I18N (RenderMessage) import UnliftIO.Exception (try) import Yesod.Auth (requireAuth) -import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml) +import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml, HandlerSite) import Yesod.Core.Content (TypedContent) import Yesod.Core.Json (requireJsonBody) import Yesod.Core.Handler -import Yesod.Form.Fields (Textarea (..), textareaField) -import Yesod.Form.Functions (areq, checkMMap, runFormPost, renderDivs) -import Yesod.Form.Types (Field, Enctype, FormResult (..)) +import Yesod.Form.Fields (Textarea (..), textField, textareaField) +import Yesod.Form.Functions +import Yesod.Form.Types import Yesod.Persist.Core (runDB, get404) import qualified Data.ByteString.Char8 as BC (unpack) @@ -74,8 +74,10 @@ import Yesod.HttpSignature (verifyRequestSignature) import qualified Network.HTTP.Signature as S (Algorithm (..)) +import Data.Aeson.Encode.Pretty.ToEncoding import Network.FedURI import Web.ActivityPub +import Yesod.Auth.Unverified import Vervis.ActorKey import Vervis.Foundation @@ -91,32 +93,9 @@ getInboxR = do Welcome to the ActivityPub inbox test page! It's the beginning of federation support in Vervis. Currently POSTing activities doesn't do anything, they're just verified and the results are - displayed on this page. Here's how to POST an activity - successfully: -

- (NOTE: Currently only Ed25519 signatures are supported, which is - incompatible with the default RSA-SHA256 used on the Fediverse) -

    -
  1. - Publish an actor JSON document. That's like a regular - ActivityPub actor, except its publicKey object - should have one extra field named - https://forgefed.angeley.es/ns#algorithm and its - value should be - https://forgefed.angeley.es/ns#ed25519. The actual - key PEM should indeed be an Ed25519 public key, rather than - RSA. -
  2. - Prepare an activity JSON document. -
  3. - POST it to this page's URL, with an HTTP signature in a - Signature header, and use at least the headers Host, Date and - (request-target). -

    - I'm aware these instructions aren't exactly clear and - self-contained. Soon I'll either clarify them or further - development will make things easier. In particular, by using one - Vervis instance to POST an activity to another Vervis instance. + displayed on this page. To test, go to another Vervis instance's + outbox page, submit an activity, and come back here to see + results.

    Last 10 activities posted:

      $forall (time, result) <- acts @@ -188,54 +167,41 @@ postInboxR = do _ -> Left "Activity's object isn't a JSON object" return (contentType, o) +{- jsonField :: (FromJSON a, ToJSON a) => Field Handler a jsonField = checkMMap fromTextarea toTextarea textareaField where toTextarea = Textarea . TL.toStrict . encodePrettyToLazyText fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea +-} -activityForm :: Form Activity -activityForm = renderDivs $ areq jsonField "" $ Just defval +fedUriField + :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI +fedUriField = Field + { fieldParse = parseHelper $ \ t -> + case parseFedURI t of + Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t + Right u -> Right u + , fieldView = \theId name attrs val isReq -> + [whamlet||] + , fieldEnctype = UrlEncoded + } + +activityForm :: Form (FedURI, Text) +activityForm = renderDivs $ (,) + <$> areq fedUriField "To" (Just defto) + <*> areq textField "Message" (Just defmsg) where - defval = Activity - { activityTo = FedURI "forge.angeley.es" "/p/aviva" "" - , activityJSON = M.fromList - [ "@context" .= ("https://www.w3.org/ns/activitystreams" :: Text) - , "type" .= ("Create" :: Text) - , "object" .= object - [ "type" .= ("Note" :: Text) - , "content" .= ("Hi! Nice to meet you :)" :: Text) - , "to" .= ("https://forge.angeley.es/p/luke" :: Text) - ] - ] - } + defto = FedURI "forge.angeley.es" "/p/fr33" "" + defmsg = "Hi! Nice to meet you :)" activityWidget :: Widget -> Enctype -> Widget activityWidget widget enctype = [whamlet| -

      Enter an activity JSON document and click "Submit" to send it. -

      NOTES: -

        -
      • - This is a test page for implementing federation in Vervis. The - activities just reach a test page, nothing really gets published or - changed otherwise. -
      • - The activity itself just needs to be valid JSON and pass some sanity - checks. It isn't verified to look like an ActivityPub activity with - ActivityStreams2 properties. So, you can probably post weird things - and they will pass. -
      • - The generated HTTP Signature uses Ed25519, while AFAIK the - Fediverse generally uses RSA, specifically RSA-PKCS1.5 (i.e. not - PSS) with SHA-256. In other words, send the activities to another - Vervis instance, not to Mastodon etc., because the latter won't - accept them. -
      • - Addressing is determined by the "to" field, which has to be a - single actor URL. The fields "cc" and "bcc" are ignored at the - moment. - +

        + This is a federation test page. Provide a recepient actor URI and + message text, and a Create activity creating a new Note will be sent + to the destination server.

        ^{widget} @@ -246,6 +212,12 @@ getOutboxR = do ((_result, widget), enctype) <- runFormPost activityForm defaultLayout $ activityWidget widget enctype +route2uri' :: (Route App -> Text) -> Route App -> FedURI +route2uri' renderUrl r = + case parseFedURI $ renderUrl r of + Left e -> error e + Right u -> u + postOutboxR :: Handler Html postOutboxR = do ((result, widget), enctype) <- runFormPost activityForm @@ -253,20 +225,28 @@ postOutboxR = do case result of FormMissing -> setMessage "Field(s) missing" FormFailure _l -> setMessage "Invalid input, see below" - FormSuccess (Activity to act) -> do - Entity _pid person <- requireAuth - let sid = personIdent person - sharer <- runDB $ get404 sid - let shr = sharerIdent sharer + FormSuccess (to, msg) -> do + shr <- do + Entity _pid person <- requireVerifiedAuth + sharer <- runDB $ get404 $ personIdent person + return $ sharerIdent sharer renderUrl <- getUrlRender - let actorID = renderUrl $ PersonR shr - actID = actorID <> "/fake/1" - objID = actorID <> "/fake/2" - keyID1 = renderUrl ActorKey1R - keyID2 = renderUrl ActorKey2R - updateObj (Object obj) = Object $ M.insert "attributedTo" (String actorID) $ M.insert "id" (String objID) obj - updateObj v = v - updateAct = M.adjust updateObj "object" . M.insert "actor" (String actorID) . M.insert "id" (String actID) + let route2uri = route2uri' renderUrl + actor = route2uri $ PersonR shr + actorID = renderUrl $ PersonR shr + appendPath u t = u { furiPath = furiPath 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 + } + } manager <- getsYesod appHttpManager eres <- httpGetAP manager to case eres of @@ -281,10 +261,10 @@ postOutboxR = do (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys let (keyID, akey) = if new1 - then (keyID1, akey1) - else (keyID2, akey2) + then (renderUrl ActorKey1R, akey1) + else (renderUrl ActorKey2R, akey2) sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) - eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID (updateAct act) + eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID 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." @@ -295,11 +275,7 @@ getActorKey choose route = do actorKey <- liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< getsYesod appActorKeys - renderUrl <- getUrlRender - let route2uri r = - case parseFedURI $ renderUrl r of - Left e -> error e - Right u -> u + route2uri <- route2uri' <$> getUrlRender selectRep $ provideAP PublicKey { publicKeyId = route2uri route diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 36cb61a..6ac0730 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -156,8 +156,8 @@ changes = -- 35 , unchecked $ lift $ do l <- E.select $ E.from $ \ (j `E.LeftOuterJoin` - jcu `E.LeftOuterJoin` - jca) -> do + jcu `E.LeftOuterJoin` + jca) -> do E.on $ E.just (j E.^. Project2018Id) E.==. jca E.?. ProjectCollabAnon2018Project diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 8e2e8d6..59ba0b5 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -25,10 +25,8 @@ module Web.ActivityPub , Actor (..) -- * Activity - -- - -- Very basic activity document which is just general JSON with some - -- basic checks. 'FromJSON' instance for receiving POSTs, and 'ToJSON' - -- instance for delivering to other servers. + , Note (..) + , Create (..) , Activity (..) -- * Utilities @@ -46,7 +44,7 @@ import Prelude import Control.Applicative ((<|>), optional) import Control.Exception (Exception, displayException, try) -import Control.Monad ((<=<)) +import Control.Monad (unless, (<=<)) import Control.Monad.IO.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Writer (Writer) @@ -221,62 +219,81 @@ instance ToJSON Actor where <> "inbox" .= inbox <> "publicKey" .= pkeys --- | This may seem trivial, but it exists for a good reason: In the 'FromJSON' --- instance we perform sanity checks. We just don't need to remember the fields --- after checking, so we don't unnecessarily add them as fields. We just keep --- the _to_ field, which tells us who the target actor is (we currently support --- only the _to_ field, and it has to be a single URI, and that URI has to be --- an actor, not a collection). The 'Object' we keep is simply for encoding --- back to JSON. I suppose that's actually silly, we could just keep the actual --- ByteString, but I guess it's okay for now, and it happens to guarantee the --- JSON we POST has no extra whitespace. -data Activity = Activity - { activityTo :: FedURI - , activityJSON :: Object +data Note = Note + { noteId :: FedURI + , noteAttrib :: FedURI + , 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" + +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 + +data Create = Create + { createId :: FedURI + , createTo :: FedURI + , createActor :: FedURI + , 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" + +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 + +data Activity = CreateActivity Create + instance FromJSON Activity where parseJSON = withObject "Activity" $ \ o -> do - c <- o .: "@context" - if c == as2context + ctx <- o .: "@context" + if ctx == as2context then return () else fail "@context isn't the AS2 context URI" - case M.lookup "id" o of - Nothing -> return () - Just _ -> fail "id is provided; let the server set it" - case M.lookup "type" o of - Nothing -> fail "Activity type missing" - Just (String _) -> return () - Just _ -> fail "Activity type isn't a string" - case M.lookup "actor" o of - Nothing -> return () - Just _ -> fail "actor is provided; let the server set it" - mto <- case M.lookup "object" o of - Nothing -> return Nothing - Just v -> case v of - String _ -> return Nothing - Object obj -> do - case M.lookup "id" obj of - Nothing -> return () - Just _ -> fail "object's id is provided; let the server set it" - case M.lookup "type" obj of - Nothing -> fail "Activity object type missing" - Just (String _) -> return () - Just _ -> fail "Activity object type isn't a string" - case M.lookup "actor" o <|> M.lookup "attributedTo" o of - Nothing -> return () - Just _ -> fail "attribution is provided; let the server set it" - obj .:? "to" - _ -> fail "Activity object isn't JSON string or object" - mto2 <- o .:? "to" - to <- case mto <|> mto2 of - Nothing -> fail "to not provided" - Just u -> return u - return $ Activity to o + typ <- o .: "type" + let v = Object o + case typ of + "Create" -> CreateActivity <$> parseJSON v + _ -> fail $ "Unrecognized activity type: " ++ T.unpack typ instance ToJSON Activity where toJSON = error "toJSON Activity" - toEncoding = toEncoding . activityJSON + toEncoding (CreateActivity c) = toEncoding c typeActivityStreams2 :: ContentType typeActivityStreams2 = "application/activity+json"