{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2022, 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/>.
 -}

module Development.Git
    ( GitT
    , withGitRepo
    , withGitRepoE
    , git
    , git_
    , gitE
    , gitE_

    , writeHookFile
    , createRepo
    , isGitRepo

    , TreeEntryType (..)
    , TreeEntry (..)
    , gitListDir
    , PathType (..)
    , gitGetPathType
    , gitGetFileContentByPath
    , gitGetFileContentByHash

    , gitListBranches
    , gitListBranches'
    , gitListTags
    , gitListTags'
    , gitGetObjectHash
    , gitResolveHead
    , gitGetObjectHashes
    , RevType (..)
    , gitGetRevType
    , gitGetCommitInfos
    , gitGetCommitInfo
    , gitDiff
    , gitGetCommitParents
    , gitPeelTag
    , gitFetch
    )
where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Either
import Data.Maybe
import Data.Map (Map)
import Data.Set (Set)
import Data.Text (Text)
import Data.Time.Format
import Data.Traversable
import System.Directory.Tree
import System.FilePath
import System.Posix.Files
import System.Process.Typed
--import Text.Diff.Parse
--import Text.Diff.Parse.Types
import Text.Email.Validate

import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO

import Data.ObjId

import qualified Data.VersionControl as VC

hookContent :: FilePath -> Text -> Text -> Text
hookContent hook authority repo =
    T.concat
        [ "#!/bin/sh\nexec ", T.pack hook
        , " ", authority, " ", repo
        ]

writeHookFile :: FilePath -> FilePath -> Text -> Text -> IO ()
writeHookFile path cmd authority repo = do
    let file = path </> "hooks" </> "post-receive"
    TIO.writeFile file $ hookContent cmd authority repo
    setFileMode file ownerModes

initialRepoTree :: FilePath -> Text -> Text -> DirTree Text
initialRepoTree hook authority repo =
    Dir (T.unpack repo)
        [ Dir "branches" []
        , File "config"
            "[core]\n\
            \    repositoryformatversion = 0\n\
            \    filemode = true\n\
            \    bare = true"
        , File "description"
            "Unnamed repository; edit this file to name the repository."
        , File "HEAD" "ref: refs/heads/main"
        , Dir "hooks"
            [ File "post-receive" $ hookContent hook authority repo
            ]
        , Dir "info"
            [ File "exclude" ""
            ]
        , Dir "objects"
            [ Dir "info" []
            , Dir "pack" []
            ]
        , Dir "refs"
            [ Dir "heads" []
            , Dir "tags" []
            ]
        ]

-- | initialize a new bare repository at a specific location.
--
-- Currently in the @hit@ package, i.e. version 0.6.3, the initRepo function
-- creates a directory which the git executable doesn't recognize as a git
-- repository. The version here creates a properly initialized repo.
createRepo
    :: FilePath
    -- ^ Parent directory which already exists
    -> Text
    -- ^ Repo hashid, i.e. new directory to create under the parent
    -> FilePath
    -- ^ Path of Vervis hook program
    -> Text
    -- ^ Instance HTTP authority
    -> IO ()
createRepo path repo cmd authority = do
    let tree = path :/ initialRepoTree cmd authority repo
    result <- writeDirectoryWith TIO.writeFile tree
    let errs = failures $ dirTree result
    when (not . null $ errs) $
        throwIO $ userError $ show errs
    setFileMode
        (path </> T.unpack repo </> "hooks" </> "post-receive")
        ownerModes

isGitRepo :: FilePath -> IO Bool
isGitRepo path = do
    r <- runExceptT $ withGitRepoE path $ gitE "rev-parse" ["--show-prefix"]
    return $
        case r of
            Left _ -> False
            Right t -> T.null $ T.strip t

type GitT m a = ReaderT FilePath m a

withGitRepo :: MonadIO m => FilePath -> GitT m a -> m a
withGitRepo path action = runReaderT action path

type GitE m a = ExceptT Text (ReaderT FilePath m) a

withGitRepoE :: MonadIO m => FilePath -> GitE m a -> ExceptT Text m a
withGitRepoE path action = ExceptT $ withGitRepo path $ runExceptT action

git :: MonadIO m => String -> [String] -> GitT m Text
git cmd args = do
    repo <- ask
    lb <- readProcessStdout_ $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
    liftIO $ either throwIO return $ TE.decodeUtf8' $ BL.toStrict lb

git_ :: MonadIO m => String -> [String] -> GitT m ()
git_ cmd args = do
    repo <- ask
    runProcess_ $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args

gitE :: MonadIO m => String -> [String] -> GitE m Text
gitE cmd args = do
    repo <- lift ask
    (code, lb) <- readProcessStdout $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
    case code of
        ExitSuccess -> pure ()
        ExitFailure c -> throwE $ "gitE " <> T.pack cmd <> " exited with code " <> T.pack (show c)
    either (throwE . T.pack . displayException) return $ TE.decodeUtf8' $ BL.toStrict lb

gitE_ :: MonadIO m => String -> [String] -> GitE m ()
gitE_ cmd args = do
    repo <- lift ask
    code <- runProcess $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
    case code of
        ExitSuccess -> pure ()
        ExitFailure c -> throwE $ "gitE_ " <> T.pack cmd <> " exited with code " <> T.pack (show c)

data TreeEntryType = TETFile Text | TETDir

data TreeEntry = TreeEntry
    { _teMode :: Text
    , _teType :: TreeEntryType
    , _teHash :: ObjId
    , _teName :: Text
    }

parseTree :: Text -> IO [TreeEntry]
parseTree = traverse (parseEntry . T.words) . T.lines
    where
    grabName = T.pack . takeFileName . T.unpack
    parseEntry [mode, "blob", hash, size, path] = do
        oid <- parseObjId hash
        pure $ TreeEntry mode (TETFile size) oid (grabName path)
    parseEntry [mode, "tree", hash, "-", path] = do
        oid <- parseObjId hash
        pure $ TreeEntry mode TETDir oid (grabName path)
    parseEntry _ = error "Unexpected tree entry line"

gitListDir :: MonadIO m => Text -> Maybe FilePath -> GitT m [TreeEntry]
gitListDir rev maybePath = do
    let path = fromMaybe "." maybePath
    t <- git "ls-tree" [T.unpack rev, "--long", addTrailingPathSeparator path]
    liftIO $ parseTree t

data PathType = PTBlob | PTTree deriving Show

parsePathType :: Text -> IO PathType
parsePathType t =
    case T.strip t of
        "blob" -> pure PTBlob
        "tree" -> pure PTTree
        _ -> error "Path type is neither blob nor tree"

gitGetPathType :: Text -> FilePath -> GitT IO PathType
gitGetPathType rev path = do
    t <- git "cat-file" ["-t", T.unpack rev ++ ":" ++ path]
    liftIO $ parsePathType t

parseBranches :: Text -> IO [Text]
parseBranches t = traverse grab $ map T.words $ T.lines t
    where
    grab [b]      = pure b
    grab ["*", b] = pure b
    grab _        = error "Unexpected branch line"

gitGetFileContentByPath :: Text -> FilePath -> GitT IO Text
gitGetFileContentByPath rev path =
    git "cat-file" ["blob", T.unpack rev ++ ":" ++ path]

gitGetFileContentByHash :: MonadIO m => ObjId -> GitT m Text
gitGetFileContentByHash oid =
    git "cat-file" ["blob", T.unpack $ renderObjId oid]

gitListBranches :: MonadIO m => GitT m (Set Text)
gitListBranches = do
    t <- git "branch" ["--list"]
    bs <- liftIO $ parseBranches t
    return $ S.fromList bs

gitListBranches' :: MonadIO m => GitT m (Map Text ObjId)
gitListBranches' = do
    t <- git "branch" ["--list"]
    bs <- liftIO $ parseBranches t
    hs <- gitGetObjectHashes $ map ("refs/heads/" <>) bs
    return $ M.fromList $ zip bs hs

parseTags :: Text -> IO [Text]
parseTags t = traverse grab $ map T.words $ T.lines t
    where
    grab [tag] = pure tag
    grab _     = error "Unexpected tag line"

gitListTags :: MonadIO m => GitT m (Set Text)
gitListTags = do
    t <- git "tag" ["--list"]
    ts <- liftIO $ parseTags t
    return $ S.fromList ts

gitListTags' :: MonadIO m => GitT m (Map Text ObjId)
gitListTags' = do
    t <- git "tag" ["--list"]
    ts <- liftIO $ parseTags t
    hs <- gitGetObjectHashes $ map ("refs/tags/" <>) ts
    return $ M.fromList $ zip ts hs

gitGetObjectHash :: MonadIO m => Text -> GitT m ObjId
gitGetObjectHash object = do
    hash <- T.strip <$> git "rev-parse" [T.unpack object]
    liftIO $ parseObjId hash

gitResolveHead :: MonadIO m => GitT m (Maybe ObjId)
gitResolveHead = do
    mh <-
        either (const Nothing) Just <$>
            runExceptT (T.strip <$> gitE "rev-parse" ["HEAD"])
    liftIO $ for mh parseObjId

gitGetObjectHashes :: MonadIO m => [Text] -> GitT m [ObjId]
gitGetObjectHashes []      = pure []
gitGetObjectHashes objects = do
    hashes <- T.lines <$> git "rev-parse" (map T.unpack objects)
    liftIO $ traverse parseObjId hashes

data RevType = RTCommit | RTTag deriving Show

parseRevType :: Text -> IO RevType
parseRevType t =
    case T.strip t of
        "commit" -> pure RTCommit
        "tag" -> pure RTTag
        _ -> error "Rev type is neither commit nor tag"

gitGetRevType :: MonadIO m => Text -> GitT m RevType
gitGetRevType rev = do
    t <- git "cat-file" ["-t", T.unpack rev]
    liftIO $ parseRevType t

parseCommits :: Text -> Maybe [VC.Commit]
parseCommits input = do
    input' <- T.stripPrefix "commit " input
    let sections = T.splitOn "\ncommit " input'
    traverse (parseSection . T.lines) sections
    where
    parseSection (hash : a : ad : c : cd : "" : title : "    " : rest) = do
        a' <- T.strip <$> T.stripPrefix "Author:" a
        author <- parsePerson a'
        ad' <- T.strip <$> T.stripPrefix "AuthorDate:" ad
        date <- parseDate ad'
        committed <- do
            c' <- T.strip <$> T.stripPrefix "Commit:" c
            cd' <- T.strip <$> T.stripPrefix "CommitDate:" cd
            if c' == a' && cd' == ad'
                then pure Nothing
                else Just $ (,) <$> parsePerson c' <*> parseDate cd'
        title' <- T.stripPrefix "    " title
        desc <- T.unlines <$> traverse (T.stripPrefix "    ") rest
        return $ VC.Commit (author, date) committed hash title' desc
        where
        parseDate t =
            parseTimeM False defaultTimeLocale rfc822DateFormat $ T.unpack t
        parsePerson t = do
            let (name, e) = T.break (== '<') t
            (c, e') <- T.uncons e
            (e'', c') <- T.unsnoc e'
            guard $ c == '<'
            guard $ c' == '>'
            email <- emailAddress $ TE.encodeUtf8 e''
            return $ VC.Author name email
    parseSection _ = Nothing

gitGetCommitInfos
    :: MonadIO m
    => Text -> [ObjId] -> Maybe Int -> Maybe Int -> GitT m [VC.Commit]
gitGetCommitInfos refspec existingBranchHashes maybeLimit maybeOffset = do
    let limit =
            case maybeLimit of
                Nothing -> []
                Just n -> ["--max-count=" ++ show n]
        offset =
            case maybeOffset of
                Nothing -> []
                Just n -> ["--skip=" ++ show n]
    t <- git "rev-list" $ offset ++ limit ++ ["--format=fuller", T.unpack refspec] ++ map (('^' :) . T.unpack . renderObjId) existingBranchHashes
    case parseCommits t of
        Just cs -> pure cs
        Nothing -> error "parseCommits failed"

gitGetCommitInfo :: MonadIO m => ObjId -> GitT m (VC.Commit)
gitGetCommitInfo oid = do
    cs <- gitGetCommitInfos (renderObjId oid) [] Nothing Nothing
    case cs of
        [c] -> pure c
        _ -> error "gitGetCommitInfo: Expected a single commit"

--gitDiff :: MonadIO m => Text -> GitT m [FileDelta]
gitDiff :: MonadIO m => ObjId -> GitT m Text
gitDiff commitOid =
    let commitHash = renderObjId commitOid
    in  git "diff"
            ["--no-color", T.unpack $ commitHash <> "~", T.unpack commitHash]
    {-
    case parseDiff t of
        Left e -> error $ "gitDiff: " ++ e
        Right deltas -> pure deltas
    -}

gitGetCommitParents :: MonadIO m => ObjId -> GitT m [ObjId]
gitGetCommitParents oid = do
    hashes <- T.lines <$> git "rev-parse" [T.unpack $ renderObjId oid <> "^@"]
    liftIO $ traverse parseObjId hashes

-- | Given a tag's hash, if it's an annotated tag, return the commit hash it
-- points to
gitPeelTag :: MonadIO m => ObjId -> GitT m (Maybe ObjId)
gitPeelTag tagOid = do
    let tagHash = renderObjId tagOid
    typ <- gitGetRevType tagHash
    commitHash <- T.strip <$> git "rev-parse" [T.unpack $ tagHash <> "^{commit}"]
    case (typ, commitHash == tagHash) of
        (RTCommit, True) -> pure Nothing
        (RTTag, False) -> liftIO $ Just <$> parseObjId commitHash
        _ -> error "gitPeelTag unexpected situation"

gitFetch :: MonadIO m => Text -> Text -> Text -> GitT m ()
gitFetch myBranch u theirBranch = git_ "fetch" [T.unpack u, T.unpack $ theirBranch <> ":" <> myBranch]