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

{-# LANGUAGE CPP, ScopedTypeVariables #-}


module Darcs.Repository
    ( Repository
    , HashedDir(..)
    , Cache(..)
    , CacheLoc(..)
    , WritableOrNot(..)
    , RepoJob(..)
    , maybeIdentifyRepository
    , identifyRepositoryFor
    , withRecorded
    , withRepoLock
    , withRepoLockCanFail
    , withRepository
    , withRepositoryDirectory
    , writePatchSet
    , findRepository
    , amInRepository
    , amNotInRepository
    , amInHashedRepository
    , replacePristine
    , readRepo
    , prefsUrl
    , repoPatchType
    , readRepoUsingSpecificInventory
    , addToPending
    , addPendingDiffToPending
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyAddToPending
    , tentativelyReplacePatches
    , readTentativeRepo
    , withManualRebaseUpdate
    , tentativelyMergePatches
    , considerMergeToWorking
    , revertRepositoryChanges
    , finalizeRepositoryChanges
    , createRepository
    , cloneRepository
    , patchSetToRepository
    , unrevertUrl
    , applyToWorking
    , patchSetToPatches
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , reorderInventory
    , cleanRepository
    , PatchSet
    , SealedPatchSet
    , PatchInfoAnd
    , setScriptsExecutable
    , setScriptsExecutablePatches
    , checkUnrelatedRepos
    , testTentative
    , modifyCache
    , reportBadSources
    -- * Recorded and unrecorded and pending.
    , readRecorded
    , readUnrecorded
    , unrecordedChanges
    , unrecordedChangesWithPatches
    , filterOutConflicts
    , readPending
    , readRecordedAndPending
    -- * Index.
    , readIndex
    , invalidateIndex
    -- * Used as command arguments
    , listFiles
    , listRegisteredFiles
    , listUnregisteredFiles
    ) where

import Prelude hiding ( catch, pi )

import System.Exit ( exitSuccess )
import Data.List ( (\\), isPrefixOf )
import Data.Maybe( catMaybes, isJust, listToMaybe )

import Darcs.Repository.State
    ( readRecorded
    , readUnrecorded
    , readWorking
    , unrecordedChanges
    , unrecordedChangesWithPatches
    , readPendingAndWorking
    , readPending
    , readIndex
    , invalidateIndex
    , readRecordedAndPending
    , restrictDarcsdir
    , restrictBoring
    , applyTreeFilter
    , filterOutConflicts
    )

import Darcs.Repository.Internal
    (Repository(..)
    , maybeIdentifyRepository
    , identifyRepositoryFor
    , identifyRepository
    , IdentifyRepo(..)
    , findRepository
    , amInRepository
    , amNotInRepository
    , amInHashedRepository
    , readRepo
    , readTentativeRepo
    , readRepoUsingSpecificInventory
    , prefsUrl
    , withRecorded
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyReplacePatches
    , tentativelyAddToPending
    , revertRepositoryChanges
    , finalizeRepositoryChanges
    , unrevertUrl
    , applyToWorking
    , patchSetToPatches
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , reorderInventory
    , cleanRepository
    , setScriptsExecutable
    , setScriptsExecutablePatches
    , makeNewPending
    , seekRepo
    )
import Darcs.Repository.Job
    ( RepoJob(..)
    , withRepoLock
    , withRepoLockCanFail
    , withRepository
    , withRepositoryDirectory
    )
import Darcs.Repository.Rebase ( withManualRebaseUpdate )
import Darcs.Repository.Test
    ( testTentative )

import Darcs.Repository.Merge( tentativelyMergePatches
                             , considerMergeToWorking
                             )
import Darcs.Repository.Cache ( unionRemoteCaches
                              , fetchFileUsingCache
                              , speculateFileUsingCache
                              , HashedDir(..)
                              , Cache(..)
                              , CacheLoc(..)
                              , WritableOrNot(..)
                              , hashedDir
                              , bucketFolder
                              , CacheType(Directory)
                              , reportBadSources
                              )

import Darcs.Patch ( RepoPatch
                   , apply
                   , invert
                   , effect
                   , PrimOf
                   )
import Darcs.Patch.Set ( Origin
                       , PatchSet(..)
                       , SealedPatchSet
                       , newset2RL
                       , newset2FL
                       , progressPatchSet
                       )
import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch )
import Darcs.Patch.Commute( commuteFL )
import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )
import Control.Exception ( catch, Exception, throwIO, finally, IOException )
import Control.Concurrent ( forkIO )
import Control.Concurrent.MVar ( MVar
                               , newMVar
                               , putMVar
                               , takeMVar
                               )
import Control.Monad ( unless, when, void )
import Control.Applicative( (<$>) )
import System.Directory ( createDirectory
                        , createDirectoryIfMissing
                        , renameFile
                        , doesFileExist
                        , removeFile
                        , getDirectoryContents
                        , getCurrentDirectory
                        , setCurrentDirectory
                        )
import System.IO ( stderr )
import System.IO.Error ( isAlreadyExistsError )
import System.Posix.Files ( createLink )

import qualified Darcs.Repository.HashedRepo as HashedRepo

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully )
import Darcs.Repository.ApplyPatches ( applyPatches, runDefault )
import Darcs.Repository.HashedRepo ( applyToTentativePristine
                                   , pris2inv
                                   , inv2pris
                                   , revertTentativeChanges
                                   , copySources
                                   )
import Darcs.Repository.InternalTypes ( modifyCache )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FreeLeft, unFreeLeft )
import Darcs.Patch.Witnesses.Ordered
       ((:>)(..), reverseRL, reverseFL, lengthFL, mapFL_FL, FL(..),
        RL(..), bunchFL, mapFL, mapRL, lengthRL, (+>+), (:\/:)(..))
import Darcs.Repository.Format ( RepoProperty ( HashedInventory, Darcs2 )
                               , RepoFormat
                               , createRepoFormat
                               , formatHas
                               , writeRepoFormat
                               , readProblem
                               )
import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources )
import Darcs.Repository.Match ( getOnePatchset )
import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon, findCommonWithThem
                           , countUsThem )
import Darcs.Patch.Type ( PatchType(..) )

import Darcs.Util.Exception ( catchall )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Repository.External
    ( copyFileOrUrl
    , Cachable(..)
    , fetchFileLazyPS
    , gzFetchFilePS
    )
import Darcs.Util.Progress ( debugMessage
                , tediousSize
                , beginTedious
                , endTedious
                )
import Darcs.Patch.Progress
    ( progressRLShowTags
    , progressFL
    )
import Darcs.Repository.Lock
    ( writeBinFile
    , writeDocBinFile
    , withTemp
    )
import Darcs.Repository.Flags
    ( UpdateWorking(..)
    , UseCache(..)
    , UseIndex(..)
    , ScanKnown(..)
    , RemoteDarcs (..)
    , Reorder (..)
    , Compression (..)
    , CloneKind (..)
    , Verbosity (..)
    , DryRun (..)
    , UMask (..)
    , AllowConflicts (..)
    , ExternalMerge (..)
    , WantGuiPause (..)
    , SetScriptsExecutable (..)
    , RemoteRepos (..)
    , SetDefault (..)
    , DiffAlgorithm (..)
    , WithWorkingDir (..)
    , ForgetParent (..)
    , WithPatchIndex (..)
    )

import Darcs.Util.Download ( maxPipelineLength )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.Util.SignalHandler ( catchInterrupt )
import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) )

import Storage.Hashed.Plain( readPlainTree )
import Storage.Hashed.Tree( Tree, emptyTree, expand, list )
import Storage.Hashed.Hash( encodeBase16 )
import Darcs.Util.Path( anchorPath )
import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes )
import Darcs.Util.ByteString( gzReadFilePS )

import System.FilePath( (</>)
                      , takeFileName
                      , splitPath
                      , joinPath
                      , takeDirectory
                      )
import qualified Codec.Archive.Tar as Tar
import Codec.Compression.GZip ( compress, decompress )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Darcs.Repository.PatchIndex (createOrUpdatePatchIndexDisk, doesPatchIndexExist, createPIWithInterrupt)
#include "impossible.h"


-- @createRepository useFormat1 useNoWorkingDir patchIndex@
createRepository :: Bool -> WithWorkingDir -> WithPatchIndex -> IO ()
createRepository useFormat1 withWorkingDir createPatchIndex = do
  createDirectory darcsdir `catch`
      (\e-> if isAlreadyExistsError e
            then fail "Tree has already been initialized!"
            else fail $ "Error creating directory `"++darcsdir++"'.")
  cwd <- getCurrentDirectory
  x <- seekRepo
  when (isJust x) $ do
      setCurrentDirectory cwd
      putStrLn "WARNING: creating a nested repository."
  createDirectory $ darcsdir ++ "/pristine.hashed"
  createDirectory $ darcsdir ++ "/patches"
  createDirectory $ darcsdir ++ "/inventories"
  createDirectory $ darcsdir ++ "/prefs"
  writeDefaultPrefs
  let repoFormat = createRepoFormat useFormat1 withWorkingDir
  writeRepoFormat repoFormat (darcsdir++"/format")
  writeBinFile (darcsdir++"/hashed_inventory") ""
  writePristine "." emptyTree
  withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of
      NoPatchIndex -> return () -- default
      YesPatchIndex -> createOrUpdatePatchIndexDisk repo

repoPatchType :: Repository p wR wU wT -> PatchType p
repoPatchType _ = PatchType

cloneRepository ::
    String    -- origin repository path
    -> String -- new repository name (for relative path)
    -> Verbosity -> UseCache
    -> CloneKind
    -> UMask -> RemoteDarcs
    -> SetScriptsExecutable
    -> RemoteRepos -> SetDefault
    -> [MatchFlag]
    -> RepoFormat
    -> WithWorkingDir
    -> WithPatchIndex   -- use patch index
    -> Bool   -- use packs
    -> Bool   -- --to-match given
    -> ForgetParent
    -> IO ()
cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos
                setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks toMatch forget = do
  createDirectory mysimplename
  setCurrentDirectory mysimplename
  createRepository (not $ formatHas Darcs2 rfsource)
                   withWorkingDir
                   (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)
  debugMessage "Finished initializing new directory."
  addRepoSource repodir NoDryRun remoteRepos setDefault

  if toMatch && cloneKind /= LazyClone
    then withRepository uc $ RepoJob $ \repository -> do
      debugMessage "Using economical clone --to-match handling"
      fromrepo <- identifyRepositoryFor repository uc repodir
      Sealed patches_to_get <- getOnePatchset fromrepo matchFlags
      patchSetToRepository fromrepo patches_to_get uc rdarcs
      debugMessage "Finished converting selected patch set to new repository"
    else copyRepoAndGoToChosenVersion repodir v uc cloneKind um rdarcs sse
                                      matchFlags withWorkingDir usePacks forget

-- assumes that the target repo of the get is the current directory,
-- and that an inventory in the right format has already been created.
copyRepoAndGoToChosenVersion ::
               String -- repository directory
               -> Verbosity -> UseCache
               -> CloneKind
               -> UMask -> RemoteDarcs
               -> SetScriptsExecutable
               -> [MatchFlag]
               -> WithWorkingDir -> Bool
               -> ForgetParent
               -> IO ()
copyRepoAndGoToChosenVersion repodir v uc gk um rdarcs sse matchFlags withWorkingDir usePacks forget =
  withRepository uc $ RepoJob $ \repository -> do
     debugMessage "Identifying and copying repository..."
     fromRepo@(Repo fromDir rffrom _ _) <- identifyRepositoryFor repository uc repodir
     case readProblem rffrom of
       Just e ->  fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e
       Nothing -> return ()
     debugMessage "Copying prefs"
     copyFileOrUrl rdarcs (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")
       (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()
     if formatHas HashedInventory rffrom
      then do
        -- copying basic repository (hashed_inventory and pristine)
        if usePacks && (not . isValidLocalPath) fromDir
          then copyBasicRepoPacked    fromRepo v uc um rdarcs withWorkingDir
          else copyBasicRepoNotPacked fromRepo v uc um rdarcs withWorkingDir
        when (gk /= LazyClone) $ do
          when (gk /= CompleteClone) $
            putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."
        -- copying complete repository (inventories and patches)
          if usePacks && (not . isValidLocalPath) fromDir
            then copyCompleteRepoPacked    fromRepo v uc um gk
            else copyCompleteRepoNotPacked fromRepo v uc um gk
      else
        -- old-fashioned repositories are cloned diferently since
        -- we need to copy all patches first and then build pristine
        copyRepoOldFashioned fromRepo v uc um withWorkingDir
     when (sse == YesSetScriptsExecutable) setScriptsExecutable
     when (havePatchsetMatch matchFlags) $ do
      putStrLn "Going to specified version..."
      -- read again repository on disk to get caches and sources right
      withRepoLock NoDryRun uc YesUpdateWorking um $ RepoJob $ \repository' -> do
        patches <- readRepo repository'
        Sealed context <- getOnePatchset repository' matchFlags
        when (snd (countUsThem patches context) > 0) $
             errorDoc $ text "Missing patches from context!" -- FIXME : - (
        _ :> us' <- return $ findCommonWithThem patches context
        let ps = mapFL_FL hopefully us'
        putInfo v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++
                    englishNum (lengthFL ps) (Noun "patch") ""
        invalidateIndex repository'
        _ <- tentativelyRemovePatches repository' GzipCompression YesUpdateWorking us'
        tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect us'
        finalizeRepositoryChanges repository' YesUpdateWorking GzipCompression
        runDefault (apply (invert $ effect ps)) `catch` \(e :: IOException) ->
            fail ("Couldn't undo patch in working dir.\n" ++ show e)
        when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps)
     when (forget == YesForgetParent) deleteSources

putInfo :: Verbosity -> Doc -> IO ()
putInfo Quiet _ = return ()
putInfo _ d = hPutDocLn Encode stderr d

putVerbose :: Verbosity -> Doc -> IO ()
putVerbose Verbose d = putDocLn d
putVerbose _ _ = return ()

copyBasicRepoNotPacked  :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository p wR wU wT
                        -> Verbosity -> UseCache
                        -> UMask -> RemoteDarcs
                        -> WithWorkingDir
                        -> IO ()
copyBasicRepoNotPacked (Repo fromDir _ _ fromCache) verb useCache umask rdarcs withWorkingDir = do
  toRepo@(Repo toDir toFormat toPristine toCache) <- identifyRepository useCache "."
  let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape
  toCache2 <- unionRemoteCaches toCache fromCache fromDir
  let toRepo2 :: Repository p wR wU wT
      toRepo2 = Repo toDir toFormat toPristine toCache2
  HashedRepo.copyHashedInventory toRepo2 rdarcs fromDir
  HashedRepo.copySources toRepo2 fromDir
  debugMessage "Grabbing lock in new repository to copy basic repo..."
  withRepoLock NoDryRun useCache YesUpdateWorking umask
   $ RepoJob $ \torepository -> do
      putVerbose verb $ text "Writing pristine and working directory contents..."
      createPristineDirectoryTree torepository "." withWorkingDir


copyCompleteRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository p wR wU wT
                        -> Verbosity -> UseCache
                        -> UMask -> CloneKind
                        -> IO ()
copyCompleteRepoNotPacked _ verb useCache umask cloneKind = do
  debugMessage "Grabbing lock in new repository to copy complete repo..."
  withRepoLock NoDryRun useCache YesUpdateWorking umask
   $ RepoJob $ \torepository@(Repo todir _ _ _) -> do
       let cleanup = putInfo verb $ text "Using lazy repository."
       allowCtrlC cloneKind cleanup $ do
         fetchPatchesIfNecessary torepository
         pi <- doesPatchIndexExist todir
         when pi $ createPIWithInterrupt torepository

packsDir :: String
packsDir = "/" ++ darcsdir ++ "/packs/"

copyBasicRepoPacked ::
  forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository p wR wU wT
  -> Verbosity -> UseCache
  -> UMask -> RemoteDarcs
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked r@(Repo fromDir _ _ _) verb useCache umask rdarcs withWorkingDir =
  do let hashURL = fromDir ++ packsDir ++ "pristine"
     mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)
     let hiURL = fromDir ++ "/" ++ darcsdir ++ "/hashed_inventory"
     i <- gzFetchFilePS hiURL Uncachable
     let currentHash = BS.pack $ inv2pris i
     let copyNormally = copyBasicRepoNotPacked r verb useCache umask rdarcs withWorkingDir
     case mPackHash of
      Just packHash | packHash == currentHash
              -> ( copyBasicRepoPacked2 r verb useCache withWorkingDir
                    `catchall` do putStrLn "Problem while copying basic pack, copying normally."
                                  copyNormally)
      _       -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally."
                    copyNormally

copyBasicRepoPacked2 ::
  forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository p wR wU wT
  -> Verbosity -> UseCache
  -> WithWorkingDir -> IO ()
copyBasicRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache withWorkingDir = do
  b <- fetchFileLazyPS (fromDir ++ packsDir ++ "basic.tar.gz") Uncachable
  putVerbose verb $ text "Cloning packed basic repository."
  Repo toDir toFormat toPristine toCache <-
    identifyRepositoryFor fromRepo useCache "."
  toCache2 <- unionRemoteCaches toCache fromCache fromDir
  let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded)
      toRepo = Repo toDir toFormat toPristine toCache2
  copySources toRepo fromDir
  Repo _ _ _ toCache3 <-
    identifyRepositoryFor toRepo useCache "."
  -- unpack inventory & pristine cache
  cleanDir "pristine.hashed"
  removeFile $ darcsdir </> "hashed_inventory"
  unpackBasic toCache3 . Tar.read $ decompress b
  createPristineDirectoryTree toRepo "." withWorkingDir
  putVerbose verb $ text "Basic repository unpacked. Will now see if there are new patches."
  -- pull new patches
  us <- readRepo toRepo
  them <- readRepo fromRepo
  us' :\/: them' <- return $ findUncommon us them
  revertTentativeChanges
  Sealed pw <- tentativelyMergePatches toRepo "clone" NoAllowConflicts YesUpdateWorking NoExternalMerge NoWantGuiPause GzipCompression verb NoReorder ( UseIndex, ScanKnown, MyersDiff ) us' them'
  invalidateIndex toRepo
  finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression
  when (withWorkingDir == WithWorkingDir) $ void $ applyToWorking toRepo verb pw
 where
  cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) .
    filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d)

copyCompleteRepoPacked ::
  forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository p wR wU wT
  -> Verbosity -> UseCache
  -> UMask
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked r verb useCache umask cloneKind =
  ( copyCompleteRepoPacked2 r verb useCache cloneKind
  `catchall` do putVerbose verb $ text "Problem while copying patches pack, copying normally."
                copyCompleteRepoNotPacked r verb useCache umask cloneKind )

copyCompleteRepoPacked2 ::
  forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository p wR wU wT
  -> Verbosity -> UseCache
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache cloneKind = do
  Repo toDir toFormat toPristine toCache <- identifyRepositoryFor fromRepo useCache "."
  toCache2 <- unionRemoteCaches toCache fromCache fromDir
  let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded)
      toRepo = Repo toDir toFormat toPristine toCache2
  Repo _ _ _ toCache3 <- identifyRepositoryFor toRepo useCache "."
  us <- readRepo toRepo
  -- get old patches
  let cleanup = putInfo verb $ text "Using lazy repository."
  allowCtrlC cloneKind cleanup $ do
    cleanDir "patches"
    putVerbose verb $ text "Using patches pack."
    unpackPatches toCache3 (mapRL hashedPatchFileName $ newset2RL us) .
      Tar.read . decompress =<< fetchFileLazyPS (fromDir ++ packsDir ++ "patches.tar.gz") Uncachable
    pi <- doesPatchIndexExist toDir
    when pi $ createPIWithInterrupt toRepo
 where
  cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) .
    filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d)

allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()
allowCtrlC CompleteClone _       action = action
allowCtrlC _             cleanup action = action `catchInterrupt` cleanup

copyRepoOldFashioned :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository p wR wU wT
                        -> Verbosity -> UseCache
                        -> UMask
                        -> WithWorkingDir
                        -> IO ()
copyRepoOldFashioned fromrepository verb useCache umask withWorkingDir = do
  toRepo@(Repo _ _ _ toCache) <- identifyRepository useCache "."
  let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape
  -- copy all patches from remote
  HashedRepo.revertTentativeChanges
  patches <- readRepo fromrepository
  let k = "Copying patch"
  beginTedious k
  tediousSize k (lengthRL $ newset2RL patches)
  let patches' = progressPatchSet k patches
  HashedRepo.writeTentativeInventory toCache GzipCompression patches'
  endTedious k
  HashedRepo.finalizeTentativeChanges toRepo GzipCompression
  -- apply all patches into current hashed repository
  debugMessage "Grabbing lock in new repository..."
  withRepoLock NoDryRun useCache YesUpdateWorking umask
   $ RepoJob $ \torepository -> do
      local_patches <- readRepo torepository
      replacePristine torepository emptyTree
      let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches
      sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply
      finalizeRepositoryChanges torepository YesUpdateWorking GzipCompression
      putVerbose verb $ text "Writing pristine and working directory contents..."
      createPristineDirectoryTree torepository "." withWorkingDir

withControlMVar :: (MVar () -> IO ()) -> IO ()
withControlMVar f = do
  mv <- newMVar ()
  f mv
  takeMVar mv

forkWithControlMVar :: MVar () -> IO () -> IO ()
forkWithControlMVar mv f = do
  takeMVar mv
  _ <- forkIO $ finally f (putMVar mv ())
  return ()

removeMetaFiles :: IO ()
removeMetaFiles = mapM_ (removeFile . (darcsdir </>)) .
  filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir

unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO ()
unpackBasic c x = do
  withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x
  removeMetaFiles

unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO ()
unpackPatches c ps x = do
  withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x
  removeMetaFiles

unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO ()
unpackTar  _ _ Tar.Done = return ()
unpackTar  _ _ (Tar.Fail e)= throwIO e
unpackTar c mh (Tar.Next x xs) = case Tar.entryContent x of
  Tar.NormalFile x' _ -> do
    let p = Tar.entryPath x
    if "meta-" `isPrefixOf` takeFileName p
      then do
        BL.writeFile p x'
        mh
        unpackTar c mh xs
      else do
        ex <- doesFileExist p
        if ex
          then debugMessage $ "Tar thread: STOP " ++ p
          else do
            if p == darcsdir </> "hashed_inventory"
              then writeFile' Nothing p x'
              else writeFile' (cacheDir c) p $ compress x'
            debugMessage $ "Tar thread: GET " ++ p
            unpackTar c mh xs
  _ -> fail "Unexpected non-file tar entry"
 where
  writeFile' Nothing path content = withTemp $ \tmp -> do
    BL.writeFile tmp content
    renameFile tmp path
  writeFile' (Just ca) path content = do
    let fileFullPath = case splitPath path of
          _:hDir:hFile:_  -> joinPath [ca, hDir, bucketFolder hFile, hFile]
          _               -> fail "Unexpected file path"
    createDirectoryIfMissing True $ takeDirectory path
    createLink fileFullPath path `catch` (\(ex :: IOException) -> do
      if isAlreadyExistsError ex then
        return () -- so much the better
      else
        -- ignore cache if we cannot link
        writeFile' Nothing path content)

basicMetaHandler :: Cache -> MVar () -> IO ()
basicMetaHandler ca mv = do
  ex <- doesFileExist $ darcsdir </> "meta-filelist-pristine"
  when ex . forkWithControlMVar mv $
    fetchFilesUsingCache ca HashedPristineDir . lines =<<
      readFile (darcsdir </> "meta-filelist-pristine")

patchesMetaHandler :: Cache -> [String] -> MVar () -> IO ()
patchesMetaHandler ca ps mv = do
  ex <- doesFileExist $ darcsdir </> "meta-filelist-inventories"
  when ex $ do
    forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPristineDir .
      lines =<< readFile (darcsdir </> "meta-filelist-inventories")
    forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPatchesDir ps

cacheDir :: Cache -> Maybe String
cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of
  Cache Directory Writable x' -> Just x'
  _ -> Nothing

hashedPatchFileName :: PatchInfoAnd p wA wB -> String
hashedPatchFileName x = case extractHash x of
  Left _ -> fail "unexpected unhashed patch"
  Right h -> h

-- | fetchFilesUsingCache is similar to mapM fetchFileUsingCache, exepts
-- it stops execution if file it's going to fetch already exists.
fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO ()
fetchFilesUsingCache _ _ [] = return ()
fetchFilesUsingCache c d (f:fs) = do
  ex <- doesFileExist $ darcsdir </> hashedDir d </> f
  if ex
    then debugMessage $ "Cache thread: STOP " ++
      (darcsdir </> hashedDir d </> f)
    else do
      debugMessage $ "Cache thread: GET " ++
        (darcsdir </> hashedDir d </> f)
      _ <- fetchFileUsingCache c d f
      fetchFilesUsingCache c d fs

-- | writePatchSet is like patchSetToRepository, except that it doesn't
-- touch the working directory or pristine cache.
writePatchSet :: (RepoPatch p, ApplyState p ~ Tree)
              => PatchSet p Origin wX
              -> UseCache
              -> IO (Repository p wR wU wT)
writePatchSet patchset useCache = do
    maybeRepo <- maybeIdentifyRepository useCache "."
    let repo@(Repo _ _ _ c) =
          case maybeRepo of
            GoodRepository r -> r
            BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e)
            NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e)
    debugMessage "Writing inventory"
    HashedRepo.writeTentativeInventory c GzipCompression patchset
    HashedRepo.finalizeTentativeChanges repo GzipCompression
    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.
patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree)
                     => Repository p wR1 wU1 wR1
                     -> PatchSet p Origin wX
                     -> UseCache -> RemoteDarcs
                     -> IO ()
patchSetToRepository (Repo fromrepo rf _ _) patchset useCache remoteDarcs = do
    when (formatHas HashedInventory rf) $ -- set up sources and all that
       do writeFile (darcsdir </> "tentative_pristine") "" -- this is hokey
          repox <- writePatchSet patchset useCache
          HashedRepo.copyHashedInventory repox remoteDarcs fromrepo
          HashedRepo.copySources repox fromrepo
    repo <- writePatchSet patchset useCache
    readRepo repo >>= (runDefault . applyPatches . newset2FL)
    debugMessage "Writing the pristine"
    pristineFromWorking repo

checkUnrelatedRepos :: RepoPatch p
                    => Bool
                    -> PatchSet p wStart wX
                    -> PatchSet p wStart wY
                    -> IO ()
checkUnrelatedRepos allowUnrelatedRepos us them =
    when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $
         do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"
            unless confirmed $ do putStrLn "Cancelled."
                                  exitSuccess

-- | This function fetches all patches that the given repository has
--   with fetchFileUsingCache, unless --lazy is passed.
fetchPatchesIfNecessary :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository p wR wU wT
                        -> IO ()
fetchPatchesIfNecessary torepository@(Repo _ _ _ c) =
  do  r <- readRepo torepository
      pipelineLength <- maxPipelineLength
      let patches = newset2RL r
          ppatches = progressRLShowTags "Copying patches" patches
          (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches
          speculate | pipelineLength > 1 = [] : first : map (:[]) other
                    | otherwise = []
      mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])
  where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [String]
        hashes = catMaybes . mapRL (either (const Nothing) Just . extractHash)
        fetchAndSpeculate :: (String, [String]) -> IO ()
        fetchAndSpeculate (f, ss) = do
          _ <- fetchFileUsingCache c HashedPatchesDir f
          mapM_ (speculateFileUsingCache c HashedPatchesDir) ss

-- | Add an FL of patches started from the pending state to the pending patch.
-- TODO: add witnesses for pending so we can make the types precise: currently
-- the passed patch can be applied in any context, not just after pending.
addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree)
                          => Repository p wR wU wT -> UpdateWorking
                          -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending _ NoUpdateWorking  _ = return ()
addPendingDiffToPending repo@(Repo{}) uw@YesUpdateWorking newP = do
    (toPend :> _) <-
        readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing
    invalidateIndex repo
    case unFreeLeft newP of
        (Sealed p) -> makeNewPending repo uw $ toPend +>+ p

-- | Add a FL of patches starting from the working state to the pending patch,
-- including as much extra context as is necessary (context meaning
-- dependencies), by commuting the patches to be added past as much of the
-- changes between pending and working as is possible, and including anything
-- that doesn't commute, and the patch itself in the new pending patch.
addToPending :: (RepoPatch p, ApplyState p ~ Tree)
             => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending _ NoUpdateWorking  _ = return ()
addToPending repo@(Repo{}) uw@YesUpdateWorking p = do
   (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing
   invalidateIndex repo
   case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of
       (toP' :> p'  :> _excessUnrec) ->
           makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p'

-- | Replace the existing pristine with a new one (loaded up in a Tree object).
replacePristine :: Repository p wR wU wT -> Tree IO -> IO ()
replacePristine (Repo r _ _ _) = writePristine r

writePristine :: FilePath -> Tree IO -> IO ()
writePristine r tree = withCurrentDirectory r $
    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

pristineFromWorking :: RepoPatch p => Repository p wR wU wT -> IO ()
pristineFromWorking repo@(Repo dir _ _ _) =
  withCurrentDirectory dir $ readWorking >>= replacePristine repo

-- | Get a list of all files and directories in the working copy, including
-- boring files if necessary
listFiles :: Bool -> IO [String]
listFiles takeBoring =
  do
    nonboring <- considered emptyTree
    working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."
    return $ map (anchorPath "" . fst) $ list working
  where
    considered = if takeBoring
                 then const (return restrictDarcsdir)
                 else restrictBoring

-- | 'listUnregisteredFiles' returns the list of all non-boring unregistered
-- files in the repository.
listUnregisteredFiles :: Bool -> IO [String]
listUnregisteredFiles includeBoring =
    do unregd <- listFiles includeBoring
       regd <- listRegisteredFiles
       return $ unregd \\ regd -- (inefficient)

-- | 'listRegisteredFiles' returns the list of all registered files in the repository.
listRegisteredFiles :: IO [String]
listRegisteredFiles =
    do recorded <- expand =<< withRepository YesUseCache (RepoJob readRecordedAndPending)
       return $ map (anchorPath "" . fst) $ list recorded