forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Federation test outbox page with form for entering JSON

Browse source
This commit is contained in:
fr33domlover 2019-01-21 15:54:57 +00:00
parent 2cc621e3a5
commit 1f47ca39eb
12 changed files with 632 additions and 190 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/routes
View file

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

46
src/Data/Aeson/Encode/Pretty/ToEncoding.hs Normal file
View file

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

104
src/Network/HTTP/Client/Conduit/ActivityPub.hs Normal file
View file

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

164
src/Vervis/ActivityPub.hs
View file

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

7
src/Vervis/ActorKey.hs
View file

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

27
src/Vervis/Foundation.hs
View file

@ -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.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.HTTP.Client (Manager, HttpException, requestFromURI, responseBody)
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 <-
ExceptT $ first (displayException :: HttpException -> String) <$>
(try $
httpJSONEither .
addRequestHeader "Accept" "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" .
setRequestManager manager
=<< requestFromURI u
)
actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager 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"

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

@ -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.Encode.Pretty (encodePretty)
import Data.Aeson
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.Text as T (unpack)
import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
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 Vervis.Foundation (App (..), HttpSigVerResult (..), Handler)
import Web.ActivityPub
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

3
src/Vervis/Handler/Person.hs
View file

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

326
src/Web/ActivityPub.hs Normal file
View file

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

1
stack.yaml
View file

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

1
update-deps.sh
View file

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

9
vervis.cabal
View file

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