diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs
new file mode 100644
index 0000000..e07ed54
--- /dev/null
+++ b/src/Vervis/Handler/Inbox.hs
@@ -0,0 +1,234 @@
+{- 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.Handler.Inbox
+ ( getInboxR
+ , postInboxR
+ )
+where
+
+import Prelude
+
+import Control.Applicative ((<|>))
+import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
+import Control.Exception (displayException)
+import Control.Monad.IO.Class (liftIO)
+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.Bifunctor (first, second)
+import Data.HashMap.Strict (HashMap)
+import Data.PEM (pemContent)
+import Data.Text (Text)
+import Data.Text.Lazy.Encoding (decodeUtf8)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Interval (TimeInterval, toTimeUnit)
+import Data.Time.Units (Second)
+import Network.HTTP.Client (Manager, HttpException, requestFromURI)
+import Network.HTTP.Simple (httpJSONEither, getResponseBody)
+import Network.URI (URI (uriFragment), parseURI)
+import Text.Blaze.Html (Html)
+import UnliftIO.Exception (try)
+import Yesod.Core (ContentType, defaultLayout, whamlet)
+import Yesod.Core.Json (requireJsonBody)
+import Yesod.Core.Handler
+
+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.Vector as V (length, cons, init)
+import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
+
+import Network.HTTP.Signature hiding (Algorithm (..))
+
+import qualified Network.HTTP.Signature as S (Algorithm (..))
+
+import Vervis.ActivityPub
+import Vervis.Foundation (App (..), Handler)
+import Vervis.Settings (AppSettings (appHttpSigTimeLimit))
+
+getInboxR :: Handler Html
+getInboxR = do
+ acts <- liftIO . readTVarIO =<< getsYesod appActivities
+ defaultLayout
+ [whamlet|
+ <p>
+ Welcome to the ActivityPub inbox test page! It's the beginning of
+ federation support in Vervis. Currently POSTing activities
+ doesn't do anything, they're just verified and the results are
+ displayed on this page. Here's how to POST an activity
+ successfully:
+ <p>
+ (NOTE: Currently only Ed25519 signatures are supported, which is
+ incompatible with the default RSA-SHA256 used on the Fediverse)
+ <ol>
+ <li>
+ Publish an actor JSON document. That's like a regular
+ ActivityPub actor, except its <var>publicKey</var> object
+ should have one extra field named
+ <code>https://forgefed.angeley.es/ns#algorithm</code> and its
+ value should be
+ <code>https://forgefed.angeley.es/ns#ed25519</code>. The actual
+ key PEM should indeed be an Ed25519 public key, rather than
+ RSA.
+ <li>
+ Prepare an activity JSON document.
+ <li>
+ POST it to this page's URL, with an HTTP signature in a
+ Signature header, and use at least the headers Host, Date and
+ (request-target).
+ <p>
+ I'm aware these instructions aren't exactly clear and
+ self-contained. Soon I'll either clarify them or further
+ development will make things easier. In particular, by using one
+ Vervis instance to POST an activity to another Vervis instance.
+ <p>Last 10 activities posted:
+ <ul>
+ $forall (time, result) <- acts
+ <li>
+ <div>#{show time}
+ $case result
+ $of Left e
+ <div>#{e}
+ $of Right (ct, o)
+ <div><code>#{BC.unpack ct}
+ <div><pre>#{decodeUtf8 o}
+ |]
+
+postInboxR :: Handler ()
+postInboxR = do
+ now <- liftIO getCurrentTime
+ r <- runExceptT $ getActivity now
+ let item = (now, second (second encodePretty) r)
+ acts <- getsYesod appActivities
+ liftIO $ atomically $ modifyTVar' acts $ \ vec ->
+ let vec' = item `V.cons` vec
+ in if V.length vec' > 10
+ then V.init vec'
+ else vec'
+ case r of
+ Right _ -> return ()
+ Left _ -> notAuthenticated
+ where
+ liftE = ExceptT . pure
+ verifyActivity :: UTCTime -> ExceptT String Handler URI
+ verifyActivity now = do
+ site <- getYesod
+ wr <- waiRequest
+ let request = Request
+ { requestMethod = CI.mk $ W.requestMethod wr
+ , requestPath = W.rawPathInfo wr
+ , requestHeaders = W.requestHeaders wr
+ }
+ toSeconds :: TimeInterval -> Second
+ toSeconds = toTimeUnit
+ (malgo, KeyId keyid, input, Signature sig) <-
+ liftE $
+ first show $
+ prepareToVerify
+ [HeaderTarget, HeaderName "Host"]
+ (fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings $ site)
+ now
+ request
+ liftE $ case malgo of
+ Nothing -> Right ()
+ Just algo ->
+ case algo of
+ S.AlgorithmEd25519 -> Right ()
+ S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
+ u <- liftE $ case parseURI $ BC.unpack keyid of
+ Nothing -> Left "keyId in Sig header isn't a valid absolute URI"
+ Just uri -> Right uri
+ response <- ExceptT $ first (displayException :: HttpException -> String) <$> (try $ httpJSONEither =<< requestFromURI u)
+ liftE $ do
+ actor <- first displayException $ getResponseBody response
+ let uActor = u { uriFragment = "" }
+ if uActor == actorId actor
+ then Right ()
+ else Left "Actor ID doesn't match the keyid URI we fetched"
+ let pkey = actorPublicKey actor
+ if publicKeyId pkey == u
+ then Right ()
+ else Left "Actor's publicKey's ID doesn't match the keyid URI"
+ if publicKeyOwner pkey == actorId actor
+ then Right ()
+ else Left "Actor's publicKey's owner doesn't match the actor's ID"
+ case publicKeyAlgo pkey of
+ Nothing ->
+ Left $
+ case malgo of
+ Nothing -> "Algo not given in Sig nor actor"
+ Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor"
+ Just algo ->
+ case algo of
+ AlgorithmEd25519 -> Right ()
+ AlgorithmOther _ ->
+ Left $
+ case malgo of
+ Nothing -> "No algo in Sig, unsupported algo in actor"
+ Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
+ key <- case publicKey $ pemContent $ publicKeyPem pkey of
+ CryptoPassed k -> Right k
+ CryptoFailed e -> Left "Parsing Ed25519 public key failed"
+ signature <- case signature sig of
+ CryptoPassed s -> Right s
+ CryptoFailed e -> Left "Parsing Ed25519 signature failed"
+ if verify key input signature
+ then Right uActor
+ else Left "Ed25519 sig verification says not valid"
+ getActivity :: UTCTime -> ExceptT String Handler (ContentType, HashMap Text Value)
+ getActivity now = do
+ contentType <- do
+ ctypes <- lookupHeaders "Content-Type"
+ liftE $ case ctypes of
+ [] -> Left "Content-Type not specified"
+ [x] -> case x of
+ "application/activity+json" -> Right x
+ "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x
+ _ -> Left "Unknown Content-Type"
+ _ -> Left "More than one Content-Type given"
+ uActor <- verifyActivity now
+ o <- requireJsonBody
+ activityActor <-
+ liftE $
+ case M.lookup "actor" o of
+ Nothing -> Left "Activity has no actor member"
+ Just v -> case v of
+ String t -> case parseURI $ T.unpack t of
+ Nothing -> Left "Activity actor URI parsing failed"
+ Just uri -> Right uri
+ _ -> Left "Activity actor isn't a JSON string"
+ liftE $ if activityActor == uActor
+ then Right ()
+ else Left "Activity's actor != Signature key's actor"
+ liftE $ case M.lookup "object" o of
+ Nothing -> Right ()
+ Just v -> case v of
+ Object obj -> case M.lookup "actor" obj <|> M.lookup "attributedTo" obj of
+ Nothing -> Right ()
+ Just v' -> case v' of
+ String t -> case parseURI $ T.unpack t of
+ Nothing -> Left "Activity actor URI parsing failed"
+ Just uri ->
+ if uri == uActor
+ then Right ()
+ else Left "Activity object's actor doesn't match activity's actor"
+ _ -> Left "Activity actor isn't a JSON string"
+ _ -> Left "Activity's object isn't a JSON object"
+ return (contentType, o)