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
import Control.Monad.IO.Class (liftIO)
import Control.Monad.STM (atomically)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
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, concat)
import qualified Data.Text.Lazy as TL (toStrict)
import qualified Data.Vector as V
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 Database.Persist.Local
import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified

import Vervis.ActorKey
import Vervis.Foundation
import Vervis.Model
import Vervis.RemoteActorStore
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, Doc 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
        (h, luActor) <- f2l <$> liftE result
        d@(Doc h' a) <- requireJsonBody
        unless (h == h') $
            throwE "Activity host doesn't match signature key host"
        unless (activityActor a == luActor) $
            throwE "Activity's actor != Signature key's actor"
        return (contentType, d)

{-
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" "/s/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
                (h, actor) = f2l $ route2uri $ SharerR shr
                actorID = renderUrl $ SharerR shr
                appendPath u t = u { luriPath = luriPath u <> t }
                activity = Activity
                    { activityId       = appendPath actor "/fake-activity"
                    , activityActor    = actor
                    , activityAudience = Audience
                        { audienceTo      = V.singleton to
                        , audienceBto     = V.empty
                        , audienceCc      = V.empty
                        , audienceBcc     = V.empty
                        , audienceGeneral = V.empty
                        }
                    , activitySpecific = CreateActivity Create
                        { createObject = Note
                            { noteId      = appendPath actor "/fake-note"
                            , noteReplyTo = Nothing
                            , noteContent = msg
                            }
                        }
                    }
            manager <- getsYesod appHttpManager
            let (host, lto) = f2l to
            minbox <- fetchInboxURI manager host lto
            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 (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID $ Doc h 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 -> Text -> LocalURI -> Handler (Maybe LocalURI)
    fetchInboxURI manager h lto = do
        mrs <- runDB $ do
            mi <- getBy $ UniqueInstance h
            case mi of
                Nothing -> return $ Left Nothing
                Just (Entity iid _) ->
                    maybe (Left $ Just iid) Right <$>
                        getBy (UniqueRemoteSharer iid lto)
        case mrs of
            Left miid -> do
                eres <- fetchAPID manager actorId h lto
                case eres of
                    Left s -> do
                        setMessage $ toHtml $ T.concat
                            [ "Tried to fetch recipient actor <"
                            , renderFedURI $ l2f h lto
                            , "> and got an error: "
                            , T.pack s
                            ]
                        return Nothing
                    Right actor -> withHostLock h $ do
                        let inbox = actorInbox actor
                        runDB $ do
                            (iid, inew) <-
                                case miid of
                                    Just iid -> return (iid, False)
                                    Nothing -> idAndNew <$> insertBy (Instance h)
                            let rs = RemoteSharer lto iid inbox
                            if inew
                                then insert_ rs
                                else insertUnique_ rs
                        return $ Just inbox
            Right (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
    let (host, id_) = f2l $ route2uri route
    selectRep $
        provideAP $ Doc host PublicKey
            { publicKeyId       = id_
            , publicKeyExpires  = Nothing
            , publicKeyOwner    = OwnerInstance
            , publicKeyMaterial = actorKey
            --, publicKeyAlgo    = Just AlgorithmEd25519
            }

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

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