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

{-# LANGUAGE RankNTypes #-}

-- These are for the Barbie-based generated instances
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Vervis.Actor
    ( -- * Local actors
      LocalActorBy (..)
    , LocalActor

      -- * Converting between KeyHashid, Key, Identity and Entity
      --
      -- Adapted from 'Vervis.Recipient'
    , hashLocalActorPure
    , getHashLocalActor
    , hashLocalActor

    , unhashLocalActorPure
    , unhashLocalActor
    , unhashLocalActorF
    , unhashLocalActorM
    , unhashLocalActorE
    , unhashLocalActor404

      -- * Local recipient set
    , TicketRoutes (..)
    , ClothRoutes (..)
    , PersonRoutes (..)
    , GroupRoutes (..)
    , RepoRoutes (..)
    , DeckRoutes (..)
    , LoomRoutes (..)
    , DeckFamilyRoutes (..)
    , LoomFamilyRoutes (..)
    , RecipientRoutes (..)

      -- * AP system base types
    , RemoteAuthor (..)
    , ActivityBody (..)
    , VerseRemote (..)

      -- * Behavior utility types
    , Verse
    , Event (..)
    , Env (..)
    , Act
    , ActE
    , ActDB
    , ActDBE
    , Theater

      -- * Behavior utilities
    , withDB
    , withDBExcept
    , behave

    , RemoteRecipient (..)
    , sendToLocalActors
    )
where

import Control.Concurrent.STM.TVar
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function
import Data.Hashable
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Data.Typeable
import Database.Persist.Sql
import GHC.Generics
import UnliftIO.Exception
import Web.Hashids
import Yesod.Core

import qualified Control.Monad.Fail as F
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashSet as HS
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Control.Concurrent.Actor
import Crypto.ActorKey
import Network.FedURI
import Web.Actor
import Web.Actor.Deliver
import Web.Actor.Persist
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Data.List.NonEmpty.Local

import Vervis.FedURI
import Vervis.Model hiding (Actor, Message)
import Vervis.Settings

data LocalActorBy f
    = LocalActorPerson (f Person)
    | LocalActorGroup  (f Group)
    | LocalActorRepo   (f Repo)
    | LocalActorDeck   (f Deck)
    | LocalActorLoom   (f Loom)
    deriving (Generic, FunctorB, ConstraintsB)

deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)
deriving instance AllBF Hashable f LocalActorBy => Hashable (LocalActorBy f)
deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f)

type LocalActor = LocalActorBy KeyHashid

hashLocalActorPure
    :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
hashLocalActorPure ctx = f
    where
    f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
    f (LocalActorGroup g)  = LocalActorGroup $ encodeKeyHashidPure ctx g
    f (LocalActorRepo r)   = LocalActorRepo $ encodeKeyHashidPure ctx r
    f (LocalActorDeck d)   = LocalActorDeck $ encodeKeyHashidPure ctx d
    f (LocalActorLoom l)   = LocalActorLoom $ encodeKeyHashidPure ctx l

getHashLocalActor
    :: (MonadActor m, StageHashids (ActorEnv m))
    => m (LocalActorBy Key -> LocalActorBy KeyHashid)
getHashLocalActor = do
    ctx <- asksEnv stageHashidsContext
    return $ hashLocalActorPure ctx

hashLocalActor
    :: (MonadActor m, StageHashids (ActorEnv m))
    => LocalActorBy Key -> m (LocalActorBy KeyHashid)
hashLocalActor actor = do
    hash <- getHashLocalActor
    return $ hash actor

unhashLocalActorPure
    :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
unhashLocalActorPure ctx = f
    where
    f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
    f (LocalActorGroup g)  = LocalActorGroup <$> decodeKeyHashidPure ctx g
    f (LocalActorRepo r)   = LocalActorRepo <$> decodeKeyHashidPure ctx r
    f (LocalActorDeck d)   = LocalActorDeck <$> decodeKeyHashidPure ctx d
    f (LocalActorLoom l)   = LocalActorLoom <$> decodeKeyHashidPure ctx l

unhashLocalActor
    :: (MonadActor m, StageHashids (ActorEnv m))
    => LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
unhashLocalActor actor = do
    ctx <- asksEnv stageHashidsContext
    return $ unhashLocalActorPure ctx actor

unhashLocalActorF
    :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
    => LocalActorBy KeyHashid -> String -> m (LocalActorBy Key)
unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor

unhashLocalActorM
    :: (MonadActor m, StageHashids (ActorEnv m))
    => LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key)
unhashLocalActorM = MaybeT . unhashLocalActor

unhashLocalActorE
    :: (MonadActor m, StageHashids (ActorEnv m))
    => LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key)
unhashLocalActorE actor e =
    ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor

unhashLocalActor404
    :: ( MonadSite m
       , MonadHandler m
       , HandlerSite m ~ SiteEnv m
       , YesodHashids (HandlerSite m)
       )
    => LocalActorBy KeyHashid
    -> m (LocalActorBy Key)
unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor
    where
    unhashLocalActor byHash = do
        ctx <- asksSite siteHashidsContext
        return $ unhashLocalActorPure ctx byHash

data TicketRoutes = TicketRoutes
    { routeTicketFollowers :: Bool
    }
    deriving Eq

data ClothRoutes = ClothRoutes
    { routeClothFollowers :: Bool
    }
    deriving Eq

data PersonRoutes = PersonRoutes
    { routePerson          :: Bool
    , routePersonFollowers :: Bool
    }
    deriving Eq

data GroupRoutes = GroupRoutes
    { routeGroup          :: Bool
    , routeGroupFollowers :: Bool
    }
    deriving Eq

data RepoRoutes = RepoRoutes
    { routeRepo          :: Bool
    , routeRepoFollowers :: Bool
    }
    deriving Eq

data DeckRoutes = DeckRoutes
    { routeDeck          :: Bool
    , routeDeckFollowers :: Bool
    }
    deriving Eq

data LoomRoutes = LoomRoutes
    { routeLoom          :: Bool
    , routeLoomFollowers :: Bool
    }
    deriving Eq

data DeckFamilyRoutes = DeckFamilyRoutes
    { familyDeck    :: DeckRoutes
    , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
    }
    deriving Eq

data LoomFamilyRoutes = LoomFamilyRoutes
    { familyLoom   :: LoomRoutes
    , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)]
    }
    deriving Eq

data RecipientRoutes = RecipientRoutes
    { recipPeople :: [(KeyHashid Person, PersonRoutes)]
    , recipGroups :: [(KeyHashid Group , GroupRoutes)]
    , recipRepos  :: [(KeyHashid Repo  , RepoRoutes)]
    , recipDecks  :: [(KeyHashid Deck  , DeckFamilyRoutes)]
    , recipLooms  :: [(KeyHashid Loom  , LoomFamilyRoutes)]
    }
    deriving Eq

data RemoteAuthor = RemoteAuthor
    { remoteAuthorURI      :: FedURI
    , remoteAuthorInstance :: InstanceId
    , remoteAuthorId       :: RemoteActorId
    }

data ActivityBody = ActivityBody
    { actbBL         :: BL.ByteString
    , actbObject     :: A.Object
    , actbActivity   :: AP.Activity URIMode
    }

data VerseRemote = VerseRemote
    { verseAuthor   :: RemoteAuthor
    , verseBody     :: ActivityBody
    , verseForward  :: Maybe (RecipientRoutes, ByteString)
    , verseActivity :: LocalURI
    }

data Event
    = EventRemoteGrantLocalRecipFwdToFollower RemoteActivityId
    -- ^ A local actor has received a Grant (they're being granted some access)
    --   and forwarding it to me because I'm following this local actor
    | EventRemoteFwdLocalActivity (LocalActorBy Key) OutboxItemId
    -- EventLocalFwdRemoteActivity (LocalActorBy Key) RemoteActivityId
    -- ^ A local actor is forwarding me a remote activity to add to my inbox.
    --   The data is (1) who's forwarding to me (2) the remote activity
    | EventUnknown
    deriving Show

type Verse = Either Event VerseRemote

instance Message Verse where
    summarize (Left event) = T.pack $ show event
    summarize (Right (VerseRemote author body _fwd uri)) =
        let ObjURI h _ = remoteAuthorURI author
            typ = AP.activityType $ AP.activitySpecific $ actbActivity body
        in  T.concat [typ, " ", renderObjURI $ ObjURI h uri]
    refer (Left event) = T.pack $ show event
    refer (Right (VerseRemote author _body _fwd uri)) =
        let ObjURI h _ = remoteAuthorURI author
        in  renderObjURI $ ObjURI h uri

type YesodRender y = Route y -> [(Text, Text)] -> Text

-- | Data to which every actor has access. Since such data can be passed to the
-- behavior function when launching the actor, having a dedicated datatype is
-- just convenience. The main reason is to allow 'runDB' not to take a
-- connection pool parameter, instead grabbing it from the ReaderT. Another
-- reason is to avoid the clutter of passing the same arguments manually
-- everywhere.
--
-- The purpose of Env is to hold the system stuff: DB connection pool,
-- settings, HTTP manager, etc. etc. while the data stuff (actual info of the
-- actor) is meant to be passed as parameters of the behavior function.
--
-- Maybe in the future there won't be data shared by all actors, and then this
-- type can be removed.
data Env = forall y. (Typeable y, Yesod y) => Env
    { envSettings        :: AppSettings
    , envDbPool          :: ConnectionPool
    , envHashidsContext  :: HashidsContext
    , envActorKeys       :: Maybe (TVar (ActorKey, ActorKey, Bool))
    , envDeliveryTheater :: DeliveryTheater URIMode
    --, envYesodSite       :: y
    , envYesodRender     :: YesodRender y
    }
    deriving Typeable

instance Stage Env where
    type StageKey Env     = LocalActorBy Key
    type StageMessage Env = Verse
    type StageReturn Env  = Either Text Text

instance StageWeb Env where
    type StageURIMode Env = URIMode
    --type StageRoute Env = Route Site
    stageInstanceHost = appInstanceHost . envSettings
    stageDeliveryTheater = envDeliveryTheater

instance StageHashids Env where
    stageHashidsContext = envHashidsContext

type Act = ActFor Env

type ActE = ActForE Env

type ActDB = SqlPersistT Act

type ActDBE = ExceptT Text ActDB

type Theater = TheaterFor Env

-- | Run a database transaction. If an exception is thrown, the whole
-- transaction is aborted.
withDB :: ActDB a -> Act a
withDB action = do
    env <- askEnv
    runPool (appDatabaseConf $ envSettings env) action (envDbPool env)

newtype FedError = FedError Text deriving Show

instance Exception FedError

-- | Like 'withDB', but supports errors via 'ExceptT. If an exception is
-- thrown, either via the 'ExceptT' or via regular throwing, the whole
-- transaction is aborted.
withDBExcept :: ExceptT Text (SqlPersistT Act) a -> ExceptT Text Act a
withDBExcept action = do
    result <- lift $ try $ withDB $ either abort return =<< runExceptT action
    case result of
        Left (FedError t) -> throwE t
        Right r -> return r
    where
    abort = throwIO . FedError

behave
    :: (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next))
    -> (Key a -> Verse -> Act (Either Text Text, Act (), Next))
behave handler key msg = do
    now <- liftIO getCurrentTime
    result <- runExceptT $ handler now key msg
    case result of
        Left e -> done $ Left e
        Right (t, after, next) -> return (Right t, after, next)

data RemoteRecipient = RemoteRecipient
    { remoteRecipientActor      :: RemoteActorId
    , remoteRecipientId         :: LocalURI
    , remoteRecipientInbox      :: LocalURI
    , remoteRecipientErrorSince :: Maybe UTCTime
    }

-- Given a list of local recipients, which may include actors and collections,
--
-- * Insert activity to message queues of live actors
-- * If collections are listed, insert activity to message queues of local
--   members and return the remote members
--
-- This function reads the follower sets and remote recipient data from the
-- PostgreSQL database. Don't use it inside a database transaction.
sendToLocalActors
    :: Event
    -- ^ Event to send to local live actors
    -> Bool
    -- ^ Whether to deliver to collection only if owner actor is addressed
    -> Maybe (LocalActorBy Key)
    -- ^ An actor whose collections are excluded from requiring an owner, i.e.
    --   even if owner is required, this actor's collections will be delivered
    --   to, even if this actor isn't addressed. This is meant to be the
    --   activity's author.
    -> Maybe (LocalActorBy Key)
    -- ^ An actor whose inbox to exclude from delivery, even if this actor is
    --   listed in the recipient set. This is meant to be the activity's
    --   author.
    -> RecipientRoutes
    -> Act [((InstanceId, Host), NonEmpty RemoteRecipient)]
sendToLocalActors event requireOwner mauthor maidAuthor recips = do

    -- Unhash actor and work item hashids
    people <- unhashKeys $ recipPeople recips
    groups <- unhashKeys $ recipGroups recips
    repos <- unhashKeys $ recipRepos recips
    decksAndTickets <- do
        decks <- unhashKeys $ recipDecks recips
        for decks $ \ (deckID, (DeckFamilyRoutes deck tickets)) ->
            (deckID,) . (deck,) <$> unhashKeys tickets
    loomsAndCloths <- do
        looms <- unhashKeys $ recipLooms recips
        for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
            (loomID,) . (loom,) <$> unhashKeys cloths

    -- Grab local actor sets whose stages are allowed for delivery
    let allowStages'
            :: (famili -> routes)
            -> (routes -> Bool)
            -> (Key record -> LocalActorBy Key)
            -> (Key record, famili)
            -> Bool
        allowStages' = allowStages isAuthor

        peopleForStages =
            filter (allowStages' id routePerson LocalActorPerson) people
        groupsForStages =
            filter (allowStages' id routeGroup LocalActorGroup) groups
        reposForStages =
            filter (allowStages' id routeRepo LocalActorRepo) repos
        decksAndTicketsForStages =
            filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
        loomsAndClothsForStages =
            filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths

    -- Grab local actors being addressed
    let localActorsForSelf = concat
            [ [ LocalActorPerson key | (key, routes) <- people, routePerson routes ]
            , [ LocalActorGroup key | (key, routes) <- groups, routeGroup routes ]
            , [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ]
            , [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
            , [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
            ]

    -- Grab local actors whose followers are going to be delivered to
    let personIDsForFollowers =
            [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ]
        groupIDsForFollowers =
            [ key | (key, routes) <- groupsForStages, routeGroupFollowers routes ]
        repoIDsForFollowers =
            [ key | (key, routes) <- reposForStages, routeRepoFollowers routes ]
        deckIDsForFollowers =
            [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
        loomIDsForFollowers =
            [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]

    -- Grab tickets and cloths whose followers are going to be delivered to
    let ticketSetsForFollowers =
            mapMaybe
                (\ (deckID, (_, tickets)) -> (deckID,) <$>
                        NE.nonEmpty
                        [ ticketDeckID | (ticketDeckID, routes) <- tickets
                                       , routeTicketFollowers routes
                        ]
                )
                decksAndTicketsForStages
        clothSetsForFollowers =
            mapMaybe
                (\ (loomID, (_, cloths)) -> (loomID,) <$>
                        NE.nonEmpty
                        [ ticketLoomID | (ticketLoomID, routes) <- cloths
                                       , routeClothFollowers routes
                        ]
                )
                loomsAndClothsForStages

    (localFollowers, remoteFollowers) <- withDB $ do
        -- Get actor and work item FollowerSet IDs from DB
        followerSetIDs <- do
            actorIDs <- concat <$> sequenceA
                [ selectActorIDs personActor personIDsForFollowers
                , selectActorIDs groupActor groupIDsForFollowers
                , selectActorIDs repoActor repoIDsForFollowers
                , selectActorIDs deckActor deckIDsForFollowers
                , selectActorIDs loomActor loomIDsForFollowers
                ]
            ticketIDs <-
                concat <$>
                    ((++)
                        <$> traverse
                                (selectTicketIDs ticketDeckTicket TicketDeckDeck)
                                ticketSetsForFollowers
                        <*> traverse
                                (selectTicketIDs ticketLoomTicket TicketLoomLoom)
                                clothSetsForFollowers
                    )
            (++)
                <$> (map (actorFollowers . entityVal) <$>
                        selectList [ActorId <-. actorIDs] []
                    )
                <*> (map (ticketFollowers . entityVal) <$>
                        selectList [TicketId <-. ticketIDs] []
                    )

        -- Get the local and remote followers of the follower sets from DB
        locals <- concat <$> sequenceA
                [ selectFollowers LocalActorPerson PersonActor followerSetIDs
                , selectFollowers LocalActorGroup  GroupActor  followerSetIDs
                , selectFollowers LocalActorRepo   RepoActor   followerSetIDs
                , selectFollowers LocalActorDeck   DeckActor   followerSetIDs
                , selectFollowers LocalActorLoom   LoomActor   followerSetIDs
                ]
        remotes <- getRemoteFollowers followerSetIDs
        return (locals, remotes)

    -- Insert activity to message queues of all local live actors who are
    -- recipients, i.e. either directly addressed or listed in a local stage
    -- addressed
    let liveRecips =
            let s = HS.fromList $ localFollowers ++ localActorsForSelf
            in  case maidAuthor of
                    Nothing -> s
                    Just a -> HS.delete a s
    sendMany liveRecips $ Left event

    -- Return remote followers, to whom we need to deliver via HTTP
    return remoteFollowers
    where
    orderedUnion = foldl' LO.union []

    unhashKeys
        :: ToBackendKey SqlBackend record
        => [(KeyHashid record, routes)]
        -> Act [(Key record, routes)]
    unhashKeys actorSets = do
        unhash <- decodeKeyHashidPure <$> asksEnv stageHashidsContext
        return $ mapMaybe (unhashKey unhash) actorSets
        where
        unhashKey unhash (hash, famili) = (,famili) <$> unhash hash

    isAuthor =
        case mauthor of
            Nothing -> const False
            Just author -> (== author)

    allowStages
        :: (LocalActorBy Key -> Bool)
        -> (famili -> routes)
        -> (routes -> Bool)
        -> (Key record -> LocalActorBy Key)
        -> (Key record, famili)
        -> Bool
    allowStages isAuthor familyActor routeActor makeActor (actorID, famili)
        =  routeActor (familyActor famili)
        || not requireOwner
        || isAuthor (makeActor actorID)

    selectActorIDs
        :: (MonadIO m, PersistRecordBackend record SqlBackend)
        => (record -> ActorId)
        -> [Key record]
        -> ReaderT SqlBackend m [ActorId]
    selectActorIDs grabActor ids =
        map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] []

    selectTicketIDs
        :: ( MonadIO m
           , PersistRecordBackend tracker SqlBackend
           , PersistRecordBackend item SqlBackend
           )
        => (item -> TicketId)
        -> EntityField item (Key tracker)
        -> (Key tracker, NonEmpty (Key item))
        -> ReaderT SqlBackend m [TicketId]
    selectTicketIDs grabTicket trackerField (trackerID, workItemIDs) = do
        maybeTracker <- get trackerID
        case maybeTracker of
            Nothing -> pure []
            Just _ ->
                map (grabTicket . entityVal) <$>
                    selectList [persistIdField <-. NE.toList workItemIDs, trackerField ==. trackerID] []

    getRemoteFollowers
        :: MonadIO m
        => [FollowerSetId]
        -> ReaderT SqlBackend m
            [((InstanceId, Host), NonEmpty RemoteRecipient)]
    getRemoteFollowers fsids =
        fmap groupRemotes $
            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.in_` E.valList fsids
                E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
                return
                    ( i E.^. InstanceId
                    , i E.^. InstanceHost
                    , ra E.^. RemoteActorId
                    , ro E.^. RemoteObjectIdent
                    , ra E.^. RemoteActorInbox
                    , ra E.^. RemoteActorErrorSince
                    )
        where
        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
            where
            toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)

    selectFollowers makeLocalActor actorField followerSetIDs =
        fmap (map (makeLocalActor . E.unValue)) $
        E.select $ E.from $ \ (f `E.InnerJoin` p) -> do
            E.on $ f E.^. FollowActor E.==. p E.^. actorField
            E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
            return $ p E.^. persistIdField