Federation test outbox page with form for entering JSON
This commit is contained in:
parent
2cc621e3a5
commit
1f47ca39eb
12 changed files with 632 additions and 190 deletions
|
@ -25,6 +25,7 @@
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
|
|
||||||
/inbox InboxR GET POST
|
/inbox InboxR GET POST
|
||||||
|
/outbox OutboxR GET POST
|
||||||
|
|
||||||
-- ----------------------------------------------------------------------------
|
-- ----------------------------------------------------------------------------
|
||||||
-- Current user
|
-- Current user
|
||||||
|
|
46
src/Data/Aeson/Encode/Pretty/ToEncoding.hs
Normal file
46
src/Data/Aeson/Encode/Pretty/ToEncoding.hs
Normal 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
104
src/Network/HTTP/Client/Conduit/ActivityPub.hs
Normal 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)
|
|
@ -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
|
|
|
@ -18,6 +18,7 @@ module Vervis.ActorKey
|
||||||
, generateActorKey
|
, generateActorKey
|
||||||
, actorKeyRotator
|
, actorKeyRotator
|
||||||
, actorKeyPublicBin
|
, actorKeyPublicBin
|
||||||
|
, actorKeySign
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -27,11 +28,12 @@ import Control.Concurrent (threadDelay)
|
||||||
import Control.Concurrent.STM (TVar, writeTVar)
|
import Control.Concurrent.STM (TVar, writeTVar)
|
||||||
import Control.Monad (forever)
|
import Control.Monad (forever)
|
||||||
import Control.Monad.STM (atomically)
|
import Control.Monad.STM (atomically)
|
||||||
import Crypto.PubKey.Ed25519
|
import Crypto.PubKey.Ed25519 hiding (Signature)
|
||||||
import Data.ByteArray (convert)
|
import Data.ByteArray (convert)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import Data.Time.Interval (TimeInterval, microseconds)
|
import Data.Time.Interval (TimeInterval, microseconds)
|
||||||
import Data.PEM
|
import Data.PEM
|
||||||
|
import Network.HTTP.Signature (Signature (..))
|
||||||
|
|
||||||
-- | Ed25519 signing key, we generate it on the server and use for signing. We
|
-- | 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
|
-- 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.
|
-- probably okay because the PEM rendering is hopefully trivial.
|
||||||
actorKeyPublicBin :: ActorKey -> ByteString
|
actorKeyPublicBin :: ActorKey -> ByteString
|
||||||
actorKeyPublicBin = convert . actorKeyPublic
|
actorKeyPublicBin = convert . actorKeyPublic
|
||||||
|
|
||||||
|
actorKeySign :: ActorKey -> ByteString -> Signature
|
||||||
|
actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub
|
||||||
|
|
|
@ -27,8 +27,9 @@ import Data.Time.Interval (TimeInterval, fromTimeUnit, toTimeUnit)
|
||||||
import Data.Time.Units (Second, Minute, Day)
|
import Data.Time.Units (Second, Minute, Day)
|
||||||
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||||||
import Graphics.SVGFonts.ReadFont (PreparedFont)
|
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 Network.URI (URI (uriFragment), parseURI)
|
||||||
import Text.Shakespeare.Text (textFile)
|
import Text.Shakespeare.Text (textFile)
|
||||||
import Text.Hamlet (hamletFile)
|
import Text.Hamlet (hamletFile)
|
||||||
|
@ -46,8 +47,6 @@ import qualified Yesod.Core.Unsafe as Unsafe
|
||||||
import Data.Text as T (pack, intercalate, concat)
|
import Data.Text as T (pack, intercalate, concat)
|
||||||
--import qualified Data.Text.Encoding as TE
|
--import qualified Data.Text.Encoding as TE
|
||||||
|
|
||||||
import Text.Email.Local
|
|
||||||
|
|
||||||
import Network.HTTP.Signature hiding (Algorithm (..))
|
import Network.HTTP.Signature hiding (Algorithm (..))
|
||||||
import Yesod.Auth.Unverified
|
import Yesod.Auth.Unverified
|
||||||
import Yesod.Auth.Unverified.Creds
|
import Yesod.Auth.Unverified.Creds
|
||||||
|
@ -56,8 +55,11 @@ import Yesod.Mail.Send
|
||||||
|
|
||||||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||||||
|
|
||||||
|
import Web.ActivityPub
|
||||||
|
|
||||||
|
import Text.Email.Local
|
||||||
import Text.Jasmine.Local (discardm)
|
import Text.Jasmine.Local (discardm)
|
||||||
import Vervis.ActivityPub
|
|
||||||
import Vervis.ActorKey (ActorKey)
|
import Vervis.ActorKey (ActorKey)
|
||||||
import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn)
|
import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn)
|
||||||
import Vervis.Model.Group
|
import Vervis.Model.Group
|
||||||
|
@ -170,6 +172,8 @@ instance Yesod App where
|
||||||
| a == resendVerifyR -> personFromResendForm
|
| a == resendVerifyR -> personFromResendForm
|
||||||
(AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
|
(AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
|
||||||
|
|
||||||
|
(OutboxR , True) -> personAny
|
||||||
|
|
||||||
(GroupsR , True) -> personAny
|
(GroupsR , True) -> personAny
|
||||||
(GroupNewR , _ ) -> personAny
|
(GroupNewR , _ ) -> personAny
|
||||||
(GroupMembersR grp , True) -> groupAdmin grp
|
(GroupMembersR grp , True) -> groupAdmin grp
|
||||||
|
@ -563,7 +567,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
||||||
|
|
||||||
instance YesodHttpSig App where
|
instance YesodHttpSig App where
|
||||||
data HttpSigVerResult App = HttpSigVerResult (Either String URI)
|
data HttpSigVerResult App = HttpSigVerResult (Either String URI)
|
||||||
httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"]
|
httpSigVerHeaders = const [hRequestTarget, hHost]
|
||||||
httpSigVerSeconds =
|
httpSigVerSeconds =
|
||||||
fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
|
fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
|
||||||
where
|
where
|
||||||
|
@ -580,16 +584,8 @@ instance YesodHttpSig App where
|
||||||
Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
|
Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
|
||||||
Just uri -> Right uri
|
Just uri -> Right uri
|
||||||
manager <- getsYesod appHttpManager
|
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
|
ExceptT . pure $ do
|
||||||
actor <- first displayException $ getResponseBody response
|
|
||||||
let uActor = u { uriFragment = "" }
|
let uActor = u { uriFragment = "" }
|
||||||
if uActor == actorId actor
|
if uActor == actorId actor
|
||||||
then Right ()
|
then Right ()
|
||||||
|
@ -632,6 +628,7 @@ instance YesodBreadcrumbs App where
|
||||||
RobotsR -> ("", Nothing)
|
RobotsR -> ("", Nothing)
|
||||||
|
|
||||||
InboxR -> ("Inbox", Nothing)
|
InboxR -> ("Inbox", Nothing)
|
||||||
|
OutboxR -> ("Outbox", Nothing)
|
||||||
|
|
||||||
HomeR -> ("Home", Nothing)
|
HomeR -> ("Home", Nothing)
|
||||||
ResendVerifyEmailR -> ( "Resend verification email"
|
ResendVerifyEmailR -> ( "Resend verification email"
|
||||||
|
|
|
@ -16,6 +16,8 @@
|
||||||
module Vervis.Handler.Inbox
|
module Vervis.Handler.Inbox
|
||||||
( getInboxR
|
( getInboxR
|
||||||
, postInboxR
|
, postInboxR
|
||||||
|
, getOutboxR
|
||||||
|
, postOutboxR
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -29,29 +31,39 @@ import Control.Monad.STM (atomically)
|
||||||
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
|
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
|
||||||
import Crypto.Error (CryptoFailable (..))
|
import Crypto.Error (CryptoFailable (..))
|
||||||
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
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.Bifunctor (first, second)
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
import Data.PEM (pemContent)
|
import Data.PEM (pemContent)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Text.Encoding (encodeUtf8)
|
||||||
import Data.Text.Lazy.Encoding (decodeUtf8)
|
import Data.Text.Lazy.Encoding (decodeUtf8)
|
||||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||||
import Data.Time.Interval (TimeInterval, toTimeUnit)
|
import Data.Time.Interval (TimeInterval, toTimeUnit)
|
||||||
import Data.Time.Units (Second)
|
import Data.Time.Units (Second)
|
||||||
|
import Database.Persist (Entity (..))
|
||||||
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
|
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
|
||||||
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
|
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 Text.Blaze.Html (Html)
|
||||||
import UnliftIO.Exception (try)
|
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.Json (requireJsonBody)
|
||||||
import Yesod.Core.Handler
|
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.ByteString.Char8 as BC (unpack)
|
||||||
import qualified Data.CaseInsensitive as CI (mk)
|
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 Data.Vector as V (length, cons, init)
|
||||||
import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
|
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 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))
|
import Vervis.Settings (AppSettings (appHttpSigTimeLimit))
|
||||||
|
|
||||||
getInboxR :: Handler Html
|
getInboxR :: Handler Html
|
||||||
|
@ -169,3 +184,105 @@ postInboxR = do
|
||||||
_ -> Left "Activity actor isn't a JSON string"
|
_ -> Left "Activity actor isn't a JSON string"
|
||||||
_ -> Left "Activity's object isn't a JSON object"
|
_ -> Left "Activity's object isn't a JSON object"
|
||||||
return (contentType, o)
|
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
|
||||||
|
|
|
@ -42,8 +42,9 @@ import Yesod.Auth.Unverified (requireUnverifiedAuth)
|
||||||
|
|
||||||
import Text.Email.Local
|
import Text.Email.Local
|
||||||
|
|
||||||
|
import Web.ActivityPub
|
||||||
|
|
||||||
--import Vervis.ActivityStreams
|
--import Vervis.ActivityStreams
|
||||||
import Vervis.ActivityPub
|
|
||||||
import Vervis.ActorKey
|
import Vervis.ActorKey
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Vervis.Secure
|
import Vervis.Secure
|
||||||
|
|
326
src/Web/ActivityPub.hs
Normal file
326
src/Web/ActivityPub.hs
Normal 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 }
|
|
@ -18,6 +18,7 @@ packages:
|
||||||
- lib/hit-graph
|
- lib/hit-graph
|
||||||
- lib/hit-harder
|
- lib/hit-harder
|
||||||
- lib/hit-network
|
- lib/hit-network
|
||||||
|
- lib/http-client-signature
|
||||||
- lib/http-signature
|
- lib/http-signature
|
||||||
- lib/persistent-migration
|
- lib/persistent-migration
|
||||||
- lib/persistent-email-address
|
- lib/persistent-email-address
|
||||||
|
|
|
@ -7,6 +7,7 @@ DEPS='hit-graph
|
||||||
hit-network
|
hit-network
|
||||||
darcs-lights
|
darcs-lights
|
||||||
darcs-rev
|
darcs-rev
|
||||||
|
http-client-signature
|
||||||
http-signature
|
http-signature
|
||||||
ssh
|
ssh
|
||||||
persistent-migration
|
persistent-migration
|
||||||
|
|
|
@ -41,6 +41,7 @@ library
|
||||||
exposed-modules: Control.Applicative.Local
|
exposed-modules: Control.Applicative.Local
|
||||||
Control.Concurrent.Local
|
Control.Concurrent.Local
|
||||||
Darcs.Local.Repository
|
Darcs.Local.Repository
|
||||||
|
Data.Aeson.Encode.Pretty.ToEncoding
|
||||||
Data.Attoparsec.ByteString.Local
|
Data.Attoparsec.ByteString.Local
|
||||||
Data.Binary.Local
|
Data.Binary.Local
|
||||||
Data.ByteString.Char8.Local
|
Data.ByteString.Char8.Local
|
||||||
|
@ -83,12 +84,14 @@ library
|
||||||
Diagrams.IntransitiveDAG
|
Diagrams.IntransitiveDAG
|
||||||
Formatting.CaseInsensitive
|
Formatting.CaseInsensitive
|
||||||
Language.Haskell.TH.Quote.Local
|
Language.Haskell.TH.Quote.Local
|
||||||
|
Network.HTTP.Client.Conduit.ActivityPub
|
||||||
Network.SSH.Local
|
Network.SSH.Local
|
||||||
Text.Blaze.Local
|
Text.Blaze.Local
|
||||||
Text.Display
|
Text.Display
|
||||||
Text.Email.Local
|
Text.Email.Local
|
||||||
Text.FilePath.Local
|
Text.FilePath.Local
|
||||||
Text.Jasmine.Local
|
Text.Jasmine.Local
|
||||||
|
Web.ActivityPub
|
||||||
Web.PathPieces.Local
|
Web.PathPieces.Local
|
||||||
Yesod.Auth.Unverified
|
Yesod.Auth.Unverified
|
||||||
Yesod.Auth.Unverified.Creds
|
Yesod.Auth.Unverified.Creds
|
||||||
|
@ -96,7 +99,6 @@ library
|
||||||
Yesod.Paginate.Local
|
Yesod.Paginate.Local
|
||||||
Yesod.SessionEntity
|
Yesod.SessionEntity
|
||||||
|
|
||||||
Vervis.ActivityPub
|
|
||||||
Vervis.ActivityStreams
|
Vervis.ActivityStreams
|
||||||
Vervis.ActorKey
|
Vervis.ActorKey
|
||||||
Vervis.Application
|
Vervis.Application
|
||||||
|
@ -228,6 +230,8 @@ library
|
||||||
-- for defining colors for use with diagrams
|
-- for defining colors for use with diagrams
|
||||||
, colour
|
, colour
|
||||||
, conduit
|
, conduit
|
||||||
|
-- For httpAPEither
|
||||||
|
, conduit-extra
|
||||||
, containers
|
, containers
|
||||||
, cryptonite
|
, cryptonite
|
||||||
-- for Storage.Hashed because hashed-storage seems
|
-- for Storage.Hashed because hashed-storage seems
|
||||||
|
@ -260,6 +264,7 @@ library
|
||||||
, hashable
|
, hashable
|
||||||
-- for source file highlighting
|
-- for source file highlighting
|
||||||
, highlighter2
|
, highlighter2
|
||||||
|
, http-client-signature
|
||||||
, http-signature
|
, http-signature
|
||||||
, git
|
, git
|
||||||
, hit-graph
|
, hit-graph
|
||||||
|
@ -318,6 +323,8 @@ library
|
||||||
, transformers
|
, transformers
|
||||||
-- probably should be replaced with lenses once I learn
|
-- probably should be replaced with lenses once I learn
|
||||||
, tuple
|
, tuple
|
||||||
|
-- For httpAPEither
|
||||||
|
, unliftio-core
|
||||||
, unliftio
|
, unliftio
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
|
|
Loading…
Reference in a new issue