    -- 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.

    {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
    {-# LANGUAGE CPP, ScopedTypeVariables #-}

    #include "gadts.h"

    module Darcs.Repository
        ( Repository, ($-), maybeIdentifyRepository, identifyRepositoryFor
        , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory
        , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository
        , amNotInRepository, slurp_pending, replacePristine, slurp_recorded
        , slurp_recorded_and_unrecorded, withRecorded, read_repo, prefsUrl
        , add_to_pending, tentativelyAddPatch, tentativelyRemovePatches
        , tentativelyAddToPending, tentativelyReplacePatches
        , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges
        , finalizeRepositoryChanges, createRepository, copyRepository
        , copy_oldrepo_patches, patchSetToRepository, unrevertUrl, applyToWorking
        , patchSetToPatches, createPristineDirectoryTree
        , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository
        , getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd
        , setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded
        -- * Recorded and unrecorded and pending.
        , readRecorded, readUnrecorded, unrecordedChanges, readPending, pendingChanges
        , readRecordedAndPending
        -- * Index.
        , readIndex, invalidateIndex
        ) where

    import System.Exit ( ExitCode(..), exitWith )

    import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges
                                 , readPending, pendingChanges, readIndex, invalidateIndex
                                 , readRecordedAndPending )

    import Darcs.Repository.Internal
        (Repository(..), RepoType(..), ($-),
         maybeIdentifyRepository, identifyRepositoryFor,
         findRepository, amInRepository, amNotInRepository,
         makePatchLazy,
         slurp_pending,
         slurp_recorded, slurp_recorded_and_unrecorded,
         withRecorded,
         read_repo,
         prefsUrl,
         withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
         tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
         tentativelyReplacePatches,
         revertRepositoryChanges, finalizeRepositoryChanges,
         unrevertUrl,
         applyToWorking, patchSetToPatches,
         createPristineDirectoryTree, createPartialsPristineDirectoryTree,
         optimizeInventory, cleanRepository,
         getMarkedupFile,
         setScriptsExecutable,
         testTentative, testRecorded,
         make_new_pending
        )
    import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking )
    import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) )
    import Darcs.Patch.Set ( PatchSet, SealedPatchSet )

    import Control.Monad ( unless, when )
    import Data.Either(Either(..))
    import System.Directory ( createDirectory, renameDirectory )
    import System.IO.Error ( isAlreadyExistsError )

    import qualified Darcs.Repository.DarcsRepo as DarcsRepo
    import qualified Darcs.Repository.HashedRepo as HashedRepo

    import Darcs.Hopefully ( PatchInfoAnd, info, extractHash )
    import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint )
    import Darcs.Repository.ApplyPatches ( apply_patches )
    import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine, pris2inv )
    import Darcs.Repository.InternalTypes ( Pristine(..) )
    import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply )
    import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL
                         , reverseRL ,concatRL, lengthRL, isShorterThanRL, (+>+) )
    import Darcs.Patch.Info ( PatchInfo )
    import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),
                                     createRepoFormat, formatHas, writeRepoFormat )
    import Darcs.Repository.Prefs ( writeDefaultPrefs )
    import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking )
    import Darcs.Patch.Depends ( get_patches_beyond_tag )
    import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError )
    import Darcs.External ( copyFileOrUrl, Cachable(..) )
    import Progress ( debugMessage, tediousSize,
                            beginTedious, endTedious, progress )
    import Darcs.ProgressPatches (progressRLShowTags, progressFL)
    import Darcs.Lock ( writeBinFile, writeDocBinFile, rm_recursive )
    import Darcs.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )

    import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral, Complete,
                                    AllowUnrelatedRepos, NoUpdateWorking )
                       , compression )
    import Darcs.Global ( darcsdir )

    import Storage.Hashed.Tree( Tree, emptyTree )
    import Storage.Hashed.Hash( encodeBase16 )
    import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes )
    import Storage.Hashed( writePlainTree )
    import ByteStringUtils( gzReadFilePS )

    import System.FilePath( (</>) )

    import qualified Data.ByteString.Char8 as BS

    #include "impossible.h"

    createRepository :: [DarcsFlag] -> IO ()
    createRepository opts = do
      createDirectory darcsdir `catch`
          (\e-> if isAlreadyExistsError e
                then fail "Tree has already been initialized!"
                else fail $ "Error creating directory `"++darcsdir++"'.")
      let rf = createRepoFormat opts
      createPristine $ flagsToPristine opts rf
      createDirectory $ darcsdir ++ "/patches"
      createDirectory $ darcsdir ++ "/prefs"
      writeDefaultPrefs
      writeRepoFormat rf (darcsdir++"/format")
      if formatHas HashedInventory rf
          then writeBinFile (darcsdir++"/hashed_inventory") ""
          else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK!

    copyRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
    copyRepository fromrepository@(Repo _ opts rf _)
        | Partial `elem` opts && not (formatHas HashedInventory rf) =
            do isPartial <- copyPartialRepository fromrepository
               unless (isPartial == IsPartial) $ copyFullRepository fromrepository
        | otherwise = copyFullRepository fromrepository

    data PorNP = NotPartial | IsPartial
                 deriving ( Eq )

    data RepoSort = Hashed | Old

    copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
    copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do
      repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "."
      let newrepo :: Repository p C(r u t)
          newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote))
          copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir
          copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>=
                                DarcsRepo.write_inventory_and_patches opts
          repoSort rfx | formatHas HashedInventory rfx = Hashed
                       | otherwise = Old
      case repoSort rf2 of
        Hashed ->
            if formatHas HashedInventory rf
            then copyHashedHashed
            else withCurrentDirectory todir $
                 do HashedRepo.revert_tentative_changes
                    patches <- read_repo fromrepo
                    let k = "Copying patch"
                    beginTedious k
                    tediousSize k (lengthRL $ concatRL patches)
                    let patches' = mapRL_RL (mapRL_RL (progress k)) patches
                    HashedRepo.write_tentative_inventory c (compression opts) patches'
                    endTedious k
                    HashedRepo.finalize_tentative_changes repo (compression opts)
        Old -> case repoSort rf of
               Hashed -> copyAnythingToOld fromrepo
               _ -> copy_oldrepo_patches opts fromrepo todir

    copy_oldrepo_patches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO ()
    copy_oldrepo_patches opts repository@(Repo dir _ _ _) out = do
      Sealed patches <- DarcsRepo.read_repo opts "." :: IO (SealedPatchSet Patch)
      mpi <- if Partial `elem` opts
             -- FIXME this should get last pinfo *before*
             -- desired tag...
             then identify_checkpoint repository
             else return Nothing
      FlippedSeal scp <- return $ since_checkpoint mpi $ concatRL patches
      DarcsRepo.copy_patches opts dir out $ mapRL info $ scp
          where since_checkpoint :: Maybe PatchInfo
                                 -> RL (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (PatchInfoAnd p)) C(y)
                since_checkpoint Nothing ps = flipSeal ps
                since_checkpoint (Just ch) (hp:<:ps)
                    | ch == info hp = flipSeal $ hp :<: NilRL
                    | otherwise = (hp :<:) `mapFlipped` since_checkpoint (Just ch) ps
                since_checkpoint _ NilRL = flipSeal NilRL

    copyPartialRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO PorNP
    copyPartialRepository fromrepository@(Repo _ opts _ _) = do
      mch <- get_checkpoint fromrepository :: IO (Maybe (Sealed (Named p C(x))))
      case mch of
        Nothing -> do putStrLn "No checkpoint."
                      return NotPartial
        Just (Sealed ch) ->
          do copyInventory fromrepository
             withRepoLock opts $- \torepository -> do
               write_checkpoint_patch ch
               local_patches <- read_repo torepository
               let pi_ch = patch2patchinfo ch
               FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches
               let needed_patches = reverseRL ps
               apply opts ch `catch`
                                 \e -> fail ("Bad checkpoint!\n" ++ prettyError e)
               apply_patches opts needed_patches
               debugMessage "Writing the pristine"
               pristineFromWorking torepository
               return IsPartial

    copyFullRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
    copyFullRepository fromrepository@(Repo fromdir opts rffrom _) = do
      copyInventory fromrepository
      debugMessage "Copying prefs"
      copyFileOrUrl opts (fromdir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)
                         `catchall` return ()
      debugMessage "Grabbing lock in new repository..."
      withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) ->
          if formatHas HashedInventory rffrom && formatHas HashedInventory rfto
          then do debugMessage "Writing working directory contents..."
                  createPristineDirectoryTree torepository "."
                  fetch_patches_if_necessary opts torepository
                  when (Partial `elem` opts) $ putStrLn $
                           "--partial: hashed or darcs-2 repository detected, using --lazy instead"
          else if formatHas HashedInventory rfto
               then do local_patches <- read_repo torepository
                       replacePristine torepository emptyTree
                       let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $
                                            mapRL_RL reverseRL local_patches
                       sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply
                       finalizeRepositoryChanges torepository
                       debugMessage "Writing working directory contents..."
                       createPristineDirectoryTree torepository "."
               else do read_repo torepository >>= (apply_patches opts . reverseRL . concatRL)
                       debugMessage "Writing the pristine"
                       pristineFromWorking torepository

    -- | writePatchSet is like patchSetToRepository, except that it doesn't
    -- touch the working directory or pristine cache.
    writePatchSet :: RepoPatch p => PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t))
    writePatchSet patchset opts = do
        maybeRepo <- maybeIdentifyRepository opts "."
        let repo@(Repo _ _ rf2 (DarcsRepository _ c)) =
              case maybeRepo of
                Right r -> r
                Left e  -> bug ("Current directory not repository in writePatchSet: " ++ e)
        debugMessage "Writing inventory"
        if formatHas HashedInventory rf2
           then do HashedRepo.write_tentative_inventory c (compression opts) patchset
                   HashedRepo.finalize_tentative_changes repo (compression opts)
           else DarcsRepo.write_inventory_and_patches opts patchset
        return repo

    -- | patchSetToRepository takes a patch set, and writes a new repository in the current directory
    --   that contains all the patches in the patch set. This function is used when 'darcs get'ing a
    --   repository with the --to-match flag and the new repository is not in hashed format.
    --   This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell
    --   darcs to create a hashed repository, this function will call @error@.
    patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x)
                         -> [DarcsFlag] -> IO (Repository p C(r u t))
    patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do
        when (formatHas HashedInventory rf) $ -- set up sources and all that
           do writeFile "_darcs/tentative_pristine" "" -- this is hokey
              repox <- writePatchSet patchset opts
              HashedRepo.copy_repo repox opts fromrepo
        repo <- writePatchSet patchset opts
        read_repo repo >>= (apply_patches opts . reverseRL . concatRL)
        debugMessage "Writing the pristine"
        pristineFromWorking repo
        return repo

    checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(y) -> IO ()
    checkUnrelatedRepos opts common us them
        | AllowUnrelatedRepos `elem` opts || not (null common)
           || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5
            = return ()
        | otherwise
            = do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?")
                 when (yorn /= 'y') $ do putStrLn "Cancelled."
                                         exitWith ExitSuccess

    -- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy,
    --   --partial or --ephemeral), this function fetches all patches that the given repository has
    --   with fetchFileUsingCache. This is used as a helper in copyFullRepository.
    fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO ()
    fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) =
        unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $
                 do unless (Complete `elem` opts) $
                           putInfo "Copying patches, to get lazy repository hit ctrl-C..."
                    r <- read_repo torepository
                    let peekaboo :: PatchInfoAnd p C(x y) -> IO ()
                        peekaboo x = case extractHash x of
                                     Left _ -> return ()
                                     Right h -> fetchFileUsingCache c HashedPatchesDir h >> return ()
                    sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r
      where putInfo = when (not $ Quiet `elem` opts) . putStrLn

    add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
    add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
    add_to_pending repo@(Repo _ opts _ _) p =
        do pend <- unrecordedChanges opts repo []
           invalidateIndex repo
           make_new_pending repo (pend +>+ p)

    -- | Replace the existing pristine with a new one (loaded up in a Tree object).
    replacePristine :: Repository p C(r u t) -> Tree IO -> IO ()
    replacePristine (Repo r _opts _rf (DarcsRepository pris _c)) tree =
        withCurrentDirectory r $ replace pris
        where replace HashedPristine =
                  do let t = darcsdir </> "hashed_inventory"
                     i <- gzReadFilePS t
                     tree' <- darcsAddMissingHashes tree
                     root <- writeDarcsHashed tree' $ darcsdir </> "pristine.hashed"
                     writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i
              replace (PlainPristine n) =
                  do rm_recursive nold `catchall` return ()
                     writePlainTree tree ntmp
                     renameDirectory n nold
                     renameDirectory ntmp n
                     return ()
              replace (NoPristine _) = return ()
              nold = darcsdir </> "pristine-old"
              ntmp = darcsdir </> "pristine-tmp"

    pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()
    pristineFromWorking repo@(Repo dir _ rf _)
        | formatHas HashedInventory rf =
            withCurrentDirectory dir $ readWorking >>= replacePristine repo
    pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =
      withCurrentDirectory dir $ createPristineFromWorking p