Ugh I forgot *again* to commit a new source file, the actual InboxR handler
This commit is contained in:
fr33domlover
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