Ugh I forgot *again* to commit a new source file, the actual InboxR handler
This commit is contained in:
parent
df01560ea6
commit
e4153fc909
1 changed files with 234 additions and 0 deletions
234
src/Vervis/Handler/Inbox.hs
Normal file
234
src/Vervis/Handler/Inbox.hs
Normal file
|
@ -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)
|
Loading…
Reference in a new issue