From e4153fc909807d9d9047e61e9bcb34fd44a2861f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 19 Jan 2019 01:56:50 +0000 Subject: [PATCH] Ugh I forgot *again* to commit a new source file, the actual InboxR handler --- src/Vervis/Handler/Inbox.hs | 234 ++++++++++++++++++++++++++++++++++++ 1 file changed, 234 insertions(+) create mode 100644 src/Vervis/Handler/Inbox.hs 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 . + - + - ♡ 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.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| +

+ 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: +

+ (NOTE: Currently only Ed25519 signatures are supported, which is + incompatible with the default RSA-SHA256 used on the Fediverse) +

    +
  1. + Publish an actor JSON document. That's like a regular + ActivityPub actor, except its publicKey object + should have one extra field named + https://forgefed.angeley.es/ns#algorithm and its + value should be + https://forgefed.angeley.es/ns#ed25519. The actual + key PEM should indeed be an Ed25519 public key, rather than + RSA. +
  2. + Prepare an activity JSON document. +
  3. + 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). +

    + 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. +

    Last 10 activities posted: +

      + $forall (time, result) <- acts +
    • +
      #{show time} + $case result + $of Left e +
      #{e} + $of Right (ct, o) +
      #{BC.unpack ct} + 
      #{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)