diff --git a/config/routes b/config/routes index e9aa3ba..4cd4fc7 100644 --- a/config/routes +++ b/config/routes @@ -25,6 +25,7 @@ -- ---------------------------------------------------------------------------- /inbox InboxR GET POST +/outbox OutboxR GET POST -- ---------------------------------------------------------------------------- -- Current user diff --git a/src/Data/Aeson/Encode/Pretty/ToEncoding.hs b/src/Data/Aeson/Encode/Pretty/ToEncoding.hs new file mode 100644 index 0000000..2e3a61b --- /dev/null +++ b/src/Data/Aeson/Encode/Pretty/ToEncoding.hs @@ -0,0 +1,46 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Network/HTTP/Client/Conduit/ActivityPub.hs b/src/Network/HTTP/Client/Conduit/ActivityPub.hs new file mode 100644 index 0000000..42c85e3 --- /dev/null +++ b/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 . + - + - 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) diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs deleted file mode 100644 index b725ccf..0000000 --- a/src/Vervis/ActivityPub.hs +++ /dev/null @@ -1,164 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2019 by fr33domlover . - - - - ♡ 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 - - . - -} - -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 diff --git a/src/Vervis/ActorKey.hs b/src/Vervis/ActorKey.hs index 699b82e..22aab7b 100644 --- a/src/Vervis/ActorKey.hs +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 98caeea..11b2f03 100644 --- a/src/Vervis/Foundation.hs +++ b/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.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" diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 2294ae5..068ef1d 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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.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| +

Enter an activity JSON document and click "Submit" to send it. +

NOTES: +

    +
  • + This is a test page for implementing federation in Vervis. The + activities just reach a test page, nothing really gets published or + changed otherwise. +
  • + 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. +
  • + 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. +
  • + 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. + +
    + ^{widget} + + |] + +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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index c291282..5b42bf9 100644 --- a/src/Vervis/Handler/Person.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs new file mode 100644 index 0000000..f775b56 --- /dev/null +++ b/src/Web/ActivityPub.hs @@ -0,0 +1,326 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 } diff --git a/stack.yaml b/stack.yaml index 760984d..f291e4b 100644 --- a/stack.yaml +++ b/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 diff --git a/update-deps.sh b/update-deps.sh index 467c3c5..d3bab08 100644 --- a/update-deps.sh +++ b/update-deps.sh @@ -7,6 +7,7 @@ DEPS='hit-graph hit-network darcs-lights darcs-rev + http-client-signature http-signature ssh persistent-migration diff --git a/vervis.cabal b/vervis.cabal index 1039f0d..078d1c8 100644 --- a/vervis.cabal +++ b/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