{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2022, 2023 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.Web.Actor
    ( getInbox
    , postInbox
    , getOutbox
    , getOutboxItem
    , getFollowersCollection
    , getActorFollowersCollection
    , getFollowingCollection
    , handleRobotInbox
    , serveInstanceKey
    , servePerActorKey
    )
where

import Control.Applicative ((<|>))
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
import Control.Exception hiding (Handler)
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.Reader
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Foldable (for_)
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock
import Data.Time.Interval (TimeInterval, toTimeUnit)
import Data.Time.Units (Second)
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Types.Status
import Text.Blaze.Html (Html, preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS
import Text.Shakespeare.I18N (RenderMessage)
import Yesod.Core hiding (logDebug)
import Yesod.Core.Handler
import Yesod.Form.Fields
import Yesod.Form.Functions
import Yesod.Form.Types
import Yesod.Persist.Core

import qualified Data.ByteString.Char8 as BC (unpack)
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V
import qualified Database.Esqueleto as E

import Control.Concurrent.Actor
import Crypto.ActorKey
import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub hiding (Project (..), ActorLocal (..))
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource

import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.EventTime.Local
import Data.Paginate.Local
import Data.Time.Clock.Local
import Database.Persist.Local
import Yesod.Persist.Local

import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
import qualified Web.ActivityPub as AP

import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..))
import Vervis.ActivityPub
import Vervis.API
import Vervis.Data.Actor
import Vervis.Data.Ticket
import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model hiding (Ticket)
import Vervis.Model.Ident
import Vervis.Paginate
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket

getShowTime = showTime <$> liftIO getCurrentTime
    where
    showTime now =
        showEventTime .
        intervalToEventTime .
        FriendlyConvert .
        diffUTCTime now

objectSummary o =
    case M.lookup "summary" o of
        Just (String t) | not (T.null t) -> Just t
        _ -> Nothing

objectId o =
    case M.lookup "id" o <|> M.lookup "@id" o of
        Just (String t) | not (T.null t) -> t
        _ ->
            error $
                "'id' field not found" ++
                TL.unpack (P.encodePrettyToLazyText o)

getInbox here actor hash = do
    key <- decodeKeyHashid404 hash
    (total, pages, mpage) <- runDB $ do
        inboxID <- do
            actorID <- actor <$> get404 key
            actorInbox <$> getJust actorID
        getPageAndNavCount
            (countItems inboxID)
            (\ off lim -> map adaptItem <$> getItems inboxID off lim)

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRoutePageLocal <- getEncodeRoutePageLocal
    let here' = here hash
        pageUrl = encodeRoutePageLocal here'
    host <- getsYesod $ appInstanceHost . appSettings
    selectRep $
        case mpage of
            Nothing -> do
                provideAP $ pure $ Doc host $ Collection
                    { collectionId         = encodeRouteLocal here'
                    , collectionType       = CollectionTypeOrdered
                    , collectionTotalItems = Just total
                    , collectionCurrent    = Nothing
                    , collectionFirst      = Just $ pageUrl 1
                    , collectionLast       = Just $ pageUrl pages
                    , collectionItems      = [] :: [Text]
                    }
                provideRep (redirectFirstPage here' :: Handler Html)
            Just (items, navModel) -> do
                let current = nmCurrent navModel
                provideAP $ pure $ Doc host $ CollectionPage
                    { collectionPageId         = pageUrl current
                    , collectionPageType       = CollectionPageTypeOrdered
                    , collectionPageTotalItems = Nothing
                    , collectionPageCurrent    = Just $ pageUrl current
                    , collectionPageFirst      = Just $ pageUrl 1
                    , collectionPageLast       = Just $ pageUrl pages
                    , collectionPagePartOf     = encodeRouteLocal here'
                    , collectionPagePrev       =
                        if current > 1
                            then Just $ pageUrl $ current - 1
                            else Nothing
                    , collectionPageNext       =
                        if current < pages
                            then Just $ pageUrl $ current + 1
                            else Nothing
                    , collectionPageStartIndex = Nothing
                    , collectionPageItems      = map fst items
                    }
                provideRep $ do
                    let pageNav = navWidget navModel
                    showTime <- getShowTime
                    defaultLayout $(widgetFile "person/inbox")
    where
    countItems ibid =
        (+) <$> count [InboxItemLocalInbox ==. ibid]
            <*> count [InboxItemRemoteInbox ==. ibid]
    getItems ibid off lim =
        E.select $ E.from $
            \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
                E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
                E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
                E.where_
                    $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
                        ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
                      )
                    E.&&.
                      ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
                        ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
                      )
                E.orderBy [E.desc $ ib E.^. InboxItemId]
                E.offset $ fromIntegral off
                E.limit $ fromIntegral lim
                return
                    ( ib E.^. InboxItemId
                    , ob E.?. OutboxItemActivity
                    , ob E.?. OutboxItemPublished
                    , ract E.?. RemoteActivityContent
                    , ract E.?. RemoteActivityReceived
                    )
    adaptItem
        (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) =
            case (mact, mpub, mobj, mrec) of
                (Nothing, Nothing, Nothing, Nothing) ->
                    error $ ibiidString ++ " neither local nor remote"
                (Just _, Just _, Just _, Just _) ->
                    error $ ibiidString ++ " both local and remote"
                (Just act, Just pub, Nothing, Nothing) ->
                    (persistJSONObject act, (pub, False))
                (Nothing, Nothing, Just obj, Just rec) ->
                    (persistJSONObject obj, (rec, True))
                _ -> error $ "Unexpected query result for " ++ ibiidString
        where
        ibiidString = "InboxItem #" ++ show (fromSqlKey ibid)

postInbox :: LocalActorBy Key -> Handler ()
postInbox recipByKey = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod
    contentTypes <- lookupHeaders "Content-Type"
    now <- liftIO getCurrentTime
    result <- runExceptT $ do
        (auth, body) <- authenticateActivity now
        verse <-
            case auth of
                ActivityAuthLocal authorByKey -> Left <$> do
                    outboxItemID <-
                        parseAuthenticatedLocalActivityURI
                            authorByKey
                            (AP.activityId $ actbActivity body)
                    return $ EventRemoteFwdLocalActivity authorByKey outboxItemID
                ActivityAuthRemote author -> Right <$> do
                    luActivity <-
                        fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
                    localRecips <- do
                        mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
                        paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
                    recipByHash <- hashLocalActor recipByKey
                    msig <- checkForwarding recipByHash
                    let mfwd = (localRecips,) <$> msig
                    return $ VerseRemote author body mfwd luActivity
        theater <- getsYesod appTheater
        r <- liftIO $ callIO theater recipByKey verse
        case r of
            Nothing -> notFound
            Just (Left e) -> throwE e
            Just (Right t) -> return (actbObject body, t)
    recordActivity now result contentTypes
    case result of
        Left err -> do
            logDebug err
            sendResponseStatus badRequest400 err
        Right _ -> return ()
    where
    recordActivity
        :: (MonadSite m, SiteEnv m ~ App)
        => UTCTime -> Either Text (Object, Text) -> [ContentType] -> m ()
    recordActivity now result contentTypes = do
        macts <- asksSite appActivities
        for_ macts $ \ (size, acts) ->
            liftIO $ atomically $ modifyTVar' acts $ \ vec ->
                let (msg, body) =
                        case result of
                            Left t -> (t, "{?}")
                            Right (o, t) -> (t, encodePretty o)
                    item = ActivityReport now msg contentTypes body
                    vec' = item `V.cons` vec
                in  if V.length vec' > size
                        then V.init vec'
                        else vec'
    parseAuthenticatedLocalActivityURI
        :: (MonadSite m, YesodHashids (SiteEnv m))
        => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId
    parseAuthenticatedLocalActivityURI author maybeActivityURI = do
        luAct <- fromMaybeE maybeActivityURI "No 'id'"
        (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct
        unless (actorByKey == author) $
            throwE "'actor' actor and 'id' actor mismatch"
        return outboxItemID

getOutbox here itemRoute grabActorID hash = do
    key <- decodeKeyHashid404 hash
    (total, pages, mpage) <- runDB $ do
        outboxID <- do
            actorID <- grabActorID <$> get404 key
            actorOutbox <$> getJust actorID
        let countAllItems = count [OutboxItemOutbox ==. outboxID]
            selectItems off lim = selectList [OutboxItemOutbox ==. outboxID] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
        getPageAndNavCount countAllItems selectItems

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRoutePageLocal <- getEncodeRoutePageLocal
    let here' = here hash
        pageUrl = encodeRoutePageLocal here'
    host <- getsYesod $ appInstanceHost . appSettings
    selectRep $
        case mpage of
            Nothing -> do
                provideAP $ pure $ Doc host $ Collection
                    { collectionId         = encodeRouteLocal here'
                    , collectionType       = CollectionTypeOrdered
                    , collectionTotalItems = Just total
                    , collectionCurrent    = Nothing
                    , collectionFirst      = Just $ pageUrl 1
                    , collectionLast       = Just $ pageUrl pages
                    , collectionItems      = [] :: [Text]
                    }
                provideRep (redirectFirstPage here' :: Handler Html)
            Just (items, navModel) -> do
                let current = nmCurrent navModel
                provideAP $ pure $ Doc host $ CollectionPage
                    { collectionPageId         = pageUrl current
                    , collectionPageType       = CollectionPageTypeOrdered
                    , collectionPageTotalItems = Nothing
                    , collectionPageCurrent    = Just $ pageUrl current
                    , collectionPageFirst      = Just $ pageUrl 1
                    , collectionPageLast       = Just $ pageUrl pages
                    , collectionPagePartOf     = encodeRouteLocal here'
                    , collectionPagePrev       =
                        if current > 1
                            then Just $ pageUrl $ current - 1
                            else Nothing
                    , collectionPageNext       =
                        if current < pages
                            then Just $ pageUrl $ current + 1
                            else Nothing
                    , collectionPageStartIndex = Nothing
                    , collectionPageItems      = map (persistJSONObject . outboxItemActivity . entityVal) items
                    }
                provideRep $ do
                    let pageNav = navWidget navModel
                    showTime <- getShowTime
                    hashItem <- getEncodeKeyHashid
                    defaultLayout $(widgetFile "person/outbox")

getOutboxItem here actor topicHash itemHash = do
    topicID <- decodeKeyHashid404 topicHash
    itemID <- decodeKeyHashid404 itemHash
    body <- runDB $ do
        outboxID <- do
            actorID <- actor <$> get404 topicID
            actorOutbox <$> getJust actorID
        item <- get404 itemID
        unless (outboxItemOutbox item == outboxID) notFound
        return $ outboxItemActivity item
    let here' = here topicHash itemHash
    provideHtmlAndAP'' body $ redirectToPrettyJSON here'

getLocalActors
    :: [ActorId] -> ReaderT SqlBackend Handler [LocalActorBy Key]
getLocalActors actorIDs = do
    localActors <-
        concat <$> sequenceA
            [ map LocalActorPerson <$>
                selectKeysList [PersonActor <-. actorIDs] []
            , map LocalActorGroup <$>
                selectKeysList [GroupActor <-. actorIDs] []
            , map LocalActorRepo <$>
                selectKeysList [RepoActor <-. actorIDs] []
            , map LocalActorDeck <$>
                selectKeysList [DeckActor <-. actorIDs] []
            , map LocalActorLoom <$>
                selectKeysList [LoomActor <-. actorIDs] []
            ]
    case compare (length localActors) (length actorIDs) of
        LT -> error "Found actor ID not used by any specific actor"
        GT -> error "Found actor ID used by multiple specific actors"
        EQ -> return localActors

getFollowersCollection
    :: Route App -> AppDB FollowerSetId -> Handler TypedContent
getFollowersCollection here getFsid = do
    (locals, remotes, l, r) <- runDB $ do
        fsid <- getFsid
        (,,,) <$> do actorIDs <-
                        map (followActor . entityVal) <$>
                            selectList
                                [FollowTarget ==. fsid, FollowPublic ==. True]
                                []
                     getLocalActors actorIDs
              <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
                        E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
                        E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
                        E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
                        E.where_
                            $     rf E.^. RemoteFollowTarget E.==. E.val fsid
                            E.&&. rf E.^. RemoteFollowPublic E.==. E.val True
                        return
                            ( i E.^. InstanceHost
                            , ro E.^. RemoteObjectIdent
                            )
              <*> count [FollowTarget ==. fsid]
              <*> count [RemoteFollowTarget ==. fsid]

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    hashActor <- getHashLocalActor
    let followersAP = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ l + r
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      =
                map (encodeRouteHome . renderLocalActor . hashActor) locals ++
                map (uncurry ObjURI . bimap E.unValue E.unValue) remotes
            }
    provideHtmlAndAP followersAP $ redirectToPrettyJSON here

getActorFollowersCollection here actor hash = do
    key <- decodeKeyHashid404 hash
    getFollowersCollection (here hash) (getFsid key)
    where
    getFsid key = do
        actorID <- actor <$> get404 key
        actorFollowers <$> getJust actorID

getFollowingCollection here actor hash = do
    key <- decodeKeyHashid404 hash
    (localTotal, localActors, workItems, remotes) <- runDB $ do
        followerActorID <- actor <$> get404 key
        followerSetIDs <-
            map (followTarget . entityVal) <$>
                selectList [FollowActor ==. followerActorID] []
        actorIDs <- selectKeysList [ActorFollowers <-. followerSetIDs] []
        ticketIDs <- selectKeysList [TicketFollowers <-. followerSetIDs] []
        (,,,) (length followerSetIDs)
            <$> getLocalActors actorIDs
            <*> ((++) <$> getTickets ticketIDs <*> getCloths ticketIDs)
            <*> getRemotes followerActorID

    hashActor <- getHashLocalActor
    hashItem <- getHashWorkItem
    let locals =
            map (renderLocalActor . hashActor) localActors ++
            map (workItemRoute . hashItem) workItems
    unless (length locals == localTotal) $
        error "Bug! List length mismatch"

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let here' = here hash
        followingAP = Collection
            { collectionId         = encodeRouteLocal here'
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ localTotal + length remotes
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      = map encodeRouteHome locals ++ remotes
            }
    provideHtmlAndAP followingAP $ redirectToPrettyJSON here'
    where
    getTickets tids =
        map workItem <$> selectList [TicketDeckTicket <-. tids] []
        where
        workItem (Entity t (TicketDeck _ d)) = WorkItemTicket d t
    getCloths tids =
        map workItem <$> selectList [TicketLoomTicket <-. tids] []
        where
        workItem (Entity c (TicketLoom _ l _)) = WorkItemCloth l c
    getRemotes aid =
        map (followRemoteTarget . entityVal) <$>
            selectList [FollowRemoteActor ==. aid] []

handleRobotInbox
    :: LocalActorBy KeyHashid
    -> (  UTCTime
       -> RemoteAuthor
       -> ActivityBody
       -> Maybe (RecipientRoutes, ByteString)
       -> LocalURI
       -> SpecificActivity URIMode
       -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
       )
    -> UTCTime
    -> ActivityAuthentication
    -> ActivityBody
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleRobotInbox recipByHash handleSpecific now auth body = do
    remoteAuthor <-
        case auth of
            ActivityAuthLocal _ -> throwE "Got a forwarded local activity, I don't need those"
            ActivityAuthRemote ra -> return ra
    luActivity <-
        fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
    localRecips <- do
        mrecips <- parseAudience $ activityAudience $ actbActivity body
        paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
    msig <- checkForwarding recipByHash
    let mfwd = (localRecips,) <$> msig
    handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body)

actorKeyAP
    :: ( MonadSite m, SiteEnv m ~ site
       , SiteFedURI site, SiteFedURIMode site ~ u
       )
    => Maybe (Route site) -> Route site -> ActorKey -> m (AP.PublicKey u)
actorKeyAP maybeHolderR keyR akey = do
    encodeRouteLocal <- getEncodeRouteLocal
    return AP.PublicKey
        { AP.publicKeyId       = LocalRefURI $ Left $ encodeRouteLocal keyR
        , AP.publicKeyExpires  = Nothing
        , AP.publicKeyOwner    =
            case maybeHolderR of
                Nothing -> AP.OwnerInstance
                Just holderR -> AP.OwnerActor $ encodeRouteLocal holderR
        , AP.publicKeyMaterial = actorKeyPublicBin akey
        }

serveInstanceKey
    :: ((ActorKey, ActorKey) -> ActorKey)
    -> Route App
    -> Handler TypedContent
serveInstanceKey choose keyR = do
    maybeKeys <- asksSite appActorKeys
    case maybeKeys of
        Nothing -> notFound
        Just keys -> do
            akey <- liftIO $ do
                (akey1, akey2, _) <- readTVarIO keys
                return $ choose (akey1, akey2)
            keyAP <- actorKeyAP Nothing keyR akey
            provideHtmlAndAP keyAP $ redirectToPrettyJSON keyR

servePerActorKey'
    :: LocalActorBy KeyHashid
    -> KeyHashid SigKey
    -> ActorKey
    -> Handler TypedContent
servePerActorKey' holderByHash keyHash akey = do
    let holderR = renderLocalActor holderByHash
        keyR = stampRoute holderByHash keyHash
    keyAP <- actorKeyAP (Just holderR) keyR akey
    provideHtmlAndAP keyAP $ redirectToPrettyJSON keyR

servePerActorKey
    :: (PersistRecordBackend holder SqlBackend, ToBackendKey SqlBackend holder)
    => (holder -> ActorId)
    -> (KeyHashid holder -> LocalActorBy KeyHashid)
    -> KeyHashid holder
    -> KeyHashid SigKey
    -> Handler TypedContent
servePerActorKey holderActor localActorHolder holderHash keyHash = do
    holderID <- decodeKeyHashid404 holderHash
    keyID <- decodeKeyHashid404 keyHash
    akey <- runDB $ do
        actorID <- holderActor <$> get404 holderID
        SigKey actorID' akey <- get404 keyID
        unless (actorID' == actorID) notFound
        return akey
    servePerActorKey' (localActorHolder holderHash) keyHash akey