Ugh I forgot *again* to commit a new source file, the actual InboxR handler

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)