module Darcs.Repository.Clone
    ( cloneRepository
    , replacePristine
    , writePatchSet
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Exception ( catch, SomeException )
import Control.Monad ( when )
import qualified Data.ByteString.Char8 as BC
import Data.List( intercalate )
import Data.Maybe( catMaybes )
import System.FilePath( (</>) )
import System.Directory
    ( removeFile
    , getDirectoryContents
    )
import System.IO ( stderr )

import Darcs.Repository.Create
    ( EmptyRepository(..)
    , createRepository
    , writePristine
    )
import Darcs.Repository.State ( invalidateIndex )
import Darcs.Repository.Pending ( tentativelyAddToPending )
import Darcs.Repository.Identify
    ( IdentifyRepo(..)
    , identifyRepositoryFor
    , maybeIdentifyRepository )
import Darcs.Repository.Hashed
    ( readRepo
    , tentativelyRemovePatches
    , finalizeRepositoryChanges
    , createPristineDirectoryTree
    , revertRepositoryChanges
    )
import Darcs.Repository.Working
    ( setScriptsExecutable
    , setScriptsExecutablePatches )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoLocation
    , repoFormat
    , repoCache
    , modifyCache
    , repoPatchType )
import Darcs.Repository.Job ( withUMaskFlag )
import Darcs.Repository.Cache
    ( unionRemoteCaches
    , unionCaches
    , fetchFileUsingCache
    , speculateFileUsingCache
    , HashedDir(..)
    , Cache(..)
    , CacheLoc(..)
    , repo2cache
    )
import qualified Darcs.Repository.Cache as DarcsCache

import qualified Darcs.Repository.Hashed as HashedRepo
import Darcs.Repository.ApplyPatches ( runDefault )
import Darcs.Repository.Hashed
    ( applyToTentativePristineCwd
    , peekPristineHash
    )
import Darcs.Repository.Format
    ( RepoProperty ( HashedInventory, Darcs2 )
    , RepoFormat
    , formatHas
    , readProblem
    )
import Darcs.Repository.Prefs ( addRepoSource, deleteSources )
import Darcs.Repository.Match ( getOnePatchset )
import Darcs.Util.External
    ( copyFileOrUrl
    , Cachable(..)
    , gzFetchFilePS
    )
import Darcs.Repository.PatchIndex
    ( doesPatchIndexExist
    , createPIWithInterrupt
    )
import Darcs.Repository.Packs
    ( fetchAndUnpackBasic
    , fetchAndUnpackPatches
    , packsDir
    )
import Darcs.Util.Lock ( appendTextFile, withNewDirectory )
import Darcs.Repository.Flags
    ( UpdateWorking(..)
    , UseCache(..)
    , RemoteDarcs (..)
    , remoteDarcs
    , Compression (..)
    , CloneKind (..)
    , Verbosity (..)
    , DryRun (..)
    , UMask (..)
    , SetScriptsExecutable (..)
    , RemoteRepos (..)
    , SetDefault (..)
    , WithWorkingDir (..)
    , ForgetParent (..)
    , WithPatchIndex (..)
    , PatchFormat (..)
    )

import Darcs.Patch ( RepoPatch, IsRepoType, apply, invert, effect )
import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )
import Darcs.Patch.Set ( Origin
                       , PatchSet
                       , patchSet2RL
                       , patchSet2FL
                       , progressPatchSet
                       )
import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch )
import Darcs.Patch.Progress ( progressRLShowTags, progressFL )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Ordered
    ( (:>)(..)
    , lengthFL
    , mapFL_FL
    , RL(..)
    , bunchFL
    , mapFL
    , mapRL
    , lengthRL
    )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully )

import Darcs.Util.Tree( Tree, emptyTree )

import Darcs.Util.Download ( maxPipelineLength )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.English ( englishNum, Noun(..) )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.Util.SignalHandler ( catchInterrupt )
import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc )
import Darcs.Util.Progress
    ( debugMessage
    , tediousSize
    , beginTedious
    , endTedious
    )

joinUrl :: [String] -> String
joinUrl = intercalate "/"

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
    -> ForgetParent
    -> IO ()
cloneRepository repodir mysimplename v useCache cloneKind um rdarcs sse remoteRepos
                setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks
                forget =
  withUMaskFlag um $ withNewDirectory mysimplename $ do
      let patchfmt = if formatHas Darcs2 rfsource then PatchFormat2 else PatchFormat1
      EmptyRepository toRepo' <-
        createRepository patchfmt withWorkingDir
          (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex) useCache
      debugMessage "Finished initializing new repository."
      addRepoSource repodir NoDryRun remoteRepos setDefault

      debugMessage "Identifying and copying repository..."
      fromRepo <- identifyRepositoryFor toRepo' useCache repodir
      let fromLoc = repoLocation fromRepo
      let rffrom = repoFormat fromRepo
      case readProblem rffrom of
        Just e ->  fail $ "Incompatibility with repository " ++ fromLoc ++ ":\n" ++ e
        Nothing -> return ()
      debugMessage "Copying prefs..."
      copyFileOrUrl (remoteDarcs rdarcs)
        (joinUrl [fromLoc, darcsdir, "prefs", "prefs"])
        (darcsdir </> "prefs/prefs") (MaxAge 600) `catchall` return ()
      debugMessage "Copying sources..."
      cache <- unionRemoteCaches (repoCache toRepo') (repoCache fromRepo) fromLoc
      appendTextFile (darcsdir </> "prefs/sources")
                     (show $ repo2cache fromLoc `unionCaches` dropNonRepos cache)
      debugMessage "Done copying and filtering sources."
      -- put remote source last
      let toRepo = modifyCache toRepo' (const $ cache `unionCaches` repo2cache fromLoc)
      if formatHas HashedInventory rffrom then do
       -- copying basic repository (hashed_inventory and pristine)
       if usePacks && (not . isValidLocalPath) fromLoc
         then copyBasicRepoPacked    fromRepo toRepo v rdarcs withWorkingDir
         else copyBasicRepoNotPacked fromRepo toRepo v rdarcs withWorkingDir
       when (cloneKind /= LazyClone) $ do
         when (cloneKind /= CompleteClone) $
           putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."
       -- copying complete repository (inventories and patches)
         if usePacks && (not . isValidLocalPath) fromLoc
           then copyCompleteRepoPacked    fromRepo toRepo v cloneKind
           else copyCompleteRepoNotPacked fromRepo toRepo v cloneKind
      else
       -- old-fashioned repositories are cloned diferently since
       -- we need to copy all patches first and then build pristine
       copyRepoOldFashioned fromRepo toRepo v withWorkingDir
      when (sse == YesSetScriptsExecutable) setScriptsExecutable
      when (havePatchsetMatch (repoPatchType toRepo) matchFlags) $ do
        putInfo v $ text "Going to specified version..."
        -- the following is necessary to be able to read repo's patches
        revertRepositoryChanges toRepo YesUpdateWorking
        patches <- readRepo toRepo
        Sealed context <- getOnePatchset toRepo 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 toRepo
        _ <- tentativelyRemovePatches toRepo GzipCompression YesUpdateWorking us'
        tentativelyAddToPending toRepo YesUpdateWorking $ invert $ effect us'
        finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression
        runDefault (apply (invert $ effect ps)) `catch` \(e :: SomeException) ->
            fail ("Couldn't undo patch in working dir.\n" ++ show e)
        when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps)
      when (forget == YesForgetParent) deleteSources

-- | This keeps only NonWritable Repo entries.
dropNonRepos :: Cache -> Cache
dropNonRepos (Ca cache) = Ca $ filter notRepo cache where
  notRepo xs = case xs of
    Cache DarcsCache.Directory _ _ -> False
    -- we don't want to write thisrepo: entries to the disk
    Cache DarcsCache.Repo DarcsCache.Writable _ -> False
    _ -> True

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

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

copyBasicRepoNotPacked  :: forall rt p wR wU wT.
                           Repository rt p wR wU wT -- remote
                        -> Repository rt p wR wU wT -- existing empty local
                        -> Verbosity
                        -> RemoteDarcs
                        -> WithWorkingDir
                        -> IO ()
copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir = do
  putVerbose verb $ text "Copying hashed inventory from remote repo..."
  HashedRepo.copyHashedInventory toRepo rdarcs (repoLocation fromRepo)
  putVerbose verb $ text "Writing pristine and working directory contents..."
  createPristineDirectoryTree toRepo "." withWorkingDir

copyCompleteRepoNotPacked :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                        => Repository rt p wR wU wT -- remote
                        -> Repository rt p wR wU wT -- existing basic local
                        -> Verbosity
                        -> CloneKind
                        -> IO ()
copyCompleteRepoNotPacked _ toRepo verb cloneKind = do
       let cleanup = putInfo verb $ text "Using lazy repository."
       allowCtrlC cloneKind cleanup $ do
         fetchPatchesIfNecessary toRepo
         pi <- doesPatchIndexExist (repoLocation toRepo)
         ps <- readRepo toRepo
         when pi $ createPIWithInterrupt toRepo ps

copyBasicRepoPacked ::
  forall rt p wR wU wT.
     Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing empty local repository
  -> Verbosity
  -> RemoteDarcs
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked fromRepo toRepo verb rdarcs withWorkingDir =
  do let fromLoc = repoLocation fromRepo
     let hashURL = joinUrl [fromLoc, darcsdir, packsDir, "pristine"]
     mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)
     let hiURL = joinUrl [fromLoc, darcsdir, "hashed_inventory"]
     i <- gzFetchFilePS hiURL Uncachable
     let currentHash = BC.pack $ peekPristineHash i
     let copyNormally = copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir
     case mPackHash of
      Just packHash | packHash == currentHash
              -> ( copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir
                    `catch` \(e :: SomeException) ->
                               do putStrLn ("Exception while getting basic pack:\n" ++ show e)
                                  copyNormally)
      _       -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally."
                    copyNormally

copyBasicRepoPacked2 ::
  forall rt p wR wU wT.
     Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing empty local repository
  -> Verbosity
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir = do
  putVerbose verb $ text "Cloning packed basic repository."
  -- unpack inventory & pristine cache
  cleanDir $ darcsdir </> "pristine.hashed"
  removeFile $ darcsdir </> "hashed_inventory"
  fetchAndUnpackBasic (repoCache toRepo) (repoLocation fromRepo)
  putInfo verb $ text "Done fetching and unpacking basic pack."
  createPristineDirectoryTree toRepo "." withWorkingDir

copyCompleteRepoPacked ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing basic local repository
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked from to verb cloneKind =
    copyCompleteRepoPacked2 from to verb cloneKind
  `catch`
    \(e :: SomeException) -> do
      putStrLn ("Exception while getting patches pack:\n" ++ show e)
      putVerbose verb $ text "Problem while copying patches pack, copying normally."
      copyCompleteRepoNotPacked from to verb cloneKind

copyCompleteRepoPacked2 ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wT
  -> Repository rt p wR wU wT
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked2 fromRepo toRepo verb cloneKind = do
  us <- readRepo toRepo
  -- get old patches
  let cleanup = putInfo verb $ text "Using lazy repository."
  allowCtrlC cloneKind cleanup $ do
    putVerbose verb $ text "Using patches pack."
    fetchAndUnpackPatches (mapRL hashedPatchFileName $ patchSet2RL us)
      (repoCache toRepo) (repoLocation fromRepo)
    pi <- doesPatchIndexExist (repoLocation toRepo)
    when pi $ createPIWithInterrupt toRepo us -- TODO or do another readRepo?

cleanDir :: FilePath -> IO ()
cleanDir d = mapM_ (\x -> removeFile $ d </> x) .
  filter (\x -> head x /= '.') =<< getDirectoryContents d

copyRepoOldFashioned :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                        => Repository rt p wR wU wT  -- remote repo
                        -> Repository rt p wR wU wT  -- local empty repo
                        -> Verbosity
                        -> WithWorkingDir
                        -> IO ()
copyRepoOldFashioned fromrepository toRepo verb withWorkingDir = do
  HashedRepo.revertTentativeChanges
  patches <- readRepo fromrepository
  let k = "Copying patch"
  beginTedious k
  tediousSize k (lengthRL $ patchSet2RL patches)
  let patches' = progressPatchSet k patches
  HashedRepo.writeTentativeInventory (repoCache toRepo) GzipCompression patches'
  endTedious k
  HashedRepo.finalizeTentativeChanges toRepo GzipCompression
  -- apply all patches into current hashed repository
  HashedRepo.revertTentativeChanges
  local_patches <- readRepo toRepo
  replacePristine toRepo emptyTree
  let patchesToApply = progressFL "Applying patch" $ patchSet2FL local_patches
  sequence_ $ mapFL applyToTentativePristineCwd $ bunchFL 100 patchesToApply
  finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression
  putVerbose verb $ text "Writing pristine and working directory contents..."
  createPristineDirectoryTree toRepo "." withWorkingDir

-- | This function fetches all patches that the given repository has
--   with fetchFileUsingCache, unless --lazy is passed.
fetchPatchesIfNecessary :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p)
                        => Repository rt p wR wU wT
                        -> IO ()
fetchPatchesIfNecessary toRepo =
  do  ps <- readRepo toRepo
      pipelineLength <- maxPipelineLength
      let patches = patchSet2RL ps
          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 rt 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
        c = repoCache toRepo

{-
-- | 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.
-- bf: no it is not used anywhere
patchSetToRepository :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                     => Repository rt p wR1 wU1 wR1
                     -> PatchSet rt p Origin wX
                     -> UseCache -> RemoteDarcs
                     -> IO ()
patchSetToRepository fromRepo patchset useCache rDarcs = do
    when (formatHas HashedInventory (repoFormat fromRepo)) $
       -- set up sources and all that
       do writeFile (darcsdir </> "tentative_pristine") "" -- this is hokey
          repox <- writePatchSet patchset useCache
          let fromLoc = repoLocation fromRepo
          HashedRepo.copyHashedInventory repox rDarcs fromLoc
          void $ copySources repox fromLoc
    repo <- writePatchSet patchset useCache
    readRepo repo >>= (runDefault . applyPatches . patchSet2FL)
    debugMessage "Writing the pristine"
    withRepoLocation repo $ readWorking >>= replacePristine repo
-}

-- | writePatchSet is like patchSetToRepository, except that it doesn't
-- touch the working directory or pristine cache.
writePatchSet :: (IsRepoType rt, RepoPatch p)
              => PatchSet rt p Origin wX
              -> UseCache
              -> IO (Repository rt p wR wU wT)
writePatchSet patchset useCache = do
    maybeRepo <- maybeIdentifyRepository useCache "."
    let repo =
          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 (repoCache repo) GzipCompression patchset
    HashedRepo.finalizeTentativeChanges repo GzipCompression
    return repo

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

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

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