module Repo (
    Repo, getRepoWorkDir,
    DeclaredRepo(..),
    RepoName(..), textRepoName, showRepoName,
    Commit, commitId, commitRepo,
    CommitId, textCommitId, showCommitId,
    Tree, treeId, treeRepo, treeSubdir,
    TreeId, textTreeId, showTreeId,
    Tag(..),
    TagId, textTagId, showTagId,
    Branch(..),

    openRepo,
    readCommit, readCommitId, tryReadCommit,
    readTree, readTreeId, tryReadTree,
    readBranch,
    readTag, tryReadTag,
    listCommits, listCommitsFrom,
    listTags,
    mergeBase,
    findUpstreamRef,

    getCommitTree,
    getCommitTitle,
    getCommitMessage,

    getSubtree,

    checkoutAt,
    createWipCommit,
    readCommittedFile,
    pushToBranch,

    watchBranch,
    watchTags,
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (IOException)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class

import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.Function
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding
import Data.Time.Format
import Data.Time.LocalTime

import System.Environment
import System.Exit
import System.FilePath
import System.INotify
import System.IO.Temp
import System.Process


data Repo
    = GitRepo
        { gitDir :: FilePath
        , gitWritable :: Bool
        , gitLock :: MVar ()
        , gitInotify :: MVar (Maybe GitInotify)
        }

instance Show Repo where
    show GitRepo {..} = gitDir

getRepoWorkDir :: Repo -> FilePath
getRepoWorkDir GitRepo {..} = takeDirectory gitDir

data DeclaredRepo = DeclaredRepo
    { repoName :: RepoName
    , repoPath :: Maybe FilePath
    , repoWritable :: Bool
    }

newtype RepoName = RepoName Text
    deriving (Eq, Ord)

textRepoName :: RepoName -> Text
textRepoName (RepoName text) = text

showRepoName :: RepoName -> String
showRepoName = T.unpack . textRepoName


data Commit = Commit
    { commitRepo :: Repo
    , commitId_ :: CommitId
    , commitDetails :: MVar (Maybe CommitDetails)
    }

commitId :: Commit -> CommitId
commitId = commitId_

data CommitDetails = CommitDetails
    { commitTree :: Tree
    , commitTitle :: Text
    , commitMessage :: Text
    }

data Tree = Tree
    { treeRepo :: Repo -- ^ Repository in which the tree is tored
    , treeId :: TreeId -- ^ Tree ID
    , treeSubdir :: FilePath -- ^ Subdirectory represented by this tree (from the repo root)
    , treeIsDir :: Bool
    }

data Tag a = Tag
    { tagTag :: Text
    , tagId :: TagId
    , tagObject :: a
    , tagTagger :: Text
    , tagTime :: ZonedTime
    , tagMessage :: Text
    }

data Branch = Branch
    { branchRepo :: Repo
    , branchName :: Text
    }

instance Eq Repo where
    (==) = (==) `on` gitLock

instance Eq Commit where
    x == y  =  commitRepo x == commitRepo y &&
                commitId_ x == commitId_ y


newtype CommitId = CommitId ByteString
    deriving (Eq, Ord)

textCommitId :: CommitId -> Text
textCommitId (CommitId cid) = decodeUtf8 cid

showCommitId :: CommitId -> String
showCommitId (CommitId cid) = BC.unpack cid

newtype TreeId = TreeId ByteString
    deriving (Eq, Ord)

textTreeId :: TreeId -> Text
textTreeId (TreeId tid) = decodeUtf8 tid

showTreeId :: TreeId -> String
showTreeId (TreeId tid) = BC.unpack tid

newtype TagId = TagId ByteString
    deriving (Eq, Ord)

textTagId :: TagId -> Text
textTagId (TagId tid) = decodeUtf8 tid

showTagId :: TagId -> String
showTagId (TagId tid) = BC.unpack tid


runGitCommand :: MonadIO m => Repo -> [ String ] -> m String
runGitCommand GitRepo {..} args = liftIO $ do
    withMVar gitLock $ \_ -> do
        readProcess "git" (("--git-dir=" <> gitDir) : args) ""


openRepo :: Bool -> FilePath -> IO (Maybe Repo)
openRepo gitWritable path = do
    findGitDir >>= \case
        Just gitDir -> do
            gitLock <- newMVar ()
            gitInotify <- newMVar Nothing
            return $ Just GitRepo {..}
        Nothing -> do
            return Nothing
  where
    tryGitDir gpath = readProcessWithExitCode "git" [ "rev-parse", "--resolve-git-dir", gpath ] "" >>= \case
        ( ExitSuccess, out, _ ) | dir : _ <- lines out -> return (Just dir)
        _                                              -> return Nothing
    findGitDir = do
        tryGitDir path >>= \case
            Just dir -> return (Just dir)
            Nothing  -> tryGitDir (path </> ".git") >>= \case
                Just dir -> return (Just dir)
                _        -> return Nothing

mkCommit :: MonadIO m => Repo -> CommitId -> m Commit
mkCommit commitRepo commitId_ = do
    commitDetails <- liftIO $ newMVar Nothing
    return $ Commit {..}

readCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m Commit
readCommit repo@GitRepo {..} ref = maybe (fail err) return =<< tryReadCommit repo ref
    where err = "revision ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’"

readCommitId :: (MonadIO m, MonadFail m) => Repo -> CommitId -> m Commit
readCommitId repo cid = readCommit repo (textCommitId cid)

tryReadCommit :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe Commit)
tryReadCommit repo ref = sequence . fmap (mkCommit repo . CommitId) =<< tryReadObjectId repo "commit" ref

readTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m Tree
readTree repo@GitRepo {..} subdir ref = maybe (fail err) return =<< tryReadTree repo subdir ref
    where err = "tree ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’"

readTreeId :: (MonadIO m, MonadFail m) => Repo -> FilePath -> TreeId -> m Tree
readTreeId repo subdir tid = readTree repo subdir $ textTreeId tid

tryReadTree :: (MonadIO m, MonadFail m) => Repo -> FilePath -> Text -> m (Maybe Tree)
tryReadTree treeRepo treeSubdir ref = do
    tryReadObjectId treeRepo "tree" ref >>= \case
        Just oid -> do
            let treeIsDir = True
                treeId = TreeId oid
            return $ Just Tree {..}
        Nothing -> tryReadObjectId treeRepo "blob" ref >>= \case
            Just oid -> do
                let treeIsDir = False
                    treeId = TreeId oid
                return $ Just Tree {..}
            Nothing -> return Nothing

tryReadObjectId :: (MonadIO m, MonadFail m) => Repo -> Text -> Text -> m (Maybe ByteString)
tryReadObjectId GitRepo {..} otype ref = do
    liftIO (readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", T.unpack ref <> "^{" <> T.unpack otype <> "}" ] "") >>= \case
        ( ExitSuccess, out, _ ) | oid : _ <- lines out -> return $ Just $ BC.pack oid
        _                                              -> return Nothing


readCommitFromFile :: MonadIO m => Repo -> FilePath -> m (Maybe Commit)
readCommitFromFile repo@GitRepo {..} path = liftIO $ do
    try @IO @IOException (BC.readFile $ gitDir </> path) >>= \case
        Right content | (cid : _) <- BC.lines content -> do
            Just <$> mkCommit repo (CommitId cid)
        _ -> do
            return Nothing

readBranch :: MonadIO m => Repo -> Text -> m (Maybe Commit)
readBranch repo branch = readCommitFromFile repo ("refs/heads" </> T.unpack branch)

readTag :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Tag Commit)
readTag repo@GitRepo {..} tag = maybe (fail err) return =<< tryReadTag repo tag
  where err = "tag ‘" <> T.unpack tag <> "’ not found in ‘" <> gitDir <> "’"

tryReadTag :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Maybe (Tag Commit))
tryReadTag repo tag = do
    mbTagId <- fmap TagId <$> tryReadObjectId repo "tag" tag
    mbCat <- forM mbTagId $ \tid ->
        fmap (fmap (drop 1) . span (not . null) . lines) $
        runGitCommand repo [ "cat-file", "tag", showTagId tid ]

    sequence $ do
        tagId <- mbTagId
        ( infoPart, message ) <- mbCat
        let info = map (fmap (drop 1) . span (/= ' ')) infoPart

        otype <- lookup "type" info
        guard (otype == "commit")
        tagTag <- T.pack <$> lookup "tag" info
        cid <- CommitId . BC.pack <$> lookup "object" info

        tagger <- T.pack <$> lookup "tagger" info
        let tagTagger = T.dropEnd 1 $ T.dropWhileEnd (/= ' ') $ T.dropEnd 1 $ T.dropWhileEnd (/= ' ') tagger
        tagTime <- parseTimeM False defaultTimeLocale "%s %z" $ T.unpack $ T.drop (T.length tagTagger + 1) tagger

        let tagMessage = T.pack $ unlines $ dropWhile null message
        Just $ do
            tagObject <- liftIO $ mkCommit repo cid
            return Tag {..}

listCommits :: MonadIO m => Repo -> Text -> m [ Commit ]
listCommits commitRepo range = liftIO $ do
    out <- runGitCommand commitRepo [ "rev-list", "--first-parent", "--reverse", T.unpack range ]
    forM (lines out) $ \cid -> do
        let commitId_ = CommitId (BC.pack cid)
        commitDetails <- newMVar Nothing
        return Commit {..}

listCommitsFrom :: MonadIO m => Repo -> [ CommitId ] -> [ CommitId ] -> m [ Commit ]
listCommitsFrom commitRepo from except = liftIO $ do
    out <- runGitCommand commitRepo $ concat
        [ [ "rev-list", "--first-parent", "--reverse" ]
        , map showCommitId from
        , "--not" : map showCommitId except
        ]
    forM (lines out) $ \cid -> do
        let commitId_ = CommitId (BC.pack cid)
        commitDetails <- newMVar Nothing
        return Commit {..}

listTags :: MonadIO m => Repo -> m [ Tag Commit ]
listTags repo = liftIO $ do
    out <- runGitCommand repo
        [ "for-each-ref", "refs/tags"
        , "--format=%(objecttype) %(refname:short)"
        ]
    fmap catMaybes $ forM (map words $ lines out) $ \case
        [ "tag", tname ] -> tryReadTag repo (T.pack tname)
        _ -> return Nothing

mergeBase :: MonadIO m => Repo -> [ CommitId ] -> m [ Commit ]
mergeBase commitRepo cids = liftIO $ do
    out <- runGitCommand commitRepo $ "merge-base" : "--all" : "--octopus" : map showCommitId cids
    forM (lines out) $ \cid -> do
        let commitId_ = CommitId (BC.pack cid)
        commitDetails <- newMVar Nothing
        return Commit {..}


findUpstreamRef :: MonadIO m => Repo -> Text -> m (Maybe Text)
findUpstreamRef repo@GitRepo {..} ref = liftIO $ do
    deref <- readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "symbolic-ref", "--quiet", T.unpack ref ] "" >>= \case
        ( ExitSuccess, out, _ ) | [ deref ] <- lines out -> return deref
        ( _, _, _ ) -> return $ T.unpack ref
    runGitCommand repo [ "show-ref", deref ] >>= \case
        out | [ _, fullRef ] : _ <- words <$> lines out
            -> runGitCommand repo [ "for-each-ref", "--format=%(upstream)", fullRef ] >>= \case
            out' | [ upstream ] <- lines out'
                -> return $ Just $ T.pack upstream
            _ -> return Nothing
        _ -> return Nothing

getGitRefPath :: MonadIO m => Repo -> Text -> m (Maybe FilePath)
getGitRefPath GitRepo {..} ref = liftIO $ do
    readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--symbolic-full-name", T.unpack ref ] "" >>= \case
        ( ExitSuccess, out, _ ) | [ path ] <- lines out -> return (Just path)
        ( _, _, _ ) -> return Nothing


getCommitDetails :: (MonadIO m, MonadFail m) => Commit -> m CommitDetails
getCommitDetails Commit {..} = do
    liftIO $ do
        modifyMVar commitDetails $ \case
            cur@(Just details) -> do
                return ( cur, details )
            Nothing -> do
                ( infoPart, _ : title : message ) <-
                    fmap (span (not . null) . lines) $
                    runGitCommand commitRepo [ "cat-file", "commit", showCommitId commitId_ ]
                let info = map (fmap (drop 1) . span (/= ' ')) infoPart

                Just treeId <- return $ TreeId . BC.pack <$> lookup "tree" info
                let treeRepo = commitRepo
                    treeSubdir = ""
                    treeIsDir = True
                let commitTree = Tree {..}
                let commitTitle = T.pack title
                let commitMessage = T.pack $ unlines $ dropWhile null message

                let details = CommitDetails {..}
                return ( Just details, details )

getCommitTree :: (MonadIO m, MonadFail m) => Commit -> m Tree
getCommitTree = fmap commitTree . getCommitDetails

getCommitTitle :: (MonadIO m, MonadFail m) => Commit -> m Text
getCommitTitle = fmap commitTitle . getCommitDetails

getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text
getCommitMessage = fmap commitMessage . getCommitDetails


getSubtree :: (MonadIO m, MonadFail m) => Maybe Commit -> FilePath -> Tree -> m Tree
getSubtree mbCommit path tree = liftIO $ do
    let GitRepo {..} = treeRepo tree
        dirs = dropWhile (`elem` [ ".", "/" ]) $ splitDirectories path

    case dirs of
        [] -> return tree
        _ -> readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> joinPath dirs ] "" >>= \case
            ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
                isdir <- readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "cat-file", "-t", tid ] "" >>= \case
                    ( ExitSuccess, otype, _ )
                        | "tree" : _ <- lines otype -> return True
                        | "blob" : _ <- lines otype -> return False
                    _ -> do
                        fail $ "subtree ‘" <> path <> "’ " <> maybe "" ((" in revision ‘" <>) . (<> "’") . showCommitId . commitId) mbCommit <> " has unknown object type"

                return Tree
                    { treeRepo = treeRepo tree
                    , treeId = TreeId (BC.pack tid)
                    , treeSubdir = joinPath $ treeSubdir tree : dirs
                    , treeIsDir = isdir
                    }
            _ -> do
                fail $ "subtree ‘" <> path <> "’ not found" <> maybe "" ((" in revision ‘" <>) . (<> "’") . showCommitId . commitId) mbCommit


checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
checkoutAt Tree {..} dest = do
    let GitRepo {..} = treeRepo
    liftIO $ withSystemTempFile "minici-checkout.index" $ \index _ -> do
        curenv <- getEnvironment
        let readGitProcess args input =
                withMVar gitLock $ \_ ->
                    readCreateProcess (proc "git" args)
                        { env = Just $ concat
                            [ [ ( "GIT_INDEX_FILE", index ) ]
                            , [ ( "GIT_DIR", gitDir ) ]
                            , [ ( "GIT_WORK_TREE", "." ) ]
                            , curenv
                            ]
                        } input
        dest' <- if treeIsDir
            then do
                "" <- readGitProcess [ "read-tree", showTreeId treeId ] ""
                return dest
            else do
                "" <- readGitProcess [ "read-tree", "--empty" ] ""
                "" <- readGitProcess [ "update-index", "--add", "--cacheinfo", "100644," <> showTreeId treeId <> "," <> takeFileName dest ] ""
                return $ takeDirectory dest
        "" <- readGitProcess [ "checkout-index", "--all", "--prefix=" <> addTrailingPathSeparator dest' ] ""
        return ()

createWipCommit :: (MonadIO m, MonadMask m, MonadFail m) => Repo -> m Commit
createWipCommit repo@GitRepo {..} = do
    withSystemTempFile "minici-wip.index" $ \index _ -> do
        curenv <- liftIO getEnvironment
        let readGitProcess mbWorkTree args input = liftIO $ do
                withMVar gitLock $ \_ ->
                    readCreateProcess (proc "git" args)
                        { env = Just $ concat
                            [ [ ( "GIT_INDEX_FILE", index ) ]
                            , [ ( "GIT_DIR", gitDir ) ]
                            , map (( "GIT_WORK_TREE", ) . T.unpack) $ maybeToList mbWorkTree
                            , curenv
                            ]
                        } input
            mkPair = fmap (T.dropWhile (== ' ')) . T.break (== ' ')
        info <- map mkPair . takeWhile (not . T.null) . T.splitOn "\0". T.pack <$>
            readGitProcess Nothing [ "worktree", "list", "--porcelain", "-z" ] ""
        case ( lookup "worktree" info, lookup "HEAD" info ) of
            ( Just worktree, Just headRev ) -> do
                let readGitProcessW = readGitProcess (Just worktree)

                headCommit <- mkCommit repo (CommitId $ encodeUtf8 headRev)
                headTree <- getCommitTree headCommit

                "" <- readGitProcessW [ "read-tree", "--empty" ] ""
                status <- map mkPair . T.splitOn "\0" . T.pack <$>
                    readGitProcessW [ "status", "--porcelain=v1", "-z", "--untracked-files=all" ] ""
                "" <- readGitProcessW [ "update-index", "--add", "-z", "--stdin" ] $ T.unpack $ T.intercalate "\0" $ map snd status
                [ tid ] <- lines <$> readGitProcessW [ "write-tree" ] ""

                if TreeId (BC.pack tid) == treeId headTree
                  then return headCommit
                  else do
                    headMsg <- getCommitTitle headCommit
                    let wipMsg = case lookup "branch" info of
                            Just branch -> "WIP on " <> branch <> ": " <> headMsg
                            Nothing -> "WIP: " <> headMsg
                    [ cid ] <- lines <$> readGitProcessW [ "commit-tree", "-m", T.unpack wipMsg, "-p", T.unpack headRev, tid ] ""
                    mkCommit repo (CommitId $ BC.pack cid)

            _ -> readCommit repo "HEAD"


readCommittedFile :: MonadIO m => Tree -> FilePath -> m (Maybe BL.ByteString)
readCommittedFile Tree {..} path = do
    let GitRepo {..} = treeRepo
    liftIO $ withMVar gitLock $ \_ -> do
        let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showTreeId treeId <> ":" <> path ])
                { std_in = NoStream
                , std_out = CreatePipe
                }
        createProcess cmd >>= \( _, mbstdout, _, ph ) -> if
            | Just stdout <- mbstdout -> do
                content <- BL.hGetContents stdout

                -- check if there will be some output:
                case BL.uncons content of
                    Just (c, _) -> c `seq` return ()
                    Nothing -> return ()

                getProcessExitCode ph >>= \case
                    Just code | code /= ExitSuccess ->
                        return Nothing
                    _ ->
                        return (Just content)
            | otherwise -> error "createProcess must return stdout handle"

pushToBranch :: (MonadIO m, MonadFail m) => Branch -> Commit -> m ()
pushToBranch Branch {..} Commit {..} = do
    when (not $ gitWritable branchRepo) $ do
        fail $ "repo ‘" <> gitDir branchRepo <> "’ is not writable"
    join $ liftIO $
        withMVar (gitLock branchRepo) $ \_ ->
        withMVar (gitLock commitRepo) $ \_ -> do
            let cmd = (proc "git" [ "--git-dir=" <> gitDir commitRepo, "push", "--quiet", "--porcelain", gitDir branchRepo, showCommitId commitId_ <> ":refs/heads/" <> T.unpack branchName ])
                    { std_in = NoStream
                    , std_out = CreatePipe
                    , std_err = NoStream
                    }
            createProcess cmd >>= \( _, mbstdout, _, ph ) -> if
                | Just _ <- mbstdout -> do
                    waitForProcess ph >>= \case
                        ExitSuccess -> return $ return ()
                        code -> return $ fail $ "git push exited with error: " <> show code
                | otherwise -> error "createProcess must return stdout handle"


data GitInotify = GitInotify
    { giInotify :: INotify
    , giTags :: MVar (Maybe ( WatchDescriptor, TChan (Tag Commit) ))
    , giDirs :: MVar (Map FilePath ( WatchDescriptor, Map Text (TVar (Maybe Commit)) ))
    }

repoInotify :: Repo -> IO GitInotify
repoInotify GitRepo {..} = modifyMVar gitInotify $ \case
    cur@(Just gi) ->
        return ( cur, gi )
    Nothing -> do
        giInotify <- initINotify
        giTags <- newMVar Nothing
        giDirs <- newMVar M.empty
        let gi = GitInotify {..}
        return ( Just gi, gi )

watchBranch :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Either Commit (STM (Maybe Commit)))
watchBranch repo@GitRepo {..} ref = liftIO $ do
    mbCommit <- tryReadCommit repo ref
    gi@GitInotify {..} <- repoInotify repo
    getGitRefPath repo ref >>= \case
        Just path -> Right <$> do
            let ( dir, sbranch ) = splitFileName path
                branch = T.pack sbranch
            modifyMVar giDirs $ \dirMap ->
                case M.lookup dir dirMap of
                    Just ( wd, branchMap ) ->
                        case M.lookup branch branchMap of
                            Just tvar -> do
                                return ( dirMap, readTVar tvar )
                            Nothing -> do
                                tvar <- newTVarIO mbCommit
                                return ( M.insert dir ( wd, M.insert branch tvar branchMap ) dirMap, readTVar tvar )

                    Nothing -> do
                        wd <- addBranchWatch gi dir
                        tvar <- newTVarIO mbCommit
                        return ( M.insert dir ( wd, M.singleton branch tvar ) dirMap, readTVar tvar )

        Nothing | Just commit <- mbCommit -> do
            return $ Left commit

        _ -> do
            fail $ "ref ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’"
  where
    addBranchWatch GitInotify {..} dir = do
        addWatch giInotify [ MoveIn ] (BC.pack $ gitDir </> dir) $ \event -> do
            let branch = decodeUtf8 $ filePath event
            withMVar giDirs $ \dirMap -> do
                Just ( _, branchMap ) <- return $ M.lookup dir dirMap
                case M.lookup branch branchMap of
                    Just tvar -> do
                        commit <- readCommitFromFile repo (dir </> T.unpack branch)
                        atomically $ writeTVar tvar commit
                    Nothing -> do
                        return ()

watchTags :: MonadIO m => Repo -> m (TChan (Tag Commit))
watchTags repo@GitRepo {..} = liftIO $ do
    GitInotify {..} <- repoInotify repo
    chan <- modifyMVar giTags $ \case
        cur@(Just ( _, chan )) -> do
            return ( cur, chan )
        Nothing -> do
            chan <- newBroadcastTChanIO
            wd <- addWatch giInotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do
                tryReadTag repo (decodeUtf8 $ filePath event) >>= \case
                    Just tag -> atomically $ writeTChan chan tag
                    Nothing  -> return ()
            return ( Just ( wd, chan ), chan )
    atomically $ dupTChan chan
  where
    tagsDir = gitDir </> "refs/tags"