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)