From df01560ea6e79f1c11ce7049c3a7a53020905a0f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 19 Jan 2019 01:44:21 +0000 Subject: [PATCH] ActivityPub inbox test page This patch includes some ugliness and commented out code. Sorry for that. I'll clean it up soon. Basically there's a TVar holding a Vector of at most 10 AP activities. You can freely POST stuff to /inbox, and then GET /inbox and see what you posted, or an error description saying why your activity was rejected. --- config/routes | 8 +- src/Vervis/ActivityPub.hs | 146 ++++++++++++++++++++++++++++++++ src/Vervis/ActorKey.hs | 101 +++++++++++++++++++--- src/Vervis/Application.hs | 7 +- src/Vervis/Foundation.hs | 116 +++++++++++++++++++++---- templates/default-layout.hamlet | 3 + vervis.cabal | 10 +++ 7 files changed, 361 insertions(+), 30 deletions(-) create mode 100644 src/Vervis/ActivityPub.hs diff --git a/config/routes b/config/routes index 8991d9b..e9aa3ba 100644 --- a/config/routes +++ b/config/routes @@ -1,6 +1,6 @@ -- This file is part of Vervis. -- --- Written in 2016 by fr33domlover . +-- Written in 2016, 2018, 2019 by fr33domlover . -- -- ♡ Copying is an act of love. Please copy, reuse and share. -- @@ -20,6 +20,12 @@ /favicon.ico FaviconR GET /robots.txt RobotsR GET +-- ---------------------------------------------------------------------------- +-- Federation +-- ---------------------------------------------------------------------------- + +/inbox InboxR GET POST + -- ---------------------------------------------------------------------------- -- Current user -- ---------------------------------------------------------------------------- diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs new file mode 100644 index 0000000..1caa91b --- /dev/null +++ b/src/Vervis/ActivityPub.hs @@ -0,0 +1,146 @@ +{- 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 (..) + ) +where + +import Prelude + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.PEM +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.URI + +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 diff --git a/src/Vervis/ActorKey.hs b/src/Vervis/ActorKey.hs index ec3bf4c..cafa143 100644 --- a/src/Vervis/ActorKey.hs +++ b/src/Vervis/ActorKey.hs @@ -17,7 +17,7 @@ module Vervis.ActorKey ( ActorKey () , generateActorKey , actorKeyRotator - , actorPublicKey + -- , actorPublicKey ) where @@ -33,13 +33,91 @@ import Data.ByteString (ByteString) import Data.Time.Interval (TimeInterval, microseconds) import Data.PEM --- | Ed25519 signing key. +-- | 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 +-- signatures. data ActorKey = ActorKey - { actorKeySecret :: SecretKey - , actorKeyPublic :: PublicKey - , actorKeyPublicPem :: ByteString + { actorKeySecret :: SecretKey + -- ^ Secret key in binary form. + , actorKeyPublic :: PublicKey + -- ^ Public key in binary form. + , actorKeyPubPEM :: ByteString + -- ^ Public key in PEM format. This can be generated from the binary + -- form, but we keep it here because it's used for sending the public + -- key to whoever wishes to verify our signatures. So, we generate a + -- key once and potentially send the PEM many times. } +{- +-- | Ed25519 public key for signature verification. We receive these public +-- keys from other servers and we use them to verify HTTP request signatures. +data ActorPublicKey = ActorPublicKey + { actorPublicKeyBin :: PublicKey + -- ^ Public key in binary form. This is used for signature verification. + , actorPublicKeyPem :: ByteString + -- ^ Public key in PEM format. We can use it for formatting the key as + -- JSON, and generally into textual formats. + , actorPublicKeyId :: URI + -- ^ Public key ID URI. We can use it for formatting the key as JSON or + -- other textual formats, and for verifying that it's identical to the + -- URI we used for retrieving the key. + , actorPublicKeyActor :: URI + -- ^ Public key's actor URI. We can use it for formatting the key as JSON + -- or other textual formats, and for verifying that it's identical to + -- the actor ID through which we found the key. We can also check that + -- this ID matches the actor ID to which content is attributed, to make + -- sure we don't accept content claimed to be authored by someone other + -- than the actor who signed the request. + } + +instance FromJSON ActorPublicKey where + parseJSON = withObject "ActorPublicKey" $ \ o -> do + pem <- o .: "publicKeyPem" + ActorPublicKey + <$> parsePEM pem + <*> pure pem + <*> parseURI' =<< (o .: "id" <|> o .: "@id") + <*> parseURI' =<< o .: "owner" + where + parsePEM b = + case pemParseBS b of + Left e -> fail $ "PEM parsing failed: " ++ e + Right xs -> + case xs of + [] -> fail "Empty PEM" + [x] -> + case publickey $ pemContent x of + CryptoPassed k -> return k + CryptoFailed e -> fail $ show e + _ -> fail "Multiple PEM sections" + parseURI' t = + withText "URI" $ \ 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" + +instance ToJSON ActorPublicKey where + toJSON = error "toJSON ActorPublicKey" + toEncoding (ActorPublicKey _ pem keyid actor) = + pairs + $ "id" .= showURI keyid + <> "owner" .= showURI actor + <> "publicKeyPem" .= pem + where + showURI u = uriToString id u "" + {- + array = Array . V.fromList + context = + array + [ String "https://w3id.org/security/v1" + , object [("id", String "@id")] + ] + -} +-} + -- | Generate a new random key. generateActorKey :: IO ActorKey generateActorKey = mk <$> generateSecretKey @@ -47,11 +125,12 @@ generateActorKey = mk <$> generateSecretKey mk secret = let public = toPublic secret in ActorKey - { actorKeySecret = secret - , actorKeyPublic = public - , actorKeyPublicPem = - pemWriteBS $ PEM "PUBLIC KEY" [] $ convert public + { actorKeySecret = secret + , actorKeyPublic = public + , actorKeyPubPEM = renderPEM public } + renderPEM :: PublicKey -> ByteString + renderPEM = pemWriteBS . PEM "PUBLIC KEY" [] . convert -- | A loop that runs forever and periodically generates a new actor key, -- storing it in a 'TVar'. @@ -69,5 +148,5 @@ actorKeyRotator interval key = "actorKeyRotator: interval out of range: " ++ show micros -- | The public key in PEM format, can be directly placed in responses. -actorPublicKey :: ActorKey -> ByteString -actorPublicKey = actorKeyPublicPem +--actorPublicKey :: ActorKey -> ByteString +--actorPublicKey = actorKeyPublicPem diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 590a9eb..6067e8f 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -37,6 +37,8 @@ import Graphics.SVGFonts.Fonts (lin2) import Graphics.SVGFonts.ReadFont (loadFont) import Vervis.Import import Language.Haskell.TH.Syntax (qLocation) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, @@ -63,6 +65,7 @@ import Vervis.Handler.Common import Vervis.Handler.Git import Vervis.Handler.Group import Vervis.Handler.Home +import Vervis.Handler.Inbox import Vervis.Handler.Key import Vervis.Handler.Person import Vervis.Handler.Project @@ -92,7 +95,7 @@ makeFoundation :: AppSettings -> IO App makeFoundation appSettings = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. - --appHttpManager <- newManager tlsManagerSettings + appHttpManager <- newManager tlsManagerSettings appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appStatic <- (if appMutableStatic appSettings then staticDevel else static) @@ -110,6 +113,8 @@ makeFoundation appSettings = do appActorKey <- newTVarIO =<< generateActorKey + appActivities <- newTVarIO mempty + -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index b49e523..a9f34c7 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -17,12 +17,18 @@ module Vervis.Foundation where import Prelude (init, last) -import Control.Monad.Logger (logWarn) +import Control.Monad.Logger.CallStack (logWarn) import Control.Monad.Trans.Maybe -import Data.Time.Interval (fromTimeUnit, toTimeUnit) -import Data.Time.Units (Minute, Day) +import Crypto.Error (CryptoFailable (..)) +import Crypto.PubKey.Ed25519 (publicKey, signature, verify) +import Data.PEM (pemContent) +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) +import Network.URI (uriFragment, parseURI) import Text.Shakespeare.Text (textFile) import Text.Hamlet (hamletFile) --import Text.Jasmine (minifym) @@ -32,20 +38,27 @@ import Yesod.Auth.Message (AuthMessage (IdentifierNotFound)) import Yesod.Core.Types (Logger) import Yesod.Default.Util (addStaticContentExternal) -import Text.Email.Local - -import Yesod.Auth.Unverified -import Yesod.Auth.Unverified.Creds -import Yesod.Mail.Send - +import qualified Data.ByteString.Char8 as BC (unpack) +import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Yesod.Core.Unsafe as Unsafe --import qualified Data.CaseInsensitive as CI 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 +import Yesod.HttpSignature (YesodHttpSig (..)) +import Yesod.Mail.Send + +import qualified Network.HTTP.Signature as S (Algorithm (..)) + import Text.Jasmine.Local (discardm) +import Vervis.ActivityPub import Vervis.ActorKey (ActorKey) -import Vervis.Import.NoFoundation hiding (Handler, Day, last, init) +import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn) import Vervis.Model.Group import Vervis.Model.Ident import Vervis.Model.Role @@ -60,11 +73,13 @@ data App = App { appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. - --, appHttpManager :: Manager + , appHttpManager :: Manager , appLogger :: Logger , appMailQueue :: Maybe (Chan (MailRecipe App)) , appSvgFont :: PreparedFont Double , appActorKey :: TVar ActorKey + + , appActivities :: TVar (Vector (UTCTime, Either String (ByteString, BL.ByteString))) } -- This is where we define all of the routes in our application. For a full @@ -272,7 +287,7 @@ instance Yesod App where if username p == uname then return Authorized else do - $logWarn $ T.concat + logWarn $ T.concat [ "User ", username p, " tried to verify user ", uname ] return $ Unauthorized "You can't verify other users" @@ -286,7 +301,7 @@ instance Yesod App where if username p == uname then return Authorized else do - $logWarn $ T.concat + logWarn $ T.concat [ "User ", username p, " tried to POST to \ \verification email resend for user ", uname ] @@ -294,7 +309,7 @@ instance Yesod App where Unauthorized "You can't do that for other users" _ -> do - $logWarn $ T.concat + logWarn $ T.concat [ "User ", username p, " tried to POST to \ \verification email resend for invalid username" ] @@ -330,7 +345,7 @@ instance Yesod App where meg <- getBy $ UniqueGroup sid case meg of Nothing -> do - $logWarn $ + logWarn $ "Found non-person non-group sharer: " <> shr2text shr return $ error "Zombie sharer" @@ -494,7 +509,7 @@ instance AccountSendEmail App where unless sent $ do setMessage "Mail sending disabled, please contact admin" ur <- getUrlRender - $logWarn $ T.concat + logWarn $ T.concat [ "Verification email NOT SENT for user " , uname, " <", emailText email, ">: " , ur url @@ -504,7 +519,7 @@ instance AccountSendEmail App where unless sent $ do setMessage "Mail sending disabled, please contact admin" ur <- getUrlRender - $logWarn $ T.concat + logWarn $ T.concat ["Password reset email NOT SENT for user " , uname, " <", emailText email, ">: " , ur url @@ -545,6 +560,73 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding +{- +instance YesodHttpSig App where + data HttpSigVerResult App = HttpSigVerResult Bool + httpSigVerHeaders = const [HeaderTarget, HeaderName "Host"] + httpSigVerSeconds = + fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings + where + toSeconds :: TimeInterval -> Second + toSeconds = toTimeUnit + httpVerifySig malgo (KeyId keyid) input (Signature sig) = + if algoSupported malgo + then case parseURI $ BC.unpack keyid of + Just u -> do + eres <- try $ httpJSONEither =<< requestFromURI u + case eres of + Left e -> do + logWarn $ "httpVerifySig got HTTP exception: " <> T.pack (displayException (e :: HttpException)) + -- return HttpSigVerKeyNotFound + return $ HttpSigVerResult False + Right r -> + case getResponseBody r of + Left e -> do + logWarn $ "httpVerifySig got JSON exception: " <> T.pack (displayException e) + -- return HttpSigVerKeyNotFound + return $ HttpSigVerResult False + Right actor -> do + let uActor = u { uriFragment = "" } + if uActor == actorId actor + then + let pkey = actorPublicKey actor + in if publicKeyId pkey == u && publicKeyOwner pkey == actorId actor + then case publicKeyAlgo pkey of + Just AlgorithmEd25519 -> + case publicKey $ pemContent $ publicKeyPem pkey of + CryptoPassed k -> + case signature sig of + CryptoPassed s -> + return $ if verify k input s + then -- HttpSigVerValid + HttpSigVerResult True + else -- HttpSigVerInvalid + HttpSigVerResult False + CryptoFailed e -> -- TODO handle + return $ HttpSigVerResult False + CryptoFailed e -> -- TODO handle + return $ HttpSigVerResult False + _ -> case malgo of + Nothing -> -- return HttpSigVerAlgoNotSupported + return $ HttpSigVerResult False + Just _ -> -- return HttpSigVerAlgoMismatch + return $ HttpSigVerResult False + else -- TODO handle the mismatch + return $ HttpSigVerResult False + else -- TODO actor id doesn't match URL we accessed! + return $ HttpSigVerResult False + Nothing -> -- return HttpSigVerKeyNotFound + return $ HttpSigVerResult False + else -- return HttpSigVerAlgoNotSupported + return $ HttpSigVerResult False + where + algoSupported Nothing = True + algoSupported (Just a) = + case a of + S.AlgorithmEd25519 -> True + S.AlgorithmOther _ -> False +-} + instance YesodBreadcrumbs App where breadcrumb route = return $ case route of StaticR _ -> ("", Nothing) diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 1f543e0..00cdc46 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -23,6 +23,9 @@ $nothing Or Sign up. +

+ UPDATE: Federation is coming! Early testing at @{InboxR} + ^{breadcrumbsW} $maybe msg <- mmsg diff --git a/vervis.cabal b/vervis.cabal index 89288ff..1039f0d 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -96,6 +96,7 @@ library Yesod.Paginate.Local Yesod.SessionEntity + Vervis.ActivityPub Vervis.ActivityStreams Vervis.ActorKey Vervis.Application @@ -133,6 +134,7 @@ library Vervis.Handler.Git Vervis.Handler.Group Vervis.Handler.Home + Vervis.Handler.Inbox Vervis.Handler.Key Vervis.Handler.Person Vervis.Handler.Project @@ -202,6 +204,8 @@ library TupleSections RecordWildCards build-depends: aeson + -- For activity JSOn display in /inbox test page + , aeson-pretty -- for parsing commands sent over SSH and Darcs patch -- metadata , attoparsec @@ -256,6 +260,7 @@ library , hashable -- for source file highlighting , highlighter2 + , http-signature , git , hit-graph , hit-harder @@ -265,6 +270,9 @@ library -- 'git' uses it for 'GitTime' , hourglass , yesod-http-signature + , http-client + , http-client-tls + , http-conduit , http-types , libravatar , memory @@ -274,6 +282,7 @@ library -- for Database.Persist.Local , mtl , network + , network-uri , pandoc , pandoc-types -- for PathPiece instance for CI, Web.PathPieces.Local @@ -309,6 +318,7 @@ library , transformers -- probably should be replaced with lenses once I learn , tuple + , unliftio , unordered-containers , vector , wai