{- This file is part of Vervis.
 -
 - Written in 2023, 2024 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 DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}

-- | Should eventually turn into an internal module for use only by
-- 'Web.Actor'.
--
-- System of local utility-actors that do the actual HTTP POSTing of
-- activities to remote actors.
module Web.Actor.Deliver
    ( Method (..)
    , DeliveryTheater ()
    , startDeliveryTheater
    , sendHttp
    )
where

import Control.Exception.Base
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.Retry
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Hashable
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Time.Clock
import Data.Time.Interval
import Data.Traversable
import Database.Persist.Sql
import Network.HTTP.Client (Manager, HttpException (..), HttpExceptionContent (..), responseStatus)
import Network.HTTP.Types.Header (HeaderName)
import Network.HTTP.Types.URI (urlEncode, urlDecode)
import Network.HTTP.Types.Status
import System.FilePath ((</>))
import System.Directory
import Web.Hashids

import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashSet as HS
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

import Control.Concurrent.Actor
import Database.Persist.Box
import Network.FedURI

import qualified Web.ActivityPub as AP

import Vervis.Settings

data Method u
    = MethodDeliverLocal (AP.Envelope u) Bool
    | MethodForwardRemote (AP.Errand u)

instance Message (Method u) where
    summarize _ = "Method"
    refer _     = "Method"

data RemoteActor = RemoteActor
    { raInbox      :: Maybe LocalURI
    , _raErrorSince :: Maybe UTCTime
    }
    deriving (Show, Read)

instance BoxableVia RemoteActor where
    type BV RemoteActor = BoxableShow

{-
migrations :: [Migration SqlBackend IO]
migrations =
    [ -- 1
      addEntities [entities|
        RemoteActor
            inbox      LocalURI Maybe
            errorSince UTCTime  Maybe
        |]
    ]
-}

data Env u = Env
    { envBox :: Box RemoteActor
    }

instance MonadBox (ActFor (Env u)) where
    type BoxType (ActFor (Env u)) = RemoteActor
    askBox = asksEnv envBox

instance Stage (Env u) where
    type StageKey (Env u)     = ObjURI u
    type StageMessage (Env u) = Method u
    type StageReturn (Env u)  = ()

data DeliveryTheater u = DeliveryTheater
    { _dtManager :: Manager
    , _dtHeaders :: NonEmpty HeaderName
    , _dtDelay   :: Int
    , _dtLog     :: LogFunc
    , _dtDir     :: OsPath
    , _dtTheater :: TheaterFor (Env u)
    }

data IdMismatch = IdMismatch deriving Show

instance Exception IdMismatch

behavior
    :: UriMode u
    => Manager
    -> NonEmpty HeaderName
    -> Int
    -> ObjURI u
    -> Method u
    -> ActFor (Env u) ((), ActFor (Env u) (), Next)
behavior manager postSignedHeaders micros (ObjURI h lu) = \case
    MethodDeliverLocal envelope fwd -> do
        ra@(RemoteActor mluInbox _mError) <- runBox obtain
        uInbox <- getInbox
        let mluFwd = if fwd then Just lu else Nothing
        _resp <-
            liftIO $ retry shouldRetry toException $
                AP.deliver manager postSignedHeaders envelope mluFwd uInbox
        done ()
    MethodForwardRemote errand -> do
        uInbox <- getInbox
        _resp <-
            liftIO $ retry shouldRetry toException $
                AP.forward manager postSignedHeaders errand uInbox
        done ()
    where
    shouldRetry = \case
        AP.APPostErrorHTTP (HttpExceptionRequest _ (StatusCodeException resp _))
            | noRetry (responseStatus resp) -> False
        _ -> True
        where
        noRetry s =
            status200 <= s && s < status300 ||
            status400 <= s && s < status500
    retry :: (e -> Bool) -> (e -> SomeException) -> IO (Either e a) -> IO a
    retry shouldRetry' toE action = do
        errorOrResult <-
            runExceptT $
                retryOnError
                    (exponentialBackoff micros)
                    (\ _ e -> pure $ shouldRetry' e)
                    (const $ ExceptT action)
        case errorOrResult of
            Left e -> throwIO $ toE e
            Right r -> return r
    getInbox = do
        ra@(RemoteActor mluInbox _mError) <- runBox obtain
        luInbox <-
            case mluInbox of
                Just luInb -> return luInb
                Nothing -> do
                    AP.Actor local _detail <-
                        liftIO $
                            retry
                                (const True)
                                (maybe (toException IdMismatch) toException)
                                (AP.fetchAPID' manager (AP.actorId . AP.actorLocal) h lu)
                    let luInb = AP.actorInbox local
                    runBox $ bestow $ ra { raInbox = Just luInb }
                    return luInb
        return $ ObjURI h luInbox

mkEnv :: LogFunc -> OsPath -> IO (Env u)
mkEnv logFunc path = flip runLoggingT logFunc $ do
    box <- loadBox {-migrations-} path (RemoteActor Nothing Nothing)
    return $ Env box

type OsPath = FilePath
encodeUtf = pure
decodeUtf = pure

startDeliveryTheater
    :: UriMode u
    => NonEmpty HeaderName
    -> Int
    -> Manager
    -> LogFunc
    -> OsPath
    -> IO (DeliveryTheater u)
startDeliveryTheater headers micros manager logFunc dbRootDir = do
    entries <- listDirectory dbRootDir
    actors <- for entries $ \ path -> do
        path' <- T.pack <$> decodeUtf path
        path'' <- either throwIO pure $ TE.decodeUtf8' $ urlDecode False $ TE.encodeUtf8 path'
        u <-
            case parseObjURI path'' of
                Left e ->
                    error $
                        "Failed to parse URI-named SQLite db filename: " ++ e
                Right uri -> return uri
        env <- mkEnv logFunc $ dbRootDir </> path
        return (u, env, behavior manager headers micros u)
    DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc actors

sendHttp :: UriMode u => DeliveryTheater u -> Method u -> [ObjURI u] -> IO ()
sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = do
    for_ recips $ \ u ->
        let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv logFunc
            behave = behavior manager headers micros u
        in  void $ spawnIO theater u makeEnv behave
    sendManyIO theater (HS.fromList recips) method