{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Darcs.Repository.Clone
    ( createRepository
    , cloneRepository
    , replacePristine
    , writePatchSet
    , patchSetToRepository
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Exception ( catch, SomeException )
import Control.Monad ( when, void )
import qualified Data.ByteString.Char8 as BS
import Data.Maybe( catMaybes, isJust )
import System.FilePath( (</>) )
import System.Directory
    ( createDirectory
    , removeFile
    , getDirectoryContents
    , getCurrentDirectory
    , setCurrentDirectory
    )
import System.IO ( stderr )
import System.IO.Error ( isAlreadyExistsError )

import Darcs.Repository.State ( invalidateIndex, readWorking )

import Darcs.Repository.Internal
    ( Repository(..)
    , IdentifyRepo(..)
    , identifyRepositoryFor
    , identifyRepository
    , maybeIdentifyRepository
    , readRepo
    , tentativelyRemovePatches
    , tentativelyAddToPending
    , finalizeRepositoryChanges
    , createPristineDirectoryTree
    , setScriptsExecutable
    , setScriptsExecutablePatches
    , seekRepo
    , repoPatchType
    , revertRepositoryChanges
    )
import Darcs.Repository.InternalTypes
    ( modifyCache )
import Darcs.Repository.Job ( RepoJob(..), withRepoLock, withRepository )
import Darcs.Repository.Cache
    ( unionRemoteCaches
    , unionCaches
    , fetchFileUsingCache
    , speculateFileUsingCache
    , HashedDir(..)
    , Cache(..)
    , CacheLoc(..)
    , repo2cache
    )
import qualified Darcs.Repository.Cache as DarcsCache

import qualified Darcs.Repository.HashedRepo as HashedRepo
import Darcs.Repository.ApplyPatches ( applyPatches, runDefault )
import Darcs.Repository.HashedRepo
    ( applyToTentativePristine
    , pris2inv
    , inv2pris
    )
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.Util.External
    ( copyFileOrUrl
    , Cachable(..)
    , gzFetchFilePS
    )
import Darcs.Repository.PatchIndex
    ( createOrUpdatePatchIndexDisk
    , doesPatchIndexExist
    , createPIWithInterrupt
    )
import Darcs.Repository.Packs
    ( fetchAndUnpackBasic
    , fetchAndUnpackPatches
    , packsDir
    )
import Darcs.Util.Lock
    ( writeBinFile
    , writeDocBinFile
    , appendBinFile
    )
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, PrimOf )
import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )
import Darcs.Patch.Set ( Origin
                       , PatchSet(..)
                       , newset2RL
                       , newset2FL
                       , 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.Hash( encodeBase16 )
import Darcs.Util.Tree( Tree, emptyTree )
import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes )

import Darcs.Util.ByteString( gzReadFilePS )
import Darcs.Util.Download ( maxPipelineLength )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.File ( withCurrentDirectory )
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, RenderMode(..) )
import Darcs.Util.Progress
    ( debugMessage
    , tediousSize
    , beginTedious
    , endTedious
    )

#include "impossible.h"

createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> IO ()
createRepository patchfmt 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
  writeRepoFormat (createRepoFormat patchfmt withWorkingDir) (darcsdir </> "format")
  writeBinFile (darcsdir </> "hashed_inventory") ""
  writePristine "." emptyTree
  withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of
      NoPatchIndex -> return () -- default
      YesPatchIndex -> createOrUpdatePatchIndexDisk repo

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 uc cloneKind um rdarcs sse remoteRepos
                setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks forget = do
  createDirectory mysimplename
  setCurrentDirectory mysimplename
  createRepository (if formatHas Darcs2 rfsource then PatchFormat2 else PatchFormat1)
                   withWorkingDir
                   (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)
  debugMessage "Finished initializing new repository."
  addRepoSource repodir NoDryRun remoteRepos setDefault

  debugMessage "Grabbing lock in new repository."
  withRepoLock NoDryRun uc YesUpdateWorking um
   $ RepoJob $ \repository -> do
      debugMessage "Identifying and copying repository..."
      fromRepo@(Repo fromDir rffrom _ fromCache) <- identifyRepositoryFor repository uc repodir
      case readProblem rffrom of
        Just e ->  fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e
        Nothing -> return ()
      debugMessage "Copying prefs"
      copyFileOrUrl (remoteDarcs rdarcs) (fromDir </> darcsdir </> "prefs" </> "prefs")
        (darcsdir </> "prefs/prefs") (MaxAge 600) `catchall` return ()
      -- prepare sources and cache
      (Repo toDir toFormat toPristine toCache) <- identifyRepository uc "."
      toCache2 <- unionRemoteCaches toCache fromCache fromDir
      toRepo <- copySources (Repo toDir toFormat toPristine toCache2) fromDir
      if formatHas HashedInventory rffrom then do
       -- copying basic repository (hashed_inventory and pristine)
       if usePacks && (not . isValidLocalPath) fromDir
         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) fromDir
           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 repository) matchFlags) $ do
        putStrLn "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

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 rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                        => Repository rt p wR wU wT -- remote
                        -> Repository rt p wR wU wT -- existing empty local
                        -> Verbosity
                        -> RemoteDarcs
                        -> WithWorkingDir
                        -> IO ()
copyBasicRepoNotPacked (Repo fromDir _ _ _) toRepo verb rdarcs withWorkingDir = do
  putVerbose verb $ text "Copying hashed inventory from remote repo..."
  HashedRepo.copyHashedInventory toRepo rdarcs fromDir
  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 _ torepository@(Repo todir _ _ _) verb cloneKind = do
       let cleanup = putInfo verb $ text "Using lazy repository."
       allowCtrlC cloneKind cleanup $ do
         fetchPatchesIfNecessary torepository
         pi <- doesPatchIndexExist todir
         when pi $ createPIWithInterrupt torepository

copyBasicRepoPacked ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing empty local repository
  -> Verbosity
  -> RemoteDarcs
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked r@(Repo fromDir _ _ _) toRepo verb rdarcs withWorkingDir =
  do let hashURL = fromDir </> darcsdir </> 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 toRepo verb rdarcs withWorkingDir
     case mPackHash of
      Just packHash | packHash == currentHash
              -> ( copyBasicRepoPacked2 r 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. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing empty local repository
  -> Verbosity
  -> WithWorkingDir
  -> IO ()
copyBasicRepoPacked2 (Repo fromDir _ _ _) toRepo@(Repo _ _ _ toCache) verb withWorkingDir = do
  putVerbose verb $ text "Cloning packed basic repository."
  -- unpack inventory & pristine cache
  cleanDir $ darcsdir </> "pristine.hashed"
  removeFile $ darcsdir </> "hashed_inventory"
  fetchAndUnpackBasic toCache fromDir
  putInfo verb $ text "Done fetching and unpacking basic pack."
  createPristineDirectoryTree toRepo "." withWorkingDir

copyCompleteRepoPacked ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository rt p wR wU wT -- remote
  -> Repository rt p wR wU wT -- existing basic local repository
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked r to verb cloneKind =
  ( copyCompleteRepoPacked2 r 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 r to verb cloneKind )

copyCompleteRepoPacked2 ::
  forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)
  => Repository rt p wR wU wT
  -> Repository rt p wR wU wT
  -> Verbosity
  -> CloneKind
  -> IO ()
copyCompleteRepoPacked2 (Repo fromDir _ _ _)
                        toRepo@(Repo toDir _ _ toCache)
                        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 $ newset2RL us) toCache fromDir
    pi <- doesPatchIndexExist toDir
    when pi $ createPIWithInterrupt toRepo

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@(Repo _ _ _ toCache) verb withWorkingDir = do
  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
  HashedRepo.revertTentativeChanges
  local_patches <- readRepo toRepo
  replacePristine toRepo emptyTree
  let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches
  sequence_ $ mapFL applyToTentativePristine $ 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, ApplyState p ~ Tree)
                        => Repository rt 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 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

-- | 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 :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                     => Repository rt p wR1 wU1 wR1
                     -> PatchSet rt p Origin wX
                     -> UseCache -> RemoteDarcs
                     -> IO ()
patchSetToRepository (Repo fromrepo rf _ _) patchset useCache rDarcs = 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 rDarcs fromrepo
          void $ copySources repox fromrepo
    repo@(Repo dir _ _ _) <- writePatchSet patchset useCache
    readRepo repo >>= (runDefault . applyPatches . newset2FL)
    debugMessage "Writing the pristine"
    withCurrentDirectory dir $ readWorking >>= replacePristine repo

-- | writePatchSet is like patchSetToRepository, except that it doesn't
-- touch the working directory or pristine cache.
writePatchSet :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
              => PatchSet rt p Origin wX
              -> UseCache
              -> IO (Repository rt 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

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

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

-- |'copySources' does two things:
-- * it copies the prefs/sources file to the local repo, from the
--   remote, having first filtered the local filesystem sources.
-- * it returns the original list of sources of the local repo
--   updated with the remote repo as an additional source
copySources :: RepoPatch p
            => Repository rt p wR wU wT
            -> String
            -> IO (Repository rt p wR wU wT)
copySources repo@(Repo outr _ _ cache0) inr = do
    let (Repo s f p newCache1) = modifyCache repo dropNonRepos
    let sourcesToWrite = repo2cache inr `unionCaches` newCache1
    appendBinFile (outr ++ "/" ++ darcsdir ++ "/prefs/sources")
                  (show sourcesToWrite)
    debugMessage "Done copying and filtering pref/sources."

    -- put remote source last:
    let newSources = cache0 `unionCaches` repo2cache inr
    return (Repo s f p newSources)
  where
    dropNonRepos (Ca cache) = Ca $ filter notRepo cache
    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