Federation test outbox page with form for entering JSON

config/routes

@@ -25,6 +25,7 @@
 -- ----------------------------------------------------------------------------
 
 /inbox                                       InboxR            GET POST
+/outbox                                      OutboxR           GET POST
 
 -- ----------------------------------------------------------------------------
 -- Current user

src/Data/Aeson/Encode/Pretty/ToEncoding.hs

@@ -0,0 +1,46 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | A replacement for "Data.Aeson.Encode.Pretty" which uses 'toEncoding'
+-- instead of 'toJSON'.
+module Data.Aeson.Encode.Pretty.ToEncoding
+    ( encodePretty
+    , encodePrettyToLazyText
+    , encodePrettyToTextBuilder
+    )
+where
+
+import Prelude
+
+import Data.Aeson (ToJSON, Value, encode, decode)
+import Data.ByteString.Lazy (ByteString)
+import Data.Maybe (fromJust)
+import Data.Text.Lazy (Text)
+import Data.Text.Lazy.Builder (Builder, fromLazyText)
+import Data.Text.Lazy.Encoding (decodeUtf8)
+
+import qualified Data.Aeson.Encode.Pretty as P (encodePretty)
+
+encodePretty :: ToJSON a => a -> ByteString
+encodePretty = P.encodePretty . fromJust . decodeValue . encode
+    where
+    decodeValue :: ByteString -> Maybe Value
+    decodeValue = decode
+
+encodePrettyToLazyText :: ToJSON a => a -> Text
+encodePrettyToLazyText = decodeUtf8 . encodePretty
+
+encodePrettyToTextBuilder :: ToJSON a => a -> Builder
+encodePrettyToTextBuilder = fromLazyText . encodePrettyToLazyText

src/Network/HTTP/Client/Conduit/ActivityPub.hs

@@ -0,0 +1,104 @@
+{- This file is part of Vervis.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - This file includes HTTP client functions for using http-conduit to receive
+ - ActivityPub JSON objects. The functions here are simply minor adaptations of
+ - functions from the http-conduit package, so technically this module inherits
+ - that package's license and isn't CC0 like most Vervis code.
+ -
+ - Copyright 2010, Michael Snoyman. All rights reserved.
+ - Includes code written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - Redistribution and use in source and binary forms, with or without
+ - modification, are permitted provided that the following conditions are met:
+ -
+ - * Redistributions of source code must retain the above copyright notice,
+ -   this list of conditions and the following disclaimer.
+ -
+ - * Redistributions in binary form must reproduce the above copyright notice,
+ -   this list of conditions and the following disclaimer in the documentation
+ -   and/or other materials provided with the distribution.
+ -
+ - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS
+ - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+ - OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
+ - NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+ - OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ - NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
+ - EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ -}
+
+module Network.HTTP.Client.Conduit.ActivityPub
+    ( httpAPEither
+    , httpAP
+    )
+where
+
+import Prelude
+
+import Control.Exception (throwIO, bracket)
+import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
+import Data.Aeson (FromJSON, Result (..), fromJSON, json')
+import Data.Conduit (runConduit, (.|), ConduitM)
+import Data.ByteString (ByteString)
+import Data.Conduit.Attoparsec (sinkParserEither)
+import Data.Void (Void)
+import Network.HTTP.Client
+import Network.HTTP.Client.Conduit (bodyReaderSource)
+import Network.HTTP.Simple
+import Network.HTTP.Types.Header (hAccept)
+
+-- | Like 'httpSink' from @http-conduit@, except it takes a 'Manager' instead
+-- of using a global one.
+httpSink'
+    :: MonadUnliftIO m
+    => Manager
+    -> Request
+    -> (Response () -> ConduitM ByteString Void m a)
+    -> m a
+httpSink' man req sink = withRunInIO $ \ run ->
+    bracket
+        (responseOpen req man)
+        responseClose
+        $ \ res -> run
+            $ runConduit
+            $ bodyReaderSource (getResponseBody res)
+           .| sink (fmap (const ()) res)
+
+-- | Like 'httpJSONEither' from @http-conduit@, except:
+--
+-- * It takes a 'Manager' instead of using a global one
+-- * It sets the _Accept_ header to the ActivityPub one, not application/json
+httpAPEither
+    :: (MonadIO m, FromJSON a)
+    => Manager
+    -> Request
+    -> m (Response (Either JSONException a))
+httpAPEither man req = liftIO $ httpSink' man req' sink
+    where
+    ct = "application/ld+json; \
+         \profile=\"https://www.w3.org/ns/activitystreams\""
+    req' = addRequestHeader hAccept ct req
+    sink orig = fmap (\ x -> fmap (const x) orig) $ do
+        eres1 <- sinkParserEither json'
+        case eres1 of
+            Left e -> return $ Left $ JSONParseException req' orig e
+            Right value ->
+                case fromJSON value of
+                    Error e ->
+                        return $ Left $
+                            JSONConversionException
+                                req'
+                                (fmap (const value) orig)
+                                e
+                    Success x -> return $ Right x
+
+-- | Like 'httpAPEither', except if JSON parsing fails, a 'JSONException' is
+-- thrown.
+httpAP :: (MonadIO m, FromJSON a) => Manager -> Request -> m (Response a)
+httpAP man req =
+    liftIO $ httpAPEither man req >>= traverse (either throwIO return)

src/Vervis/ActivityPub.hs

@@ -1,164 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ Copying is an act of love. Please copy, reuse and share.
- -
- - The author(s) have dedicated all copyright and related and neighboring
- - rights to this software to the public domain worldwide. This software is
- - distributed without any warranty.
- -
- - You should have received a copy of the CC0 Public Domain Dedication along
- - with this software. If not, see
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-module Vervis.ActivityPub
-    ( ActorType (..)
-    , Algorithm (..)
-    , PublicKey (..)
-    , Actor (..)
-    , provideAP
-    )
-where
-
-import Prelude
-
-import Control.Monad.Trans.Writer (Writer)
-import Data.Aeson
-import Data.Aeson.Types (Parser)
-import Data.PEM
-import Data.Semigroup (Endo)
-import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8)
-import Network.URI
-import Yesod.Core.Content (ContentType)
-import Yesod.Core.Handler (ProvidedRep, provideRepType)
-
-import qualified Data.Text as T (unpack)
-import qualified Data.Vector as V (fromList)
-
-frg :: Text
-frg = "https://forgefed.angeley.es/ns#"
-
-context :: Value
-context = Array $ V.fromList
-    [ String "https://www.w3.org/ns/activitystreams"
-    , String "https://w3id.org/security/v1"
-    ]
-
-parseURI' :: Text -> Parser URI
-parseURI' t =
-    case parseURI $ T.unpack t of
-        Nothing -> fail "Invalid absolute URI"
-        Just u ->
-            if uriScheme u == "https:"
-                then return u
-                else fail "URI scheme isn't https"
-
-renderURI :: URI -> String
-renderURI u = uriToString id u ""
-
-data ActorType = ActorTypePerson | ActorTypeOther Text
-
-instance FromJSON ActorType where
-    parseJSON = withText "ActorType" $ \ t ->
-        pure $ case t of
-            "Person" -> ActorTypePerson
-            _        -> ActorTypeOther t
-
-instance ToJSON ActorType where
-    toJSON = error "toJSON ActorType"
-    toEncoding at =
-        toEncoding $ case at of
-            ActorTypePerson  -> "Person"
-            ActorTypeOther t -> t
-
-data Algorithm = AlgorithmEd25519 | AlgorithmOther Text
-
-instance FromJSON Algorithm where
-    parseJSON = withText "Algorithm" $ \ t ->
-        pure $ if t == frg <> "ed25519"
-            then AlgorithmEd25519
-            else AlgorithmOther t
-
-instance ToJSON Algorithm where
-    toJSON = error "toJSON Algorithm"
-    toEncoding algo =
-        toEncoding $ case algo of
-            AlgorithmEd25519 -> frg <> "ed25519"
-            AlgorithmOther t -> t
-
-data PublicKey = PublicKey
-    { publicKeyId    :: URI
-    , publicKeyOwner :: URI
-    , publicKeyPem   :: PEM
-    , publicKeyAlgo  :: Maybe Algorithm
-    }
-
-instance FromJSON PublicKey where
-    parseJSON = withObject "PublicKey" $ \ o ->
-        PublicKey
-            <$> (parseURI' =<< o .: "id")
-            <*> (parseURI' =<< o .: "owner")
-            <*> (parsePEM =<< o .: "publicKeyPem")
-            <*> o .:? (frg <> "algorithm")
-        where
-        parsePEM t =
-            case pemParseBS $ encodeUtf8 t of
-                Left e   -> fail $ "PEM parsing failed: " ++ e
-                Right xs ->
-                    case xs of
-                        []  -> fail "Empty PEM"
-                        [x] -> pure x
-                        _   -> fail "Multiple PEM sections"
-
-instance ToJSON PublicKey where
-    toJSON = error "toJSON PublicKey"
-    toEncoding (PublicKey id_ owner pem malgo) =
-        pairs
-            $  "id"           .= renderURI id_
-            <> "owner"        .= renderURI owner
-            <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
-            <> maybe mempty ((frg <> "algorithm") .=) malgo
-
-data Actor = Actor
-    { actorId        :: URI
-    , actorType      :: ActorType
-    , actorUsername  :: Text
-    , actorInbox     :: URI
-    , actorPublicKey :: PublicKey
-    }
-
-instance FromJSON Actor where
-    parseJSON = withObject "Actor" $ \ o ->
-        Actor
-            <$> (parseURI' =<< o .: "id")
-            <*> o .: "type"
-            <*> o .: "preferredUsername"
-            <*> (parseURI' =<< o .: "inbox")
-            <*> o .: "publicKey"
-
-instance ToJSON Actor where
-    toJSON = error "toJSON Actor"
-    toEncoding (Actor id_ typ username inbox pkey) =
-        pairs
-            $  "@context"          .= context
-            <> "id"                .= renderURI id_
-            <> "type"              .= typ
-            <> "preferredUsername" .= username
-            <> "inbox"             .= renderURI inbox
-            <> "publicKey"         .= pkey
-
-typeActivityStreams2 :: ContentType
-typeActivityStreams2 = "application/activity+json"
-
-typeActivityStreams2LD :: ContentType
-typeActivityStreams2LD =
-    "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\""
-
-provideAP :: (Monad m, ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
-provideAP v = do
-    let enc = toEncoding v
-    provideRepType typeActivityStreams2   $ return enc
-    provideRepType typeActivityStreams2LD $ return enc

src/Vervis/ActorKey.hs

@@ -18,6 +18,7 @@ module Vervis.ActorKey
     , generateActorKey
     , actorKeyRotator
     , actorKeyPublicBin
+    , actorKeySign
     )
 where
 
@@ -27,11 +28,12 @@ import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM (TVar, writeTVar)
 import Control.Monad (forever)
 import Control.Monad.STM (atomically)
-import Crypto.PubKey.Ed25519
+import Crypto.PubKey.Ed25519 hiding (Signature)
 import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
 import Data.Time.Interval (TimeInterval, microseconds)
 import Data.PEM
+import Network.HTTP.Signature (Signature (..))
 
 -- | Ed25519 signing key, we generate it on the server and use for signing. We
 -- also make its public key available to whoever wishes to verify our
@@ -155,3 +157,6 @@ actorKeyRotator interval key =
 -- probably okay because the PEM rendering is hopefully trivial.
 actorKeyPublicBin :: ActorKey -> ByteString
 actorKeyPublicBin = convert . actorKeyPublic
+
+actorKeySign :: ActorKey -> ByteString -> Signature
+actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub

src/Vervis/Foundation.hs

@@ -27,8 +27,9 @@ import Data.Time.Interval (TimeInterval, fromTimeUnit, toTimeUnit)
 import Data.Time.Units (Second, Minute, Day)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Graphics.SVGFonts.ReadFont (PreparedFont)
-import Network.HTTP.Client (Manager, HttpException, requestFromURI)
+import Network.HTTP.Client (Manager, HttpException, requestFromURI, responseBody)
-import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
+import Network.HTTP.Simple (httpJSONEither, setRequestManager, addRequestHeader)
+import Network.HTTP.Types.Header (hHost)
 import Network.URI (URI (uriFragment), parseURI)
 import Text.Shakespeare.Text (textFile)
 import Text.Hamlet          (hamletFile)
@@ -46,8 +47,6 @@ import qualified Yesod.Core.Unsafe as Unsafe
 import Data.Text as T (pack, intercalate, concat)
 --import qualified Data.Text.Encoding as TE
 
-import Text.Email.Local
-
 import Network.HTTP.Signature hiding (Algorithm (..))
 import Yesod.Auth.Unverified
 import Yesod.Auth.Unverified.Creds
@@ -56,8 +55,11 @@ import Yesod.Mail.Send
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
+import Web.ActivityPub
+
+import Text.Email.Local
 import Text.Jasmine.Local (discardm)
-import Vervis.ActivityPub
+
 import Vervis.ActorKey (ActorKey)
 import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn)
 import Vervis.Model.Group
@@ -170,6 +172,8 @@ instance Yesod App where
             | a == resendVerifyR           -> personFromResendForm
         (AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
 
+        (OutboxR                   , True) -> personAny
+
         (GroupsR                   , True) -> personAny
         (GroupNewR                 , _   ) -> personAny
         (GroupMembersR grp         , True) -> groupAdmin grp
@@ -563,7 +567,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
 instance YesodHttpSig App where
     data HttpSigVerResult App = HttpSigVerResult (Either String URI)
-    httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"]
+    httpSigVerHeaders = const [hRequestTarget, hHost]
     httpSigVerSeconds =
         fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
         where
@@ -580,16 +584,8 @@ instance YesodHttpSig App where
             Nothing  -> Left "keyId in Sig header isn't a valid absolute URI"
             Just uri -> Right uri
         manager <- getsYesod appHttpManager
-        response <-
+        actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
-            ExceptT $ first (displayException :: HttpException -> String) <$>
-                (try $
-                    httpJSONEither .
-                    addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" .
-                    setRequestManager manager
-                        =<< requestFromURI u
-                )
         ExceptT . pure $ do
-            actor <- first displayException $ getResponseBody response
             let uActor = u { uriFragment = "" }
             if uActor == actorId actor
                 then Right ()
@@ -632,6 +628,7 @@ instance YesodBreadcrumbs App where
         RobotsR                          -> ("", Nothing)
 
         InboxR                           -> ("Inbox", Nothing)
+        OutboxR                          -> ("Outbox", Nothing)
 
         HomeR                            -> ("Home", Nothing)
         ResendVerifyEmailR               -> ( "Resend verification email"

src/Vervis/Handler/Inbox.hs

@@ -16,6 +16,8 @@
 module Vervis.Handler.Inbox
     ( getInboxR
     , postInboxR
+    , getOutboxR
+    , postOutboxR
     )
 where
 
@@ -29,29 +31,39 @@ import Control.Monad.STM (atomically)
 import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
 import Crypto.Error (CryptoFailable (..))
 import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
-import Data.Aeson (Value (String, Object))
+import Data.Aeson
-import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.Aeson.Encode.Pretty.ToEncoding
 import Data.Bifunctor (first, second)
 import Data.HashMap.Strict (HashMap)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.PEM (pemContent)
 import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Interval (TimeInterval, toTimeUnit)
 import Data.Time.Units (Second)
+import Database.Persist (Entity (..))
 import Network.HTTP.Client (Manager, HttpException, requestFromURI)
 import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
-import Network.URI (URI (uriFragment), parseURI)
+import Network.HTTP.Types.Header (hDate, hHost)
+import Network.URI
 import Text.Blaze.Html (Html)
 import UnliftIO.Exception (try)
-import Yesod.Core (ContentType, defaultLayout, whamlet)
+import Yesod.Auth (requireAuth)
+import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml)
 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.Persist.Core (runDB, get404)
 
 import qualified Data.ByteString.Char8 as BC (unpack)
 import qualified Data.CaseInsensitive as CI (mk)
-import qualified Data.HashMap.Strict as M (lookup)
+import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
-import qualified Data.Text as T (unpack)
+import qualified Data.Text as T (pack, unpack)
+import qualified Data.Text.Lazy as TL (toStrict)
 import qualified Data.Vector as V (length, cons, init)
 import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
 
@@ -60,8 +72,11 @@ import Yesod.HttpSignature (verifyRequestSignature)
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
-import Vervis.ActivityPub
+import Web.ActivityPub
-import Vervis.Foundation (App (..), HttpSigVerResult (..), Handler)
+
+import Vervis.ActorKey (actorKeySign)
+import Vervis.Foundation
+import Vervis.Model
 import Vervis.Settings (AppSettings (appHttpSigTimeLimit))
 
 getInboxR :: Handler Html
@@ -169,3 +184,105 @@ postInboxR = do
                         _ -> Left "Activity actor isn't a JSON string"
                 _ -> 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 =
+            URI "https:"
+                (Just $ URIAuth "" "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)
+                ]
+            ]
+        }
+
+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.
+
+        <form method=POST action=@{OutboxR} enctype=#{enctype}>
+          ^{widget}
+          <input type=submit>
+    |]
+
+getOutboxR :: Handler Html
+getOutboxR = do
+    ((_result, widget), enctype) <- runFormPost activityForm
+    defaultLayout $ activityWidget widget enctype
+
+postOutboxR :: Handler Html
+postOutboxR = do
+    ((result, widget), enctype) <- runFormPost activityForm
+    defaultLayout $ activityWidget widget enctype
+    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
+            renderUrl <- getUrlRender
+            let actorID = renderUrl $ PersonR shr
+                actID = actorID <> "/fake/1"
+                objID = actorID <> "/fake/2"
+                keyID = actorID <> "#key"
+                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)
+            manager <- getsYesod appHttpManager
+            eres <- httpGetAP manager to
+            case eres of
+                Left (APGetErrorHTTP e) -> setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e)
+                Left (APGetErrorJSON e) -> setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e)
+                Left (APGetErrorContentType e) -> setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> T.pack e
+                Right response -> do
+                    let actor = getResponseBody response
+                    if actorId actor /= to
+                        then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched"
+                        else do
+                            akey <- liftIO . readTVarIO =<< getsYesod appActorKey
+                            let sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
+                            eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate]) sign (updateAct act)
+                            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."
+    defaultLayout $ activityWidget widget enctype

src/Vervis/Handler/Person.hs

@@ -42,8 +42,9 @@ import Yesod.Auth.Unverified (requireUnverifiedAuth)
 
 import Text.Email.Local
 
+import Web.ActivityPub
+
 --import Vervis.ActivityStreams
-import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.Model.Ident
 import Vervis.Secure

src/Web/ActivityPub.hs

@@ -0,0 +1,326 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Web.ActivityPub
+    ( -- * Actor
+      --
+      -- ActivityPub actor document including a public key, with a 'FromJSON'
+      -- instance for fetching and a 'ToJSON' instance for publishing.
+      ActorType (..)
+    , Algorithm (..)
+    , PublicKey (..)
+    , 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.
+    , Activity (..)
+
+      -- * Utilities
+    , provideAP
+    , APGetError (..)
+    , httpGetAP
+    , httpPostAP
+    )
+where
+
+import Prelude
+
+import Control.Applicative ((<|>))
+import Control.Exception (Exception, try)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Writer (Writer)
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+import Data.ByteString (ByteString)
+import Data.List.NonEmpty (NonEmpty)
+import Data.PEM
+import Data.Semigroup (Endo)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Network.HTTP.Client
+import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
+import Network.HTTP.Client.Signature (signRequest)
+import Network.HTTP.Signature (KeyId, Signature)
+import Network.HTTP.Simple (JSONException)
+import Network.HTTP.Types.Header (HeaderName, hContentType)
+import Network.URI
+import Yesod.Core.Content (ContentType)
+import Yesod.Core.Handler (ProvidedRep, provideRepType)
+
+import qualified Data.HashMap.Strict as M (lookup)
+import qualified Data.Text as T (unpack)
+import qualified Data.Vector as V (fromList)
+
+frg :: Text
+frg = "https://forgefed.angeley.es/ns#"
+
+as2context :: Text
+as2context = "https://www.w3.org/ns/activitystreams"
+
+actorContext :: Value
+actorContext = Array $ V.fromList
+    [ String as2context
+    , String "https://w3id.org/security/v1"
+    ]
+
+parseURI' :: Text -> Parser URI
+parseURI' t =
+    case parseURI $ T.unpack t of
+        Nothing -> fail "Invalid absolute URI"
+        Just u ->
+            if uriScheme u == "https:"
+                then return u
+                else fail "URI scheme isn't https"
+
+renderURI :: URI -> String
+renderURI u = uriToString id u ""
+
+data ActorType = ActorTypePerson | ActorTypeOther Text
+
+instance FromJSON ActorType where
+    parseJSON = withText "ActorType" $ \ t ->
+        pure $ case t of
+            "Person" -> ActorTypePerson
+            _        -> ActorTypeOther t
+
+instance ToJSON ActorType where
+    toJSON = error "toJSON ActorType"
+    toEncoding at =
+        toEncoding $ case at of
+            ActorTypePerson  -> "Person"
+            ActorTypeOther t -> t
+
+data Algorithm = AlgorithmEd25519 | AlgorithmOther Text
+
+instance FromJSON Algorithm where
+    parseJSON = withText "Algorithm" $ \ t ->
+        pure $ if t == frg <> "ed25519"
+            then AlgorithmEd25519
+            else AlgorithmOther t
+
+instance ToJSON Algorithm where
+    toJSON = error "toJSON Algorithm"
+    toEncoding algo =
+        toEncoding $ case algo of
+            AlgorithmEd25519 -> frg <> "ed25519"
+            AlgorithmOther t -> t
+
+data PublicKey = PublicKey
+    { publicKeyId    :: URI
+    , publicKeyOwner :: URI
+    , publicKeyPem   :: PEM
+    , publicKeyAlgo  :: Maybe Algorithm
+    }
+
+instance FromJSON PublicKey where
+    parseJSON = withObject "PublicKey" $ \ o ->
+        PublicKey
+            <$> (parseURI' =<< o .: "id")
+            <*> (parseURI' =<< o .: "owner")
+            <*> (parsePEM =<< o .: "publicKeyPem")
+            <*> o .:? (frg <> "algorithm")
+        where
+        parsePEM t =
+            case pemParseBS $ encodeUtf8 t of
+                Left e   -> fail $ "PEM parsing failed: " ++ e
+                Right xs ->
+                    case xs of
+                        []  -> fail "Empty PEM"
+                        [x] -> pure x
+                        _   -> fail "Multiple PEM sections"
+
+instance ToJSON PublicKey where
+    toJSON = error "toJSON PublicKey"
+    toEncoding (PublicKey id_ owner pem malgo) =
+        pairs
+            $  "id"           .= renderURI id_
+            <> "owner"        .= renderURI owner
+            <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
+            <> maybe mempty ((frg <> "algorithm") .=) malgo
+
+data Actor = Actor
+    { actorId        :: URI
+    , actorType      :: ActorType
+    , actorUsername  :: Text
+    , actorInbox     :: URI
+    , actorPublicKey :: PublicKey
+    }
+
+instance FromJSON Actor where
+    parseJSON = withObject "Actor" $ \ o ->
+        Actor
+            <$> (parseURI' =<< o .: "id")
+            <*> o .: "type"
+            <*> o .: "preferredUsername"
+            <*> (parseURI' =<< o .: "inbox")
+            <*> o .: "publicKey"
+
+instance ToJSON Actor where
+    toJSON = error "toJSON Actor"
+    toEncoding (Actor id_ typ username inbox pkey) =
+        pairs
+            $  "@context"          .= actorContext
+            <> "id"                .= renderURI id_
+            <> "type"              .= typ
+            <> "preferredUsername" .= username
+            <> "inbox"             .= renderURI inbox
+            <> "publicKey"         .= pkey
+
+-- | 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   :: URI
+    , activityJSON :: Object
+    }
+
+instance FromJSON Activity where
+    parseJSON = withObject "Activity" $ \ o -> do
+        c <- o .: "@context"
+        if c == 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 t  -> parseURI' t
+        return $ Activity to o
+
+instance ToJSON Activity where
+    toJSON = error "toJSON Activity"
+    toEncoding = toEncoding . activityJSON
+
+typeActivityStreams2 :: ContentType
+typeActivityStreams2 = "application/activity+json"
+
+typeActivityStreams2LD :: ContentType
+typeActivityStreams2LD =
+    "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\""
+
+provideAP :: (Monad m, ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
+provideAP v = do
+    let enc = toEncoding v
+    -- provideRepType typeActivityStreams2   $ return enc
+    provideRepType typeActivityStreams2LD $ return enc
+
+data APGetError
+    = APGetErrorHTTP HttpException
+    | APGetErrorJSON JSONException
+    | APGetErrorContentType String
+    deriving Show
+
+instance Exception APGetError
+
+-- | Perform an HTTP GET request to fetch an ActivityPub object.
+--
+-- * Verify the URI scheme is _https:_ and authority part is present
+-- * Set _Accept_ request header
+-- * Perform the GET request
+-- * Verify the _Content-Type_ response header
+-- * Parse the JSON response body
+httpGetAP
+    :: (MonadIO m, FromJSON a)
+    => Manager
+    -> URI
+    -> m (Either APGetError (Response a))
+httpGetAP manager uri =
+    if uriScheme uri /= "https:"
+        then return $ Left $ APGetErrorHTTP $ InvalidUrlException (show uri) "Scheme isn't https"
+        else liftIO $ mkResult <$> try (httpAPEither manager =<< requestFromURI uri)
+    where
+    lookup' x = map snd . filter ((== x) . fst)
+    mkResult (Left e)  = Left $ APGetErrorHTTP e
+    mkResult (Right r) =
+        case lookup' hContentType $ responseHeaders r of
+            []  -> Left $ APGetErrorContentType "No Content-Type"
+            [b] -> if b == typeActivityStreams2LD || b == typeActivityStreams2
+                        then case responseBody r of
+                            Left e  -> Left $ APGetErrorJSON e
+                            Right v -> Right $ v <$ r
+                        else Left $ APGetErrorContentType "Non-AP Content-Type"
+            _   -> Left $ APGetErrorContentType "Multiple Content-Type"
+
+-- Set method to POST, Set Content-Type, make HTTP signature, set response to throw on non-2xx
+-- status
+
+-- | Perform an HTTP POST request to submit an ActivityPub object.
+--
+-- * Verify the URI scheme is _https:_ and authority part is present
+-- * Set _Content-Type_ request header
+-- * Compute HTTP signature and add _Signature_ request header
+-- * Perform the POST request
+-- * Verify the response status is 2xx
+httpPostAP
+    :: (MonadIO m, ToJSON a)
+    => Manager
+    -> URI
+    -> NonEmpty HeaderName
+    -> (ByteString -> (KeyId, Signature))
+    -> a
+    -> m (Either HttpException (Response ()))
+httpPostAP manager uri headers sign value =
+    if uriScheme uri /= "https:"
+        then return $ Left $ InvalidUrlException (show uri) "Scheme isn't https"
+        else liftIO $ try $ do
+            req <- requestFromURI uri
+            let req' =
+                    setRequestCheckStatus $
+                    consHeader hContentType typeActivityStreams2LD $
+                    req { method      = "POST"
+                        , requestBody = RequestBodyLBS $ encode value
+                        }
+                sign' b =
+                    let (k, s) = sign b
+                    in  (Nothing, k, s)
+            req'' <- signRequest headers sign' Nothing req'
+            httpNoBody req' manager
+    where
+    consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }

stack.yaml

@@ -18,6 +18,7 @@ packages:
   - lib/hit-graph
   - lib/hit-harder
   - lib/hit-network
+  - lib/http-client-signature
   - lib/http-signature
   - lib/persistent-migration
   - lib/persistent-email-address

update-deps.sh

@@ -7,6 +7,7 @@ DEPS='hit-graph
       hit-network
       darcs-lights
       darcs-rev
+      http-client-signature
       http-signature
       ssh
       persistent-migration

vervis.cabal

@@ -41,6 +41,7 @@ library
   exposed-modules:     Control.Applicative.Local
                        Control.Concurrent.Local
                        Darcs.Local.Repository
+                       Data.Aeson.Encode.Pretty.ToEncoding
                        Data.Attoparsec.ByteString.Local
                        Data.Binary.Local
                        Data.ByteString.Char8.Local
@@ -83,12 +84,14 @@ library
                        Diagrams.IntransitiveDAG
                        Formatting.CaseInsensitive
                        Language.Haskell.TH.Quote.Local
+                       Network.HTTP.Client.Conduit.ActivityPub
                        Network.SSH.Local
                        Text.Blaze.Local
                        Text.Display
                        Text.Email.Local
                        Text.FilePath.Local
                        Text.Jasmine.Local
+                       Web.ActivityPub
                        Web.PathPieces.Local
                        Yesod.Auth.Unverified
                        Yesod.Auth.Unverified.Creds
@@ -96,7 +99,6 @@ library
                        Yesod.Paginate.Local
                        Yesod.SessionEntity
 
-                       Vervis.ActivityPub
                        Vervis.ActivityStreams
                        Vervis.ActorKey
                        Vervis.Application
@@ -228,6 +230,8 @@ library
                        -- for defining colors for use with diagrams
                      , colour
                      , conduit
+                       -- For httpAPEither
+                     , conduit-extra
                      , containers
                      , cryptonite
                        -- for Storage.Hashed because hashed-storage seems
@@ -260,6 +264,7 @@ library
                      , hashable
                        -- for source file highlighting
                      , highlighter2
+                     , http-client-signature
                      , http-signature
                      , git
                      , hit-graph
@@ -318,6 +323,8 @@ library
                      , transformers
                        -- probably should be replaced with lenses once I learn
                      , tuple
+                       -- For httpAPEither
+                     , unliftio-core
                      , unliftio
                      , unordered-containers
                      , vector