vervis/src/Vervis/Handler/Inbox.hs

{- 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
    , getOutboxR
    , postOutboxR
    , getActorKey1R
    , getActorKey2R
    )
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
import Data.Aeson.Encode.Pretty.ToEncoding
import Data.Bifunctor (first, second)
import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty (..))
import Data.PEM (PEM (..))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Interval (TimeInterval, toTimeUnit)
import Data.Time.Units (Second)
import Database.Persist (Entity (..))
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.HTTP.Types.Header (hDate, hHost)
import Text.Blaze.Html (Html)
import UnliftIO.Exception (try)
import Yesod.Auth (requireAuth)
import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Json (requireJsonBody)
import Yesod.Core.Handler
import Yesod.Form.Fields (Textarea (..), textareaField)
import Yesod.Form.Functions (areq, checkMMap, runFormPost, renderDivs)
import Yesod.Form.Types (Field, Enctype, FormResult (..))
import Yesod.Persist.Core (runDB, get404)

import qualified Data.ByteString.Char8 as BC (unpack)
import qualified Data.CaseInsensitive as CI (mk)
import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
import qualified Data.Text as T (pack, unpack)
import qualified Data.Text.Lazy as TL (toStrict)
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 Yesod.HttpSignature (verifyRequestSignature)

import qualified Network.HTTP.Signature as S (Algorithm (..))

import Network.FedURI
import Web.ActivityPub

import Vervis.ActorKey
import Vervis.Foundation
import Vervis.Model
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
    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"
        HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
        uActor <- liftE result
        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 parseFedURI t of
                        Left e -> Left $ "Activity actor URI parsing failed: " ++ e
                        Right 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 parseFedURI t of
                            Left e -> Left $ "Activity actor URI parsing failed: " ++ e
                            Right 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)

jsonField :: (FromJSON a, ToJSON a) => Field Handler a
jsonField = checkMMap fromTextarea toTextarea textareaField
    where
    toTextarea = Textarea . TL.toStrict . encodePrettyToLazyText
    fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea

activityForm :: Form Activity
activityForm = renderDivs $ areq jsonField "" $ Just defval
    where
    defval = Activity
        { activityTo = FedURI "forge.angeley.es" "/p/aviva" ""
        , activityJSON = M.fromList
            [ "@context" .= ("https://www.w3.org/ns/activitystreams" :: Text)
            , "type"     .= ("Create" :: Text)
            , "object"   .= object
                [ "type"    .= ("Note" :: Text)
                , "content" .= ("Hi! Nice to meet you :)" :: Text)
                , "to"      .= ("https://forge.angeley.es/p/luke" :: Text)
                ]
            ]
        }

activityWidget :: Widget -> Enctype -> Widget
activityWidget widget enctype =
    [whamlet|
        <p>Enter an activity JSON document and click "Submit" to send it.
        <p>NOTES:
        <ul>
          <li>
            This is a test page for implementing federation in Vervis. The
            activities just reach a test page, nothing really gets published or
            changed otherwise.
          <li>
            The activity itself just needs to be valid JSON and pass some sanity
            checks. It isn't verified to look like an ActivityPub activity with
            ActivityStreams2 properties. So, you can probably post weird things
            and they will pass.
          <li>
            The generated HTTP Signature uses Ed25519, while AFAIK the
            Fediverse generally uses RSA, specifically RSA-PKCS1.5 (i.e. not
            PSS) with SHA-256. In other words, send the activities to another
            Vervis instance, not to Mastodon etc., because the latter won't
            accept them.
          <li>
            Addressing is determined by the "to" field, which has to be a
            single actor URL. The fields "cc" and "bcc" are ignored at the
            moment.

        <form method=POST action=@{OutboxR} enctype=#{enctype}>
          ^{widget}
          <input type=submit>
    |]

getOutboxR :: Handler Html
getOutboxR = do
    ((_result, widget), enctype) <- runFormPost activityForm
    defaultLayout $ activityWidget widget enctype

postOutboxR :: Handler Html
postOutboxR = do
    ((result, widget), enctype) <- runFormPost activityForm
    defaultLayout $ activityWidget widget enctype
    case result of
        FormMissing -> setMessage "Field(s) missing"
        FormFailure _l -> setMessage "Invalid input, see below"
        FormSuccess (Activity to act) -> do
            Entity _pid person <- requireAuth
            let sid = personIdent person
            sharer <- runDB $ get404 sid
            let shr = sharerIdent sharer
            renderUrl <- getUrlRender
            let actorID = renderUrl $ PersonR shr
                actID = actorID <> "/fake/1"
                objID = actorID <> "/fake/2"
                keyID1 = renderUrl ActorKey1R
                keyID2 = renderUrl ActorKey2R
                updateObj (Object obj) = Object $ M.insert "attributedTo" (String actorID) $ M.insert "id" (String objID) obj
                updateObj v            = v
                updateAct = M.adjust updateObj "object" . M.insert "actor" (String actorID) . M.insert "id" (String actID)
            manager <- getsYesod appHttpManager
            eres <- httpGetAP manager to
            case eres of
                Left (APGetErrorHTTP e) -> setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e)
                Left (APGetErrorJSON e) -> setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e)
                Left (APGetErrorContentType e) -> setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e
                Right response -> do
                    let actor = getResponseBody response
                    if actorId actor /= to
                        then setMessage "Fetched actor JSON but its id doesn't match the URL we fetched"
                        else do
                            (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
                            let (keyID, akey) =
                                    if new1
                                        then (keyID1, akey1)
                                        else (keyID2, akey2)
                                sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
                            eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID (updateAct act)
                            case eres' of
                                Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
                                Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
    defaultLayout $ activityWidget widget enctype

getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
getActorKey choose route = do
    actorKey <-
        liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
        getsYesod appActorKeys
    renderUrl <- getUrlRender
    let route2uri r =
            case parseFedURI $ renderUrl r of
                Left e -> error e
                Right u -> u
    selectRep $
        provideAP PublicKey
            { publicKeyId      = route2uri route
            , publicKeyExpires = Nothing
            , publicKeyOwner   = route2uri HomeR
            , publicKeyPem     = PEM "PUBLIC KEY" [] actorKey
            , publicKeyAlgo    = Just AlgorithmEd25519
            , publicKeyShared  = True
            }

getActorKey1R :: Handler TypedContent
getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R

getActorKey2R :: Handler TypedContent
getActorKey2R = getActorKey (\ (k1, _, _) -> k1) ActorKey2R