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.Bifunctor (first, second)
import Data.Foldable (for_)
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 (..), getBy, insertBy, insert_)
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 Text.Shakespeare.I18N (RenderMessage)
import UnliftIO.Exception (try)
import Yesod.Auth (requireAuth)
import Yesod.Core (ContentType, defaultLayout, whamlet, toHtml, HandlerSite)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Json (requireJsonBody)
import Yesod.Core.Handler
import Yesod.Form.Fields (Textarea (..), textField, textareaField)
import Yesod.Form.Functions
import Yesod.Form.Types
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 Data.Aeson.Encode.Pretty.ToEncoding
import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified

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. To test, go to another Vervis instance's
              outbox page, submit an activity, and come back here to see
              results.
            <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, Activity)
    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
        a@(CreateActivity c) <- requireJsonBody
        liftE $ do
            if createActor c == uActor
                then Right ()
                else Left "Activity's actor != Signature key's actor"
            if noteAttrib (createObject c) == uActor
                then Right ()
                else Left "Activity object's actor doesn't match activity's actor"
        return (contentType, a)

{-
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
-}

fedUriField
    :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
fedUriField = Field
    { fieldParse = parseHelper $ \ t ->
        case parseFedURI t of
            Left e  -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
            Right u -> Right u
    , fieldView = \theId name attrs val isReq ->
        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderFedURI val}>|]
    , fieldEnctype = UrlEncoded
    }

activityForm :: Form (FedURI, Text)
activityForm = renderDivs $ (,)
    <$> areq fedUriField "To"      (Just defto)
    <*> areq textField   "Message" (Just defmsg)
    where
    defto = FedURI "forge.angeley.es" "/p/fr33" ""
    defmsg = "Hi! Nice to meet you :)"

activityWidget :: Widget -> Enctype -> Widget
activityWidget widget enctype =
    [whamlet|
        <p>
          This is a federation test page. Provide a recepient actor URI and
          message text, and a Create activity creating a new Note will be sent
          to the destination server.
        <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

route2uri' :: (Route App -> Text) -> Route App -> FedURI
route2uri' renderUrl r =
    case parseFedURI $ renderUrl r of
        Left e -> error e
        Right u -> u

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 (to, msg) -> do
            shr <- do
                Entity _pid person <- requireVerifiedAuth
                sharer <- runDB $ get404 $ personIdent person
                return $ sharerIdent sharer
            renderUrl <- getUrlRender
            let route2uri = route2uri' renderUrl
                actor = route2uri $ SharerR shr
                actorID = renderUrl $ SharerR shr
                appendPath u t = u { furiPath = furiPath u <> t }
                activity = CreateActivity Create
                    { createId     = appendPath actor "/fake-activity"
                    , createTo     = to
                    , createActor  = actor
                    , createObject = Note
                        { noteId      = appendPath actor "/fake-note"
                        , noteAttrib  = actor
                        , noteTo      = to
                        , noteReplyTo = Nothing
                        , noteContent = msg
                        }
                    }
            manager <- getsYesod appHttpManager
            minbox <- fetchInboxURI manager to
            for_ minbox $ \ inbox -> do
                (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
                let (keyID, akey) =
                        if new1
                            then (renderUrl ActorKey1R, akey1)
                            else (renderUrl ActorKey2R, akey2)
                    sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
                eres' <- httpPostAP manager inbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID activity
                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
    where
    fetchInboxURI :: Manager -> FedURI -> Handler (Maybe FedURI)
    fetchInboxURI manager to = do
        mrs <- runDB $ getBy $ UniqueRemoteSharer to
        case mrs of
            Nothing -> do
                eres <- httpGetAP manager to
                case eres of
                    Left (APGetErrorHTTP e) -> do
                        setMessage $ toHtml $ "Failed to GET the recipient actor: " <> T.pack (displayException e)
                        return Nothing
                    Left (APGetErrorJSON e) -> do
                        setMessage $ toHtml $ "Failed to parse recipient actor JSON: " <> T.pack (displayException e)
                        return Nothing
                    Left (APGetErrorContentType e) -> do
                        setMessage $ toHtml $ "Got unexpected Content-Type for actor JSON: " <> e
                        return Nothing
                    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" >> return Nothing
                            else do
                                let inbox = actorInbox actor
                                runDB $ do
                                    iid <- either entityKey id <$> insertBy (Instance $ furiHost to)
                                    insert_ $ RemoteSharer to iid inbox
                                return $ Just inbox
            Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs

getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
getActorKey choose route = do
    actorKey <-
        liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
        getsYesod appActorKeys
    route2uri <- route2uri' <$> getUrlRender
    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