-- 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, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..), ($-), maybeIdentifyRepository, identifyRepositoryFor
    , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory
    , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository
    , amNotInRepository, replacePristine
    , withRecorded, readRepo, prefsUrl
    , addToPending, tentativelyAddPatch, tentativelyRemovePatches
    , tentativelyAddToPending, tentativelyReplacePatches, readTentativeRepo
    , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges
    , finalizeRepositoryChanges, createRepository, copyRepository
    , copyOldrepoPatches, patchSetToRepository, unrevertUrl, applyToWorking
    , patchSetToPatches, createPristineDirectoryTree
    , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository
    , getMarkedupFile, PatchSet, SealedPatchSet, PatchInfoAnd
    , setScriptsExecutable, checkUnrelatedRepos, testTentative, testRecorded
    , extractOptions, modifyCache
    -- * Recorded and unrecorded and pending.
    , readRecorded, readUnrecorded, unrecordedChanges, readPending
    , readRecordedAndPending
    -- * Index.
    , readIndex, invalidateIndex
    ) where

import System.Exit ( ExitCode(..), exitWith )
import Data.List ( isSuffixOf )
import Data.Maybe( catMaybes )

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

import Darcs.Repository.Internal
    (Repository(..), RepoType(..), ($-),
     maybeIdentifyRepository, identifyRepositoryFor, IdentifyRepo(..),
     findRepository, amInRepository, amNotInRepository,
     makePatchLazy,
     withRecorded,
     readRepo, readTentativeRepo,
     prefsUrl,
     withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
     tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
     tentativelyReplacePatches,
     revertRepositoryChanges, finalizeRepositoryChanges,
     unrevertUrl,
     applyToWorking, patchSetToPatches,
     createPristineDirectoryTree, createPartialsPristineDirectoryTree,
     optimizeInventory, cleanRepository,
     getMarkedupFile,
     setScriptsExecutable,
     testTentative, testRecorded,
     makeNewPending
    )
import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking )
import Darcs.Repository.Cache ( unionRemoteCaches, fetchFileUsingCache,
                                speculateFileUsingCache, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..))
import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2RL, newset2FL, progressPatchSet )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import URL ( maxPipelineLength )

import Control.Applicative ( (<$>) )
import Control.Monad ( unless, when )
import System.Directory ( createDirectory, renameDirectory,
                          createDirectoryIfMissing, renameFile )
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 ( identifyCheckpoint, writeCheckpointPatch, getCheckpoint )
import Darcs.Repository.ApplyPatches ( applyPatches )
import Darcs.Repository.HashedRepo ( applyToTentativePristine, pris2inv, revertTentativeChanges,
                                     copySources )
import Darcs.Repository.InternalTypes ( Pristine(..), extractOptions, modifyCache )
import Darcs.Patch ( RepoPatch, Named, Prim, Patch, patch2patchinfo, apply )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL
                               , reverseRL ,lengthRL, (+>+), (:\/:)(..) )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), RepoFormat,
                                 createRepoFormat, formatHas, writeRepoFormat )
import Darcs.Repository.Prefs ( writeDefaultPrefs )
import Darcs.Repository.Pristine ( createPristine, flagsToPristine, createPristineFromWorking )
import Darcs.Patch.Depends ( getPatchesBeyondTag, areUnrelatedRepos, findUncommon )

import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError )
import Darcs.External ( copyFileOrUrl, Cachable(..), fetchFileLazyPS )
import Progress ( debugMessage, tediousSize, beginTedious, endTedious )
import Darcs.ProgressPatches (progressRLShowTags, progressFL)
import Darcs.Lock ( writeBinFile, writeDocBinFile, rmRecursive, withTemp )
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 Darcs.URL ( isFile )

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 Codec.Archive.Tar as Tar
import Codec.Compression.GZip ( compress, decompress )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL

#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.writeInventory "." (PatchSet NilRL NilRL :: PatchSet Patch C(Origin Origin)) -- 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

repoSort :: RepoFormat -> RepoSort
repoSort f
  | formatHas HashedInventory f = Hashed
  | otherwise = Old

copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
copyInventory fromRepo@(Repo fromDir opts fromFormat (DarcsRepository _ fromCache)) = do
  toRepo@(Repo toDir opts' toFormat (DarcsRepository toPristine toCache)) <-
    identifyRepositoryFor fromRepo "."
  toCache2 <- unionRemoteCaches toCache fromCache fromDir
  let toRepo2 :: Repository p C(r u t)
      toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2
      copyHashedHashed = HashedRepo.copyRepo toRepo2 opts fromDir
      copyAnyToOld r = withCurrentDirectory toDir $ readRepo r >>=
                            DarcsRepo.writeInventoryAndPatches opts
  case repoSort fromFormat of
    Hashed -> case repoSort toFormat of
      Hashed -> copyHashedHashed
      Old -> copyAnyToOld fromRepo
    Old -> case repoSort toFormat of
      Hashed -> withCurrentDirectory toDir $ do
                HashedRepo.revertTentativeChanges
                patches <- readRepo fromRepo
                let k = "Copying patch"
                beginTedious k
                tediousSize k (lengthRL $ newset2RL patches)
                let patches' = progressPatchSet k patches
                HashedRepo.writeTentativeInventory toCache (compression opts) patches'
                endTedious k
                HashedRepo.finalizeTentativeChanges toRepo $ compression opts
      Old -> copyOldrepoPatches opts fromRepo toDir

copyOldrepoPatches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO ()
copyOldrepoPatches opts repository@(Repo dir _ _ _) out = do
  Sealed patches <- DarcsRepo.readRepo opts "." :: IO (SealedPatchSet Patch C(Origin))
  mpi <- if Partial `elem` opts
         -- FIXME this should get last pinfo *before*
         -- desired tag...
         then identifyCheckpoint repository
         else return Nothing
  FlippedSeal scp <- return $ since_checkpoint mpi $ newset2RL patches
  DarcsRepo.copyPatches 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 <- getCheckpoint 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
           writeCheckpointPatch ch
           local_patches <- readRepo torepository
           let pi_ch = patch2patchinfo ch
           FlippedSeal ps <- return $ getPatchesBeyondTag pi_ch local_patches
           let needed_patches = reverseRL ps
           apply opts ch `catch`
                             \e -> fail ("Bad checkpoint!\n" ++ prettyError e)
           applyPatches 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 fromRepo@(Repo fromDir opts _ _) = do
  debugMessage "Copying prefs"
  copyFileOrUrl opts (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")
    (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()
  if True -- isFile fromDir -- packs disabled for darcs 2.5
    then copyNotPackedRepository fromRepo
    else do
      b <- (Just <$> fetchFileLazyPS (fromDir ++ "/" ++ darcsdir ++
        "/packs/basic.tar.gz") Uncachable) `catchall` return Nothing
      case b of
        Nothing -> copyNotPackedRepository fromRepo
        Just b' -> copyPackedRepository fromRepo b'

copyNotPackedRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()
copyNotPackedRepository fromrepository@(Repo _ opts rffrom _) = do
  copyInventory fromrepository
  debugMessage "Grabbing lock in new repository..."
  withRepoLock opts $- \torepository@(Repo _ _ rfto _) ->
      if formatHas HashedInventory rffrom && formatHas HashedInventory rfto
      then do debugMessage "Writing working directory contents..."
              createPristineDirectoryTree torepository "."
              fetchPatchesIfNecessary 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 <- readRepo torepository
                   replacePristine torepository emptyTree
                   let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches
                   sequence_ $ mapFL (applyToTentativePristine opts) $ bunchFL 100 patchesToApply
                   finalizeRepositoryChanges torepository
                   debugMessage "Writing working directory contents..."
                   createPristineDirectoryTree torepository "."
           else do readRepo torepository >>= (applyPatches opts . newset2FL)
                   debugMessage "Writing the pristine"
                   pristineFromWorking torepository

copyPackedRepository :: forall p C(r u t). RepoPatch p =>
  Repository p C(r u t) -> BL.ByteString -> IO ()
copyPackedRepository fromRepo@(Repo fromDir opts _ (DarcsRepository _ fromCache)) b = do
  Repo toDir _ toFormat (DarcsRepository toPristine toCache) <-
    identifyRepositoryFor fromRepo "."
  toCache2 <- unionRemoteCaches toCache fromCache fromDir
  let toRepo :: Repository p C(r u r) -- In empty repo, t(entative) = r(ecorded)
      toRepo = Repo toDir opts toFormat $ DarcsRepository toPristine toCache2
      fromPacksDir = fromDir ++ "/" ++ darcsdir ++ "/packs/"
  createDirectoryIfMissing False $ toDir </> darcsdir </> "inventories"
  createDirectoryIfMissing False $ toDir </> darcsdir </> "pristine.hashed"
  createDirectoryIfMissing False $ toDir </> darcsdir </> "patches"
  copySources toRepo fromDir
  -- unpack inventory & pristine cache
  writeCompressed . Tar.read $ decompress b
  createPristineDirectoryTree toRepo "."
  -- pull new patches
  us <- readRepo toRepo
  them <- readRepo fromRepo
  us' :\/: them' <- return $ findUncommon us them
  revertTentativeChanges
  Sealed pw <- tentativelyMergePatches toRepo "get" opts us' them'
  invalidateIndex toRepo
  withGutsOf toRepo $ do
    finalizeRepositoryChanges toRepo
    applyToWorking toRepo opts pw
    return ()
  -- get old patches
  unless (any (`elem` opts) [Partial, Lazy, Ephemeral]) $ do
    putInfo "Copying patches, to get lazy repository hit ctrl-C..."
    writeCompressed . Tar.read . decompress =<< fetchFileLazyPS (fromPacksDir ++
      "patches.tar.gz") Uncachable
 where
  writeCompressed Tar.Done = return ()
  writeCompressed (Tar.Next x xs) = case Tar.entryContent x of
    Tar.NormalFile x' _ -> do
      let p = Tar.entryPath x
      withTemp $ \p' -> do
        BL.writeFile p' $ if "hashed_inventory" `isSuffixOf` p
          then x'
          else compress x'
        renameFile p' p
      writeCompressed xs
    _ -> fail "Unexpected non-file tar entry"
  writeCompressed (Tar.Fail e) = fail e
  putInfo = when (not $ Quiet `elem` opts) . putStrLn

-- | writePatchSet is like patchSetToRepository, except that it doesn't
-- touch the working directory or pristine cache.
writePatchSet :: RepoPatch p => PatchSet p C(Origin 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
            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"
    if formatHas HashedInventory rf2
       then do HashedRepo.writeTentativeInventory c (compression opts) patchset
               HashedRepo.finalizeTentativeChanges repo (compression opts)
       else DarcsRepo.writeInventoryAndPatches 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(Origin 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.copyRepo repox opts fromrepo
    repo <- writePatchSet patchset opts
    readRepo repo >>= (applyPatches opts . newset2FL)
    debugMessage "Writing the pristine"
    pristineFromWorking repo
    return repo

checkUnrelatedRepos :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> PatchSet p C(start y)
                    -> IO ()
checkUnrelatedRepos opts _ _ | AllowUnrelatedRepos `elem` opts = return ()
checkUnrelatedRepos _ us them =
    if areUnrelatedRepos us them
    then do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?")
            when (yorn /= 'y') $ do putStrLn "Cancelled."
                                    exitWith ExitSuccess
    else return ()

-- | 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.
fetchPatchesIfNecessary :: forall p C(r u t). RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO ()
fetchPatchesIfNecessary 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 <- 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 putInfo = when (not $ Quiet `elem` opts) . putStrLn
        hashes :: FORALL(x y) RL (PatchInfoAnd p) C(x y) -> [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

addToPending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
addToPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
addToPending repo@(Repo _ opts _ _) p =
    do pend <- unrecordedChanges opts repo []
       invalidateIndex repo
       makeNewPending 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 rmRecursive 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