forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2019-02-12 11:53:24 +00:00
parent 0731597e1b
commit 754709833a
3 changed files with 136 additions and 143 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

154
src/Vervis/Handler/Inbox.hs
View file

@ -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
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)
]
]
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
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

121
src/Web/ActivityPub.hs
View file

@ -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"