{- This file is part of Vervis.
 -
 - Written in 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.Data.Ticket
    ( Tip (..)
    , Material (..)
    , Merge (..)
    , TrackerAndMerge (..)
    , WorkItemOffer (..)
    , checkOfferTicket
    , checkApplyLocalLoom

    , parseBundleRoute

    , WorkItemBy (..)

    , hashWorkItemPure
    , getHashWorkItem
    , hashWorkItem

    , unhashWorkItemPure
    , unhashWorkItem
    , unhashWorkItemF
    , unhashWorkItemM
    , unhashWorkItemE
    , unhashWorkItem404

    , workItemResource
    , workItemActor
    , workItemFollowers
    , workItemRoute
    , parseWorkItem

    -- These are exported only for Vervis.Client
    , Tracker (..)
    , checkTracker
    )
where

import Control.Monad
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Bifunctor
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import Data.Traversable
import Web.Hashids
import Yesod.Core

import qualified Control.Monad.Fail as F

import Development.PatchMediaType
import Network.FedURI
import Web.Text
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local

import Vervis.Access
import Vervis.Foundation
import Vervis.FedURI
import Vervis.Model
import Vervis.Recipient

data Tip
    = TipLocalRepo RepoId
    | TipLocalBranch RepoId Text
    | TipRemote FedURI
    | TipRemoteBranch FedURI Text

data Material = Material
    { materialType    :: PatchMediaType
    , materialPatches :: NonEmpty Text
    }

data Merge = Merge
    { mergeOrigin   :: Maybe Tip
    , mergeMaterial :: Maybe Material
    , mergeTarget   :: Tip
    }

data Tracker = TrackerDeck DeckId | TrackerLoom LoomId | TrackerRemote FedURI
    deriving Eq

data TrackerAndMerge =
    TAM_Task DeckId | TAM_Merge LoomId Merge | TAM_Remote FedURI (Maybe Merge)

data WorkItemOffer = WorkItemOffer
    { wioAuthor :: Either PersonId FedURI
    , wioTitle  :: Text
    , wioDesc   :: HTML
    , wioSource :: PandocMarkdown
    , wioRest   :: TrackerAndMerge
    }

checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI)
checkAuthor u@(ObjURI h lu) = do
    hl <- hostIsLocalOld h
    if hl
        then do
            route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route"
            case route of
                PersonR personHash -> Left <$> decodeKeyHashidE personHash "Local author invalid person hash"
                _ -> throwE "Local author not a person route"
        else pure $ Right u

checkPatch :: Host -> AP.Patch URIMode -> ExceptT Text Handler (Either PersonId FedURI, PatchMediaType, Text)
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
    verifyNothingE mlocal "Patch has 'id'"
    author <- checkAuthor $ ObjURI h attrib
    verifyNothingE mpub "Patch has 'published'"
    return (author, typ, content)

checkBundle :: Host -> AP.Bundle URIMode -> ExceptT Text Handler (Either PersonId FedURI, Material)
checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs"
checkBundle h (AP.BundleOffer mlocal patches) = do
    verifyNothingE mlocal "Bundle has 'id'"
    (author, typ, content) :| rest <- traverse (checkPatch h) patches
    let authors = map (\ (a, _, _) -> a) rest
        typs = map (\ (_, t, _) -> t) rest
        contents = map (\ (_, _, c) -> c) rest
    unless (all (== author) authors) $ throwE "Different patch authors"
    unless (all (== typ) typs) $ throwE "Different patch types"
    return (author, Material typ (content :| contents))

checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI)
checkTipURI u@(ObjURI h lu) = do
    hl <- hostIsLocalOld h
    if hl
        then Left <$> do
            route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route"
            case route of
                RepoR repoHash -> decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid"
                _ -> throwE "URI is local route but not a repo route"
        else pure $ Right u

checkBranch :: Host -> AP.Branch URIMode -> ExceptT Text Handler (Either RepoId FedURI, Text)
checkBranch h (AP.Branch name _ luRepo) =
    (,name) <$> nameExceptT "Branch repo" (checkTipURI $ ObjURI h luRepo)

checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ExceptT Text Handler Tip
checkTip (Left u) = either TipLocalRepo TipRemote <$> checkTipURI u
checkTip (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b

checkMR
    :: Host
    -> AP.MergeRequest URIMode
    -> ExceptT Text Handler
        (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
checkMR h (AP.MergeRequest muOrigin target mbundle) =
    (,,)
        <$> traverse checkTip muOrigin
        <*> (for mbundle $ \ bundle ->
                case bundle of
                    Left _ -> throwE "MR bundle specified as a URI"
                    Right (h, b) -> checkBundle h b
            )
        <*> checkTip (bimap (ObjURI h) (h,) target)

checkTracker :: FedURI -> ExceptT Text Handler Tracker
checkTracker u@(ObjURI h lu) = do
    hl <- hostIsLocalOld h
    if hl
        then do
            route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route"
            case route of
                DeckR deckHash -> TrackerDeck <$> decodeKeyHashidE deckHash "Local tracker invalid deck hash"
                LoomR loomHash -> TrackerLoom <$> decodeKeyHashidE loomHash "Local tracker invalid loom hash"
                _ -> throwE "Local tracker not a deck/loom route"
        else pure $ TrackerRemote u

checkTicket
    :: Host
    -> AP.Ticket URIMode
    -> ExceptT Text Handler
        ( Either PersonId FedURI
        , Text, HTML, PandocMarkdown
        , Maybe Tracker
        , Maybe Merge
        )
checkTicket h (AP.Ticket mlocal attrib mpublished mupdated muContext summary content source muAssigned mresolved mmr) = do
    verifyNothingE mlocal "Ticket with 'id'"
    author <- checkAuthor $ ObjURI h attrib
    verifyNothingE mpublished "Ticket with 'published'"
    verifyNothingE mupdated "Ticket with 'updated'"
    maybeTracker <- traverse checkTracker muContext
    verifyNothingE muAssigned "Ticket has 'assignedTo'"
    verifyNothingE mresolved "Ticket is resolved"
    maybeMerge <- for mmr $ \ (h, mr) -> do
        (maybeOriginTip, maybeAuthorAndBundle, targetTip) <- checkMR h mr
        maybeBundle <- for maybeAuthorAndBundle $ \ (author', bundle) -> do
            unless (author == author') $
                throwE "Ticket author and patch(es) author are different"
            return bundle
        return $ Merge maybeOriginTip maybeBundle targetTip
    return (author, decodeEntities summary, content, source, maybeTracker, maybeMerge)

checkTrackerAndMerge :: Tracker -> Maybe Merge -> ExceptT Text Handler TrackerAndMerge
checkTrackerAndMerge (TrackerDeck deckID) Nothing = pure $ TAM_Task deckID
checkTrackerAndMerge (TrackerDeck _) (Just _) = throwE "Deck & MR"
checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR"
checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge
checkTrackerAndMerge (TrackerRemote uTracker) maybeMerge = pure $ TAM_Remote uTracker maybeMerge

checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler WorkItemOffer
checkOfferTicket host ticket uTarget = do
    target <- checkTracker uTarget
    (author, title, desc, source, maybeTracker, maybeBundle) <- checkTicket host ticket
    for_ maybeTracker $ \ tracker ->
        unless (tracker == target) $ throwE "Offer target != ticket context"
    tam <- checkTrackerAndMerge target maybeBundle
    return $ WorkItemOffer author title desc source tam

parseBundleRoute name u@(ObjURI h lu) = do
    hl <- hostIsLocalOld h
    if hl
        then Left <$> do
            route <-
                fromMaybeE (decodeRouteLocal lu) $
                    name <> ": Not a valid route"
            case route of
                BundleR loom ticket bundle ->
                    (,,)
                        <$> decodeKeyHashidE loom   (name <> ": Invalid lkhid")
                        <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
                        <*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
                _ -> throwE $ name <> ": not a bundle route"
        else return $ Right u

checkApply
    :: AP.Apply URIMode
    -> ExceptT Text Handler
        (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
checkApply (AP.Apply uObject target) =
    (,) <$> parseBundleRoute "Apply object" uObject
        <*> nameExceptT "Apply target" (checkTip target)

checkApplyLocalLoom
    :: AP.Apply URIMode
    -> ExceptT Text Handler
        (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
checkApplyLocalLoom apply = do
    (bundle, targetTip) <- checkApply apply
    let maybeLocal =
            case targetTip of
                TipLocalRepo repoID -> Just (repoID, Nothing)
                TipLocalBranch repoID branch -> Just (repoID, Just branch)
                TipRemote _ -> Nothing
                TipRemoteBranch _ _ -> Nothing
    for maybeLocal $ \ (repoID, maybeBranch) -> do
        (loomID, clothID, bundleID) <-
            case bundle of
                Left b -> pure b
                Right _ -> throwE "Applying a remote bundle on local loom"
        return (repoID, maybeBranch, loomID, clothID, bundleID)

data WorkItemBy f
    = WorkItemTicket (f Deck) (f TicketDeck)
    | WorkItemCloth (f Loom) (f TicketLoom)

hashWorkItemPure :: HashidsContext -> WorkItemBy Key -> WorkItemBy KeyHashid
hashWorkItemPure ctx = f
    where
    f (WorkItemTicket d t) =
        WorkItemTicket (encodeKeyHashidPure ctx d) (encodeKeyHashidPure ctx t)
    f (WorkItemCloth l c) =
        WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c)

getHashWorkItem
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => m (WorkItemBy Key -> WorkItemBy KeyHashid)
getHashWorkItem = do
    ctx <- asksSite siteHashidsContext
    return $ hashWorkItemPure ctx

hashWorkItem
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => WorkItemBy Key -> m (WorkItemBy KeyHashid)
hashWorkItem actor = do
    hash <- getHashWorkItem
    return $ hash actor

unhashWorkItemPure
    :: HashidsContext -> WorkItemBy KeyHashid -> Maybe (WorkItemBy Key)
unhashWorkItemPure ctx = f
    where
    f (WorkItemTicket d t) =
        WorkItemTicket
            <$> decodeKeyHashidPure ctx d
            <*> decodeKeyHashidPure ctx t
    f (WorkItemCloth l c) =
        WorkItemCloth
            <$> decodeKeyHashidPure ctx l
            <*> decodeKeyHashidPure ctx c

unhashWorkItem
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key))
unhashWorkItem actor = do
    ctx <- asksSite siteHashidsContext
    return $ unhashWorkItemPure ctx actor

unhashWorkItemF
    :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
    => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key)
unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor

unhashWorkItemM
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key)
unhashWorkItemM = MaybeT . unhashWorkItem

unhashWorkItemE
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key)
unhashWorkItemE actor e =
    ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor

unhashWorkItem404
    :: ( MonadSite m
       , MonadHandler m
       , HandlerSite m ~ SiteEnv m
       , YesodHashids (HandlerSite m)
       )
    => WorkItemBy KeyHashid
    -> m (WorkItemBy Key)
unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor

workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom

workItemActor (WorkItemTicket deck _) = LocalActorDeck deck
workItemActor (WorkItemCloth loom _) = LocalActorLoom loom

workItemFollowers (WorkItemTicket d t) = LocalStageTicketFollowers d t
workItemFollowers (WorkItemCloth l c) = LocalStageClothFollowers l c

workItemRoute (WorkItemTicket d t) = TicketR d t
workItemRoute (WorkItemCloth l c) = ClothR l c

parseWorkItem (TicketR deck task) = Just $ WorkItemTicket deck task
parseWorkItem (ClothR loom cloth) = Just $ WorkItemCloth loom cloth
parseWorkItem _ = Nothing