{- 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
    , getPublishR
    , getOutboxR
    , getOutboxItemR
    , 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.Logger.CallStack
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 Data.Aeson.Local
import Database.Persist.Local
import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids

import Vervis.ActorKey
import Vervis.Federation
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.RemoteActorStore
import Vervis.Settings

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, report) <- acts
                <li>
                  <div>#{show time}
                  $case report
                    $of ActivityReportHandlerError e
                      <div>Handler error:
                      <div>#{e}
                    $of ActivityReportWorkerError ct o e
                      <div><code>#{BC.unpack ct}
                      <div><pre>#{decodeUtf8 o}
                      <div>#{displayException e}
                    $of ActivityReportUsed msg
                      <div>#{msg}
                    $of ActivityReportUnused ct o msg
                      <div><code>#{BC.unpack ct}
                      <div><pre>#{decodeUtf8 o}
                      <div>#{msg}
        |]

postInboxR :: Handler ()
postInboxR = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod
    now <- liftIO getCurrentTime
    r <- runExceptT $ getActivity now
    case r of
        Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) ->
            forkHandler (handleWorkerError now ct d) $ do
                (msg, stored) <- handleInboxActivity raw h iid rsid a
                if stored
                    then recordUsed now msg
                    else recordUnused now ct d msg
        Left e -> do
            recordError now e
            notAuthenticated
    where
    liftE = ExceptT . pure
    handleWorkerError now ct d e = do
        logError $ "postInboxR worker error: " <> T.pack (displayException e)
        recordActivity now $ ActivityReportWorkerError ct (encodePretty d) e
    recordActivity now item = do
        acts <- getsYesod appActivities
        liftIO $ atomically $ modifyTVar' acts $ \ vec ->
            let vec' = (now, item) `V.cons` vec
            in  if V.length vec' > 10
                    then V.init vec'
                    else vec'
    recordUsed now msg = recordActivity now $ ActivityReportUsed msg
    recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg
    recordError now e = recordActivity now $ ActivityReportHandlerError e
    getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteActorId)))
    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 . actorDetailId <$> liftE result
        ActorDetail uActor iid rsid <- liftE result
        let (h, luActor) = f2l uActor
        wv@(WithValue _ (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, (wv, (iid, rsid)))

{-
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, Maybe FedURI, Maybe FedURI, Text)
activityForm = renderDivs $ (,,,)
    <$> areq fedUriField "To"          (Just defto)
    <*> aopt fedUriField "Replying on" (Just $ Just defctx)
    <*> aopt fedUriField "Context"     (Just $ Just defctx)
    <*> areq textField   "Message"     (Just defmsg)
    where
    defto = FedURI "forge.angeley.es" "/s/fr33/p/sandbox" ""
    defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" ""
    defmsg = "Hi! I'm testing federation. Can you see my message? :)"

activityWidget :: ShrIdent -> Widget -> Enctype -> Widget
activityWidget shr 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 shr} enctype=#{enctype}>
          ^{widget}
          <input type=submit>
    |]

getUserShrIdent :: Handler ShrIdent
getUserShrIdent = do
    Entity _ p <- requireVerifiedAuth
    s <- runDB $ get404 $ personIdent p
    return $ sharerIdent s

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

getOutboxR :: ShrIdent -> Handler TypedContent
getOutboxR = error "Not implemented yet"

getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
getOutboxItemR = error "Not implemented yet"

postOutboxR :: ShrIdent -> Handler Html
postOutboxR shr = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod
    ((result, widget), enctype) <- runFormPost activityForm
    case result of
        FormMissing -> setMessage "Field(s) missing"
        FormFailure _l -> setMessage "Invalid input, see below"
        FormSuccess (to, mparent, mcontext, msg) -> do
            renderUrl <- getUrlRender
            route2uri <- getEncodeRouteFed
            now <- liftIO getCurrentTime
            let (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 = deliverTo to
                    , activitySpecific = CreateActivity Create
                        { createObject = Note
                            { noteId        = Just $ appendPath actor "/fake-note"
                            , noteAttrib    = actor
                            , noteAudience  = deliverTo to
                            , noteReplyTo   = mparent
                            , noteContext   = mcontext
                            , notePublished = Just now
                            , 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 shr 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 (UniqueRemoteActor 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 = RemoteActor lto iid inbox Nothing
                            if inew
                                then insert_ rs
                                else insertUnique_ rs
                        return $ Just inbox
            Right (Entity _rsid rs) -> return $ Just $ remoteActorInbox rs

getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
getActorKey choose route = selectRep $ provideAP $ do
    actorKey <-
        liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
        getsYesod appActorKeys
    route2uri <- getEncodeRouteFed
    let (host, id_) = f2l $ route2uri route
    return $ 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