{- 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.Darcs
    ( DarcsT
    , withDarcsRepo
    , withDarcsRepoE
    , darcs
    , darcs'
    , darcs_
    , darcsE
    , darcsE_

    , writeDefaultsFile
    , createRepo
    , isDarcsRepo

    , DirTree (..)
    , darcsGetTree
    , lookupTreeItem
    , darcsGetFileContent
    , darcsListTags
    , darcsListTags'
    , xml2patch
    , darcsLog
    , darcsLogLength
    , darcsShowCommit
    , darcsDiff
    , darcsGetHead
    , darcsPull
    )
where

import Control.Applicative
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.Bits
import Data.Char
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Map (Map)
import Data.Set (Set)
import Data.Text (Text)
import Data.Time.Format
import Data.Traversable
import Data.Tree
import System.Directory
import System.FilePath
import System.Posix.Files
import System.Process.Typed
import Text.Email.Validate
import Text.Read (readMaybe)
import Text.XML.Light

import qualified Data.Attoparsec.Text as A
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 qualified Data.VersionControl as VC

import Data.ObjId

import Control.Monad.Trans.Except.Local

writeDefaultsFile :: FilePath -> FilePath -> Text -> Text -> IO ()
writeDefaultsFile path cmd authority repo = do
    let file = path </> "_darcs" </> "prefs" </> "defaults"
    TIO.writeFile file $ defaultsContent cmd authority repo
    setFileMode file $ ownerReadMode .|. ownerWriteMode
    where
    defaultsContent :: FilePath -> Text -> Text -> Text
    defaultsContent hook authority repo =
        T.concat
            [ "apply posthook "
            , T.pack hook, " ", authority, " ", repo
            ]

-- | initialize a new bare repository at a specific location.
createRepo
    :: FilePath
    -- ^ Parent directory which already exists
    -> Text
    -- ^ Repo keyhashid, i.e. new directory to create under the parent
    -> FilePath
    -- ^ Path of Vervis hook program
    -> Text
    -- ^ Instance HTTP authority
    -> IO ()
createRepo parent repo cmd authority = do
    let path = parent </> T.unpack repo
    createDirectory path
    runProcess_ $ setStdin nullStream $ proc "darcs" ["init", "--no-working-dir", "--repodir", path]
    writeDefaultsFile path cmd authority repo

isDarcsRepo :: FilePath -> IO Bool
isDarcsRepo path = do
    items <- listDirectory path
    case find (== "_darcs") items of
        Nothing -> pure False
        Just item -> doesDirectoryExist $ path </> item

type DarcsT m a = ReaderT FilePath m a

withDarcsRepo :: MonadIO m => FilePath -> DarcsT m a -> m a
withDarcsRepo path action = runReaderT action path

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

withDarcsRepoE :: MonadIO m => FilePath -> DarcsE m a -> ExceptT Text m a
withDarcsRepoE path action = ExceptT $ withDarcsRepo path $ runExceptT action

darcs :: MonadIO m => String -> [String] -> DarcsT m Text
darcs = darcs' "--repodir"

-- Same as 'darcs', except it alows to specify the name of the property used
-- for the repo path
darcs' :: MonadIO m => String -> String -> [String] -> DarcsT m Text
darcs' repoOption cmd args = do
    repo <- ask
    lb <- readProcessStdout_ $ setStdin nullStream $ proc "darcs" $ cmd : args ++ [repoOption, repo]
    liftIO $ either throwIO return $ TE.decodeUtf8' $ BL.toStrict lb

darcs_ :: MonadIO m => String -> [String] -> DarcsT m ()
darcs_ cmd args = do
    repo <- ask
    runProcess_ $ setStdin nullStream $ proc "darcs" $ cmd : args ++ ["--repodir", repo]

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

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

type FileName = String

parseEntry :: Text -> IO (NonEmpty FileName)
parseEntry t =
        case splitDirectories $ T.unpack t of
            "." : (p : ieces) -> pure $ p :| ieces
            _ -> error "parseEntry: Unexpected line format"

parseSkeleton :: Text -> IO [Tree FileName]
parseSkeleton input = do
    let lines = T.lines input
    lines' <-
        case lines of
            [] -> error "parseSkeleton: No lines"
            "." : ls -> pure ls
            _ -> error "parseSkeleton: First line isn't \".\""
    entries <- traverse parseEntry lines'
    either error pure $ buildTreeE entries
    where
    {-
    reverseTree (Node label children) = Node label $ reverseForest children
    reverseForest trees = map reverseTree $ reverse trees
    -}

    partitionDirs :: [NonEmpty a] -> ([(a, NonEmpty a)], [(a, [(a, NonEmpty a)])])
    partitionDirs = foldr go ([], [])
        where
        go (x :| xs) (dir, dirs) =
            case xs of
                []     -> ([]                , (x, dir) : dirs)
                (y:ys) -> ((x, y :| ys) : dir, dirs)

    partitionDirsE :: (Eq a, Show a) => [NonEmpty a] -> Either String [(a, [NonEmpty a])]
    partitionDirsE entries =
        let (firsts, dirs) = partitionDirs entries
        in  if null firsts
                then for dirs $ \ (dirname, children) ->
                        fmap (dirname,) $ for children $ \ (n, ns) ->
                            if (n == dirname)
                                then Right ns
                                else Left $ "Under " ++ show dirname ++ " found " ++ show (n, ns)
                else Left $ "First item(s) don't have a parent dir: " ++ show firsts

    buildTreeE :: (Eq a, Show a) => [NonEmpty a] -> Either String [Tree a]
    buildTreeE entries = do
        dirs <- partitionDirsE entries
        traverse makeTreeE dirs
        where
        makeTreeE :: (Eq a, Show a) => (a, [NonEmpty a]) -> Either String (Tree a)
        makeTreeE (name, children) = do
            dirs <- partitionDirsE children
            trees <- traverse makeTreeE dirs
            Right $ Node name trees

data DirTree = DirTree
    { _dtDirs  :: [(FileName, DirTree)]
    , _dtFiles :: [FileName]
    }
    deriving Show

treeToDT :: [Tree FileName] -> DirTree
treeToDT trees = DirTree (map adaptTree trees) []
    where
    adaptTree (Node name children) = (name, treeToDT children)

parseFiles :: Text -> IO [NonEmpty FileName]
parseFiles input = do
    let lines = T.lines input
    traverse parseEntry lines

insertFileE :: NonEmpty FileName -> DirTree -> Either String DirTree
insertFileE = go
    where
    go (x :| []) (DirTree dirs files) = Right $ DirTree dirs $ x : files
    go (x :| (y : l)) (DirTree dirs files) = do
        let (notEq, rest) = break ((== x) . fst) dirs
        case rest of
            [] -> Left $ show x ++ " not found in " ++ show dirs
            ((n, tree) : rest') -> do
                tree' <- go (y :| l) tree
                let dirs' = notEq ++ (n, tree') : rest'
                Right $ DirTree dirs' files

darcsGetTree :: MonadIO m => Text -> DarcsT m DirTree
darcsGetTree hash = do
    tree <-
        darcs "show" ["files", "--no-pending", "--hash", T.unpack hash, "--no-files"] >>=
        fmap treeToDT . liftIO . parseSkeleton
    files <-
        darcs "show" ["files", "--no-pending", "--hash", T.unpack hash, "--no-directories"] >>=
        liftIO . parseFiles
    either error pure $ foldrM insertFileE tree files

lookupTreeItem :: [FileName] -> DirTree -> Maybe (Either () DirTree)
lookupTreeItem []     tree = Just $ Right tree
lookupTreeItem (n:ns) tree = go (n :| ns) tree
    where
    go (x :| []) (DirTree dirs files) =
        case lookup x dirs of
            Just tree -> Just $ Right tree
            Nothing ->
                if x `elem` files
                    then Just $ Left ()
                    else Nothing
    go (x :| (y : l)) (DirTree dirs _) = do
        tree <- lookup x dirs
        go (y :| l) tree

darcsGetFileContent :: MonadIO m => Text -> FilePath -> DarcsT m Text
darcsGetFileContent hash path =
    darcs "show" ["contents", "--hash", T.unpack hash, path]

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

darcsListTags :: MonadIO m => DarcsT m (Set Text)
darcsListTags = do
    t <- darcs' "--repo" "show" ["tags"]
    ts <- liftIO $ parseTags t
    return $ S.fromList ts

darcsListTags' :: MonadIO m => DarcsT m (Map Text ObjId)
darcsListTags' = do
    t <- darcs "log" ["--xml-output", "--tags=."]
    case parseCommits t of
        Nothing -> error "parseCommits failed"
        Just cs -> liftIO $ fmap M.fromList $ for cs $ \ c -> do
            oid <- parseObjId $ VC.commitHash c
            name <-
                case T.stripPrefix "TAG " $ VC.commitTitle c of
                    Nothing -> error "No TAG prefix"
                    Just n -> pure n
            return (name, oid)

xml2patch :: Monad m => Element -> ExceptT Text m VC.Commit
xml2patch elem = do
    unless (elName elem == QName "patch" Nothing Nothing) $
        throwE $
            "Expected <patch>, found: " <> T.pack (show $ elName elem)
    (name, email) <- do
        t <- T.pack <$> findAttrE "author" elem
        parseOnlyE authorP t "author"
    date <- do
        s <- findAttrE "date" elem
        case parseTimeM False defaultTimeLocale "%Y%m%d%H%M%S" s of
            Nothing -> throwE $ "Date parsing failed: " <> T.pack s
            Just t -> return t
    hash <- do
        t <- T.pack <$> findAttrE "hash" elem
        unless (T.length t == 40) $
            throwE $ "Expected a hash string of length 40, got: " <> t
        return t

    inverted <- do
        s <- findAttrE "inverted" elem
        readMaybeE s $ "Unrecognized inverted value: " <> T.pack s
    when inverted $ throwE $ "Found inverted patch " <> hash

    title <- T.pack . strContent <$> findChildE "name" elem
    description <- do
        t <- T.pack . strContent <$> findChildE "comment" elem
        parseOnlyE commentP t "comment"

    return VC.Commit
        { VC.commitWritten     = (VC.Author name email, date)
        , VC.commitCommitted   = Nothing
        , VC.commitHash        = hash
        , VC.commitTitle       = title
        , VC.commitDescription = description
        }
    where
    readMaybeE s e = fromMaybeE (readMaybe s) e
    findAttrE q e =
        let ms = findAttr (QName q Nothing Nothing) e
        in  fromMaybeE ms $ "Couldn't find attr \"" <> T.pack q <> "\""
    findChildE q e =
        case findChildren (QName q Nothing Nothing) e of
            [] -> throwE $ "No children named " <> T.pack q
            [c] -> return c
            _ -> throwE $ "Multiple children named " <> T.pack q
    authorP = (,)
        <$> (T.stripEnd <$> A.takeWhile1 (/= '<'))
        <*  A.skip (== '<')
        <*> (A.takeWhile1 (/= '>') >>= emailP)
        <*  A.skip (== '>')
        where
        emailP
            = maybe (fail "Invalid email") pure
            . emailAddress
            . TE.encodeUtf8
    commentP
        =  A.string "Ignore-this: "
        *> A.takeWhile1 isHexDigit
        *> (fromMaybe T.empty <$>
                optional (A.endOfLine *> A.endOfLine *> A.takeText)
           )
    parseOnlyE p t n =
        case A.parseOnly (p <* A.endOfInput) t of
            Left e ->
                throwE $ T.concat ["Parsing ", n, " failed: ", T.pack e]
            Right a -> return a

parseCommits :: Text -> Maybe [VC.Commit]
parseCommits input = do
    element <- parseXMLDoc input
    either (const Nothing) Just $ runExcept $
        traverse xml2patch $ elChildren element

darcsLog :: MonadIO m => Maybe Int -> Maybe Int -> DarcsT m [VC.Commit]
darcsLog maybeLimit maybeOffset = do
    let offset = fromMaybe 0 maybeOffset
        limit = fromMaybe 1000000000 maybeLimit
        from = offset + 1
        to = offset + limit
    t <- darcs "log" ["--xml-output", "--index", show from ++ "-" ++ show to]
    case parseCommits t of
        Just cs -> pure cs
        Nothing -> error "parseCommits failed"

darcsLogLength :: MonadIO m => DarcsT m Int
darcsLogLength = pure . read . T.unpack =<< darcs "log" ["--count"]

darcsShowCommit :: MonadIO m => ObjId -> DarcsT m (VC.Commit)
darcsShowCommit oid = do
    t <- darcs "log" ["--xml-output", "--hash", T.unpack $ renderObjId oid]
    case parseCommits t of
        Just [c] -> pure c
        Just _ -> error "darcs expected to return exactly one patch"
        Nothing -> error "parseCommits failed"

darcsDiff :: MonadIO m => ObjId -> DarcsT m Text
darcsDiff patchOid =
    let patchHash = renderObjId patchOid
    in  darcs "diff" ["--hash", T.unpack patchHash]

darcsGetHead :: MonadIO m => DarcsT m Text
darcsGetHead = do
    cs <- darcsLog (Just 1) Nothing
    case cs of
        [c] -> pure $ VC.commitHash c
        _ -> error "darcsGetHead: Expected exactly one patch"

darcsPull :: MonadIO m => Text -> DarcsT m ()
darcsPull u = darcs_ "pull" ["--all", T.unpack u]