-- Copyright (C) 2002-2004 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

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

#include "gadts.h"

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

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

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

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

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

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

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

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

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

import System.FilePath( (</>) )

import qualified Data.ByteString.Char8 as BS

#include "impossible.h"

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

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

data PorNP = NotPartial | IsPartial
             deriving ( Eq )

data RepoSort = Hashed | Old

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

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

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

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

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

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

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

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

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

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

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