%  Copyright (C) 2002-2004 David Roundy
%  Copyright (C) 2005 Juliusz Chroboczek
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.

\begin{code}
module Repository ( Repository, maybeIdentifyRepository, identifyRepository,
                    findRepository, amInRepository, slurp_pending,
                    slurp_recorded, slurp_recorded_and_unrecorded,
                    get_unrecorded, read_repo, sync_repo, absolute_dir,
                    prefsUrl,
                    read_pending, with_new_pending, add_to_pending,
                    withRepoLock,
#ifdef HAVEWX
                    takeRepoGuiLock, releaseRepoGuiLock, withRepoGuiLockCanFail,
#endif
                    PatchToken, patchTokenToPatchFile,
                    writePatch, updateInventory, unrevertUrl,
                    applyToWorking,
                    applyToPristine, patchSetToPatches,
                    PatchSet
                  ) where
import External ( fetchFilePS, Cachable( Cachable ) )
import Pristine ( Pristine, identifyPristine, nopristine, applyPristine,
                )
import RepoFormat ( RepoFormat, identifyRepoFormat,
                    write_problem, read_problem )
import Directory ( doesDirectoryExist, setCurrentDirectory )
import Monad ( liftM, when )
import Maybe ( catMaybes )
import SlurpDirectory ( Slurpy, slurp_unboring, co_slurp, slurp_has )
import DarcsRepo ( seekRepo, youNeedToBeInRepo )
import qualified DarcsRepo
import qualified GitRepo
import DarcsFlags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose,
                              Quiet,
                              WorkDir, UMask) )
import PatchInfo ( PatchInfo )
import Patch ( Patch, flatten, join_patches, reorder_and_coalesce,
               apply,
               apply_to_slurpy, gzReadPatchFileLazily )
import Diff ( smart_diff )
import PatchSet ( PatchSet )
import Workaround ( getCurrentDirectory )
import DarcsUtils ( catchall, withCurrentDirectory, withUMask )
import RepoPrefs ( darcsdir_filter, boring_file_filter, filetype_function )
import Lock ( withLock )
#ifdef HAVEWX
import Lock ( takeLock, releaseLock, withLockCanFail )
#endif
import DarcsIO ( runTolerantly, runSilently )
#include "impossible.h"

data Repository = Repo !String !RepoFormat !RepoType

data RepoType = DarcsRepository !Pristine | GitRepository

maybeIdentifyRepository :: String -> IO (Either String Repository)
maybeIdentifyRepository "." =
    do darcs <- doesDirectoryExist "_darcs"
       git <- doesDirectoryExist ".git"
       rf <- identifyRepoFormat "."
       here <- absolute_dir "."
       case read_problem rf of
         Just err -> return $ Left err
         Nothing ->
           case (darcs, git) of
           (False, False) -> return (Left "Not a repository")
           (True, _)->
               do pris <- identifyPristine
                  return $ Right $ Repo here rf (DarcsRepository pris)
           (False, True) -> return (Right $ Repo here rf GitRepository)
maybeIdentifyRepository url' = do
    url <- absolute_dir url'
    darcs <- doesRemoteFileExist (url++"/_darcs/inventory")
    git <- doesRemoteFileExist (url++"/.git/HEAD")
    rf <- identifyRepoFormat url
    case read_problem rf of
        Just err -> return $ Left err
        Nothing ->
            case (darcs, git) of
            (Left s, Left _) ->
                return (Left $ "Not a repository: " ++ url' ++
                        " (" ++ s ++")")
            (Right True, _)->
                return $ Right $ Repo url rf (DarcsRepository nopristine)
            (Left _, Right True) -> return (Right $ Repo url rf GitRepository)
            _ -> impossible
    where drfe x = fetchFilePS x Cachable >> return True
          doesRemoteFileExist x = (liftM Right) (drfe x) `catch`
                                      (\e -> return (Left (show e)))

identifyRepository :: String -> IO Repository
identifyRepository url =
    do er <- maybeIdentifyRepository url
       case er of
           Left s -> fail s
           Right r -> return r

isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _         = False

currentDirIsRepository :: IO Bool
currentDirIsRepository = isRight `liftM` maybeIdentifyRepository "."

amInRepository :: [DarcsFlag] -> IO (Either String FilePath)
amInRepository (WorkDir d:_) =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       amInRepository []
amInRepository (_:fs) = amInRepository fs
amInRepository [] = 
    seekRepo currentDirIsRepository (Left youNeedToBeInRepo)

findRepository :: [DarcsFlag] -> IO (Either String FilePath)
findRepository (WorkDir d:_) =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       findRepository []
findRepository (_:fs) = findRepository fs
findRepository [] = 
    seekRepo currentDirIsRepository (Right "")

slurp_pending :: Repository -> IO Slurpy
slurp_pending repo = do
  cur <- slurp_recorded repo
  mbpend <- read_pending repo
  case mbpend of
    Just pend ->
      case apply_to_slurpy pend cur of
        Just pendcur -> return pendcur
        Nothing -> do putStrLn "Yikes, pending has conflicts!"
                      return cur
    Nothing -> return cur

slurp_recorded :: Repository -> IO Slurpy
slurp_recorded (Repo r _ (DarcsRepository pristine)) =
    withCurrentDirectory r $ DarcsRepo.surely_slurp_Pristine pristine
slurp_recorded (Repo r  _ GitRepository) = GitRepo.slurpHead r

slurp_recorded_and_unrecorded :: Repository -> IO (Slurpy, Slurpy)
slurp_recorded_and_unrecorded (Repo r _ (DarcsRepository _)) =
    DarcsRepo.slurp_recorded_and_unrecorded r
slurp_recorded_and_unrecorded repo@(Repo r _ _) = do
  cur <- slurp_recorded repo
  mbpend <- read_pending repo
  withCurrentDirectory r $
    case mbpend of
    Just pend ->
      case apply_to_slurpy pend cur of
      Nothing -> fail "Yikes, pending has conflicts!"
      Just pendslurp -> do unrec <- co_slurp pendslurp "."
                           return (cur, unrec)
    Nothing -> do unrec <- co_slurp cur "."
                  return (cur, unrec)

pendingName :: RepoType -> String
pendingName (DarcsRepository _) = "_darcs/patches/pending"
pendingName GitRepository = ".git/darcs_pending"

read_pending :: Repository -> IO (Maybe Patch)
read_pending (Repo r _ tp) =
    withCurrentDirectory r (DarcsRepo.read_pending (pendingName tp))

add_to_pending :: Repository -> Patch -> IO ()
add_to_pending repo p =
    do pend <- read_pending repo
       let pnew = case pend of Nothing -> p
                               Just pold -> join_patches [pold, p]
       with_new_pending repo pnew (return ())

with_new_pending :: Repository -> Patch -> IO () -> IO ()
with_new_pending repo@(Repo r _ tp) p job =
    withCurrentDirectory r $
    DarcsRepo.with_new_pending (pendingName tp) p $ job >> slurp_recorded repo

unempty :: [a] -> Maybe [a]
unempty [] = Nothing
unempty l = Just l

get_unrecorded :: Repository -> [DarcsFlag] -> IO (Maybe Patch)
get_unrecorded repository@(Repo r _ _) opts =
  withCurrentDirectory r $ do
    cur <- slurp_pending repository
    work <- if LookForAdds `elem` opts
            then do nboring <- if Boring `elem` opts
                               then return $ darcsdir_filter
                               else boring_file_filter
                    slurp_unboring (myfilt cur nboring) "."
            else co_slurp cur "."
    pend <- read_pending repository
    when (Verbose `elem` opts) $ putStrLn "diffing dir..."
    ftf <- filetype_function
    case smart_diff opts ftf cur work of
      Nothing -> case pend of
                 Just x | null (flatten x) -> return Nothing
                 _ -> return pend
      Just di->
        case pend of
        Nothing -> return $ Just di
        Just pp ->
            if AnyOrder `elem` opts
            then return $ liftM join_patches $
                 unempty $ flatten $ join_patches [pp,di]
            else return $ liftM (reorder_and_coalesce . join_patches) $
                 unempty $ flatten $ join_patches [pp,di]
    where myfilt s nboring f = slurp_has f s || nboring [f] /= []

read_repo :: Repository -> IO PatchSet
read_repo (Repo r _ (DarcsRepository _)) = DarcsRepo.read_repo r
read_repo (Repo r _ GitRepository) = GitRepo.read_repo r

sync_repo :: Repository -> IO ()
sync_repo (Repo r _ (DarcsRepository p)) =
    withCurrentDirectory r $ DarcsRepo.sync_repo p
-- this should probably update the Git cache
sync_repo (Repo _ _ GitRepository) = return ()

absolute_dir :: FilePath -> IO FilePath
absolute_dir = DarcsRepo.absolute_dir

prefsUrl :: Repository -> String
prefsUrl (Repo r _ (DarcsRepository _)) = r ++ "/_darcs/prefs"
prefsUrl (Repo r _ GitRepository) = r ++ "/.git/darcs-prefs"

unrevertUrl :: Repository -> String
unrevertUrl (Repo r _ (DarcsRepository _)) = r ++ "/_darcs/patches/unrevert"
unrevertUrl (Repo r _ GitRepository) = r ++ "/.git/darcs-unrevert"

applyToWorking :: Repository -> [DarcsFlag] -> Patch -> IO ()
applyToWorking (Repo r _ (DarcsRepository _)) opts patch =
    withCurrentDirectory r $ if Quiet `elem` opts
                             then runSilently $ apply opts patch
                             else runTolerantly $ apply opts patch
applyToWorking (Repo _ _ GitRepository) _ _ = return ()


applyToPristine :: Repository -> Patch -> IO ()
applyToPristine (Repo r _ (DarcsRepository p)) patch =
    withCurrentDirectory r $ applyPristine p patch
applyToPristine (Repo _ _ GitRepository) _ = return ()

-- writePatch returns an opaque token that should be passed to updateInventory.

data PatchToken = DarcsPatchToken !String | GitPatchToken !String

writePatch :: Repository -> [DarcsFlag] -> Patch -> IO (Patch, PatchToken)
writePatch (Repo dir _ (DarcsRepository _)) opts patch =
    withCurrentDirectory dir $
        do fp <- DarcsRepo.write_patch opts patch
           patch' <- gzReadPatchFileLazily fp
           return (patch', DarcsPatchToken fp)
writePatch (Repo dir _ GitRepository) _ patch =
    withCurrentDirectory dir $
        do cd <- getCurrentDirectory
           (patch', token) <- GitRepo.writePatch cd patch
           return (patch', GitPatchToken token)

-- this should be called with signals blocked
updateInventory :: Repository -> [(PatchInfo, PatchToken)] -> IO ()
updateInventory (Repo dir _ (DarcsRepository _)) l =
    withCurrentDirectory dir $
        DarcsRepo.add_to_inventory "." (map fst l)
updateInventory (Repo dir _ GitRepository) l =
    withCurrentDirectory dir $
        GitRepo.updateInventory (map (\(_,(GitPatchToken t)) -> t) l)

patchTokenToPatchFile :: PatchToken -> Maybe String
patchTokenToPatchFile (DarcsPatchToken fp) = Just fp
patchTokenToPatchFile _ = Nothing

patchSetToPatches :: PatchSet -> [Patch]
patchSetToPatches patchSet = catMaybes $ map snd $ reverse $ concat patchSet

getUMask :: [DarcsFlag] -> Maybe String
getUMask [] = Nothing
getUMask ((UMask u):_) = Just u
getUMask (_:l) = getUMask l

withRepoLock :: [DarcsFlag] -> (Repository -> IO a) -> IO a
withRepoLock opts job = do repository <- identifyRepository "."
                           let (Repo _ rf rt) = repository
                           case write_problem rf of
                               Nothing -> return ()
                               Just err -> fail err
                           let name = case rt of
                                        DarcsRepository _ -> "./_darcs/lock"
                                        GitRepository -> "./.git/lock"
                               wu = case (getUMask opts) of
                                      Nothing -> id
                                      Just u -> withUMask u
                           wu (withLock name (job repository))

#ifdef HAVEWX
takeRepoGuiLock :: IO Bool
takeRepoGuiLock =
 do (_,name) <- guiLockFileHelper
    takeLock name

releaseRepoGuiLock :: IO ()
releaseRepoGuiLock =
 do (_,name) <- guiLockFileHelper
    releaseLock name

withRepoGuiLockCanFail :: (Repository -> IO a) -> IO (Either () a)
withRepoGuiLockCanFail job =
 do (repository,name) <- guiLockFileHelper
    withLockCanFail name (job repository)

guiLockFileHelper :: IO (Repository, FilePath)
guiLockFileHelper =
 do repository <- identifyRepository "."
    let (Repo _ rf rt) = repository
    case write_problem rf of
      Nothing  -> return ()
      Just err -> fail err
    let name = case rt of
          (DarcsRepository _) -> "./_darcs/guilock"
          GitRepository       -> "./.git/guilock"
    return (repository, name)
#endif
\end{code}