{- This file is part of Vervis.
 -
 - Written in 2022 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.Persist.Actor
    ( getLocalActor
    , getLocalActorEnt
    , getLocalActorEntity
    , verifyLocalActivityExistsInDB
    , getRemoteActorURI
    , insertActor
    , updateOutboxItem
    , fillPerActorKeys
    , getPersonWidgetInfo
    )
where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bitraversable
import Data.Text (Text)
import Data.Traversable
import Database.Persist
import Database.Persist.Sql

import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Crypto.ActorKey
import Database.Persist.JSON
import Network.FedURI
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Database.Persist.Local

import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient
import Vervis.Settings

getLocalActor
    :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key)
getLocalActor = fmap (bmap entityKey) . getLocalActorEnt

getLocalActorEnt
    :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Entity)
getLocalActorEnt actorID = do
    mp <- getBy $ UniquePersonActor actorID
    mg <- getBy $ UniqueGroupActor actorID
    mr <- getBy $ UniqueRepoActor actorID
    md <- getBy $ UniqueDeckActor actorID
    ml <- getBy $ UniqueLoomActor actorID
    return $
        case (mp, mg, mr, md, ml) of
            (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
            (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
            (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g
            (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r
            (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d
            (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
            _ -> error "Multi-usage of an ActorId"

getLocalActorEntity
    :: MonadIO m
    => LocalActorBy Key
    -> ReaderT SqlBackend m (Maybe (LocalActorBy Entity))
getLocalActorEntity (LocalActorPerson p) =
    fmap (LocalActorPerson . Entity p) <$> get p
getLocalActorEntity (LocalActorGroup g) =
    fmap (LocalActorGroup . Entity g) <$> get g
getLocalActorEntity (LocalActorRepo r) =
    fmap (LocalActorRepo . Entity r) <$> get r
getLocalActorEntity (LocalActorDeck d) =
    fmap (LocalActorDeck . Entity d) <$> get d
getLocalActorEntity (LocalActorLoom l) =
    fmap (LocalActorLoom . Entity l) <$> get l

verifyLocalActivityExistsInDB
    :: MonadIO m
    => LocalActorBy Key
    -> OutboxItemId
    -> ExceptT Text (ReaderT SqlBackend m) ()
verifyLocalActivityExistsInDB actorByKey outboxItemID = do
    outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB"
    itemActorID <- do
        maybeActorID <-
            lift $ getKeyBy $ UniqueActorOutbox outboxID
        fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor"
    itemActorByKey <- lift $ getLocalActor itemActorID
    unless (itemActorByKey == actorByKey) $
        throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"

getRemoteActorURI actor = do
    object <- getJust $ remoteActorIdent actor
    inztance <- getJust $ remoteObjectInstance object
    return $
        ObjURI
            (instanceHost inztance)
            (remoteObjectIdent object)

insertActor now name desc = do
    ibid <- insert Inbox
    obid <- insert Outbox
    fsid <- insert FollowerSet
    let actor = Actor
            { actorName      = name
            , actorDesc      = desc
            , actorCreatedAt = now
            , actorInbox     = ibid
            , actorOutbox    = obid
            , actorFollowers = fsid
            }
    actorID <- insert actor
    return $ Entity actorID actor

updateOutboxItem
    :: (MonadSite m, SiteEnv m ~ App)
    => LocalActorBy Key
    -> OutboxItemId
    -> AP.Action URIMode
    -> ReaderT SqlBackend m LocalURI
updateOutboxItem actorByKey itemID action = do
    encodeRouteLocal <- getEncodeRouteLocal
    hLocal <- asksSite siteInstanceHost
    actorByHash <- hashLocalActor actorByKey
    itemHash <- encodeKeyHashid itemID
    let luId = encodeRouteLocal $ activityRoute actorByHash itemHash
        luActor = encodeRouteLocal $ renderLocalActor actorByHash
        doc = AP.Doc hLocal $ AP.makeActivity luId luActor action
    update itemID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
    return luId

fillPerActorKeys :: Worker ()
fillPerActorKeys = do
    perActor <- asksSite $ appPerActorKeys . appSettings
    when perActor $ do
        actorIDs <- runSiteDB $ E.select $ E.from $ \ (actor `E.LeftOuterJoin` sigkey) -> do
            E.on $ E.just (actor E.^. ActorId) E.==. sigkey E.?. SigKeyActor
            E.where_ $ E.isNothing $ sigkey E.?. SigKeyId
            return $ actor E.^. ActorId
        keys <- for actorIDs $ \ (E.Value actorID) -> do
            key <- liftIO generateActorKey
            return $ SigKey actorID key
        runSiteDB $ insertMany_ keys
        logInfo $
            T.concat ["Filled ", T.pack (show $ length keys), " actor keys"]

getPersonWidgetInfo
    :: MonadIO m
    => Either PersonId RemoteActorId
    -> ReaderT SqlBackend m
        (Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor))
getPersonWidgetInfo = bitraverse getLocal getRemote
    where
    getLocal personID = do
        person <- getJust personID
        actor <- getJust $ personActor person
        return (Entity personID person, actor)
    getRemote remoteActorID = do
        remoteActor <- getJust remoteActorID
        remoteObject <- getJust $ remoteActorIdent remoteActor
        inztance <- getJust $ remoteObjectInstance remoteObject
        return (inztance, remoteObject, remoteActor)