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

@@ -1,6 +1,6 @@
 -- This file is part of Vervis.
 --
--- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+-- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
 --
 -- ♡ 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
 -- ----------------------------------------------------------------------------

src/Vervis/ActivityPub.hs

@@ -0,0 +1,146 @@
+{- 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 (..)
+    )
+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

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
+      -- ^ Secret key in binary form.
     , actorKeyPublic :: PublicKey
-    , actorKeyPublicPem :: ByteString
+      -- ^ 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
@@ -49,9 +127,10 @@ generateActorKey = mk <$> generateSecretKey
         in  ActorKey
                 { actorKeySecret = secret
                 , actorKeyPublic = public
-                , actorKeyPublicPem =
+                , actorKeyPubPEM = renderPEM public
-                    pemWriteBS $ PEM "PUBLIC KEY" [] $ convert 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 :: ActorKey -> ByteString
-actorPublicKey = actorKeyPublicPem
+--actorPublicKey = actorKeyPublicPem

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

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 Crypto.Error (CryptoFailable (..))
-import Data.Time.Units (Minute, Day)
+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 qualified Data.ByteString.Char8 as BC (unpack)
-
+import qualified Data.ByteString.Lazy as BL (ByteString)
-import Yesod.Auth.Unverified
-import Yesod.Auth.Unverified.Creds
-import Yesod.Mail.Send
-
 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)

templates/default-layout.hamlet

@@ -23,6 +23,9 @@ $nothing
     Or
     <a href=@{AuthR newAccountR}>Sign up.
 
+<p>
+  UPDATE: Federation is coming! Early testing at @{InboxR}
+
 ^{breadcrumbsW}
 
 $maybe msg <- mmsg

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