{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2021, 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.Web.Repo
    ( serveCommit
    , generatePatches
    , canApplyPatches
    , applyPatches
    )
where

import Control.Monad
import Control.Monad.Trans.Except
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import System.Directory
import System.IO.Temp
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core

import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T

import Development.PatchMediaType
import Network.FedURI
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Data.Patch.Local hiding (Patch)

import qualified Data.Patch.Local as P

import Vervis.Darcs
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Git
import Vervis.Model
import Vervis.Path
import Vervis.Settings
import Vervis.Time
import Vervis.Widget.Person
import Vervis.Widget.Repo

serveCommit
    :: KeyHashid Repo
    -> Text
    -> P.Patch
    -> [Text]
    -> Handler TypedContent
serveCommit repoHash ref patch parents = do
    (mpersonWritten, mpersonCommitted) <- runDB $ (,)
        <$> getPerson (patchWritten patch)
        <*> maybe (pure Nothing) getPerson (patchCommitted patch)
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    hashPerson <- getEncodeKeyHashid
    let (author, written) = patchWritten patch
        mcommitter = patchCommitted patch
        makeAuthor' = makeAuthor hashPerson encodeRouteHome
        patchAP = AP.Commit
            { AP.commitId          = encodeRouteLocal $ RepoCommitR repoHash ref
            , AP.commitRepository  = encodeRouteLocal $ RepoR repoHash
            , AP.commitAuthor      = makeAuthor' mpersonWritten author
            , AP.commitCommitter   =
                makeAuthor' mpersonCommitted . fst <$> mcommitter
            , AP.commitTitle       = patchTitle patch
            , AP.commitHash        = AP.Hash $ encodeUtf8 ref
            , AP.commitDescription =
                let desc = patchDescription patch
                in  if T.null desc
                        then Nothing
                        else Just desc
            , AP.commitWritten     = written
            , AP.commitCommitted   = snd <$> patchCommitted patch
            }
    provideHtmlAndAP patchAP $
        let number = zip ([1..] :: [Int])
        in  $(widgetFile "repo/patch")
    where
    getPerson (author, _time) = do
        mp <- getBy $ UniquePersonEmail $ authorEmail author
        for mp $ \ ep@(Entity _ person) ->
            (ep,) <$> getJust (personActor person)

    makeAuthor _ _ Nothing author = Left AP.Author
        { AP.authorName  = authorName author
        , AP.authorEmail = authorEmail author
        }
    makeAuthor hashPerson encodeRouteHome (Just (Entity personID _, _)) _ =
        Right $ encodeRouteHome $ PersonR $ hashPerson personID

generatePatches
    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
    => ( TicketLoomId
       , RepoId
       , Bool
       , Either
            (Text, (Either RepoId FedURI, Text))
            (Either RepoId FedURI)
       )
    -> ExceptT Text m ()
generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do
    patches <-
        case tipInfo of
            Right _ -> error "Auto-pulling from Darcs remote origin not supported yet"
            Left (targetBranch, (originRepo, originBranch)) -> do
                targetPath <- do
                    repoHash <- encodeKeyHashid targetRepoID
                    repoDir <- askRepoDir repoHash
                    liftIO $ makeAbsolute repoDir
                originURI <-
                    case originRepo of
                        Left repoID -> do
                            repoHash <- encodeKeyHashid repoID
                            repoDir <- askRepoDir repoHash
                            liftIO $ makeAbsolute repoDir
                        Right uClone -> pure $ T.unpack $ renderObjURI uClone
                ExceptT $ liftIO $ runExceptT $
                    withSystemTempDirectory "vervis-generatePatches" $
                        generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch)
    now <- liftIO getCurrentTime
    lift $ runSiteDB $ do
        bundleID <- insert $ Bundle clothID True
        insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches

canApplyPatches
    :: (MonadSite m, SiteEnv m ~ App)
    => RepoId -> Maybe Text -> NonEmpty Text -> ExceptT Text m Bool
canApplyPatches repoID maybeBranch diffs = do
    repoPath <- do
        repoHash <- encodeKeyHashid repoID
        repoDir <- askRepoDir repoHash
        liftIO $ makeAbsolute repoDir
    case maybeBranch of
        Just branch -> do
            ExceptT $ liftIO $ runExceptT $
                withSystemTempDirectory "vervis-canApplyPatches" $
                    canApplyGitPatches repoPath (T.unpack branch) diffs
        Nothing -> do
            patch <-
                case diffs of
                    t :| [] -> return t
                    _ :| (_ : _) ->
                        throwE "Darcs repo given multiple patch bundles"
            canApplyDarcsPatch repoPath patch

applyPatches
    :: (MonadSite m, SiteEnv m ~ App)
    => RepoId -> Maybe Text -> NonEmpty Text -> ExceptT Text m ()
applyPatches repoID maybeBranch diffs = do
    repoPath <- do
        repoHash <- encodeKeyHashid repoID
        repoDir <- askRepoDir repoHash
        liftIO $ makeAbsolute repoDir
    case maybeBranch of
        Just branch -> do
            ExceptT $ liftIO $ runExceptT $
                withSystemTempDirectory "vervis-applyPatches" $
                    applyGitPatches repoPath (T.unpack branch) diffs
        Nothing -> do
            patch <-
                case diffs of
                    t :| [] -> return t
                    _ :| (_ : _) ->
                        throwE "Darcs repo given multiple patch bundles"
            applyDarcsPatch repoPath patch