When a client posts to their outbox, allow only Create Note, not near-any JSON

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:
-            <p>
-              (NOTE: Currently only Ed25519 signatures are supported, which is
-              incompatible with the default RSA-SHA256 used on the Fediverse)
-            <ol>
-              <li>
-                Publish an actor JSON document. That's like a regular
-                ActivityPub actor, except its <var>publicKey</var> object
-                should have one extra field named
-                <code>https://forgefed.angeley.es/ns#algorithm</code> and its
-                value should be
-                <code>https://forgefed.angeley.es/ns#ed25519</code>. The actual
-                key PEM should indeed be an Ed25519 public key, rather than
-                RSA.
-              <li>
-                Prepare an activity JSON document.
-              <li>
-                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).
-            <p>
-              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.
             <p>Last 10 activities posted:
             <ul>
               $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|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderFedURI val}>|]
+    , 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|
-        <p>Enter an activity JSON document and click "Submit" to send it.
-        <p>NOTES:
-        <ul>
-          <li>
-            This is a test page for implementing federation in Vervis. The
-            activities just reach a test page, nothing really gets published or
-            changed otherwise.
-          <li>
-            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.
-          <li>
-            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.
-          <li>
-            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.
-
+        <p>
+          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.
         <form method=POST action=@{OutboxR} enctype=#{enctype}>
           ^{widget}
           <input type=submit>
@@ -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

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

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"