Repository.lhs

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

\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
#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,
                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
                    read_repo, sync_repo,
                    prefsUrl,
                    read_pending, add_to_pending,
                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
                    tentativelyReplacePatches,
                    tentativelyMergePatches, considerMergeToWorking,
                    revertRepositoryChanges, finalizeRepositoryChanges,
                    copyRepository, copy_oldrepo_patches,
                    patchSetToRepository,
                    unrevertUrl,
                    applyToWorking, patchSetToPatches,
                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,
                    optimizeInventory, cleanRepository, checkPristineAgainstCwd,
                    getMarkedupFile,
                    PatchSet, SealedPatchSet, PatchInfoAnd,
                    setScriptsExecutable
                  ) where

import Darcs.Repository.Internal
    (Repository(..), RepoType(..), ($-), pristineFromWorking,
     maybeIdentifyRepository, identifyRepositoryFor,
     findRepository, amInRepository, amNotInRepository,
     makePatchLazy,
     slurp_pending, replacePristine,
     slurp_recorded, slurp_recorded_and_unrecorded,
     withRecorded,
     get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
     read_repo, sync_repo,
     prefsUrl, checkPristineAgainstCwd,
     read_pending, add_to_pending,
     withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,
     tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
     tentativelyReplacePatches,
     tentativelyMergePatches, considerMergeToWorking,
     revertRepositoryChanges, finalizeRepositoryChanges,
     unrevertUrl,
     applyToWorking, patchSetToPatches,
     createPristineDirectoryTree, createPartialsPristineDirectoryTree,
     optimizeInventory, cleanRepository,
     getMarkedupFile,
     setScriptsExecutable
    )
import Darcs.Repository.Prefs ( unionCaches, fetchFileUsingCache )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )

import Control.Monad ( unless, when )
import Data.Either(Either(..))

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 )
import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply )
import Darcs.Patch.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL,
                             concatRL, lengthRL )
import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),
                                 format_has )
import Darcs.Patch.Depends ( get_patches_beyond_tag )
import Darcs.Utils ( withCurrentDirectory, catchall )
import Darcs.External ( copyFileOrUrl, Cachable(..) )
import Darcs.Progress ( debugMessage, progressFL, progressRL, tediousSize,
                        beginTedious, endTedious, progress )
import Darcs.Lock ( withTempDir )
import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal, unsealM )

import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral ) )
import Darcs.Global ( darcsdir )
#include "impossible.h"

\end{code}

\begin{code}
copyRepository :: RepoPatch p => Repository p -> IO ()
copyRepository fromrepository@(Repo _ opts rf _)
    | Partial `elem` opts && not (format_has 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 . RepoPatch p => Repository p -> IO ()
copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do
  repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "."
  let newrepo :: Repository p
      newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote))
      copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir
      copyAnythingToOld r = withCurrentDirectory todir $ read_repo r `unsealM` 
                            DarcsRepo.write_inventory_and_patches opts
      repoSort rfx | format_has HashedInventory rfx = Hashed
                   | otherwise = Old
  case repoSort rf2 of
    Hashed ->
        if format_has HashedInventory rf
        then copyHashedHashed
        else withCurrentDirectory todir $
             do HashedRepo.revert_tentative_changes
                Sealed 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 opts patches'
                endTedious k
                HashedRepo.finalize_tentative_changes repo opts
    Old -> case repoSort rf of
           Hashed -> copyAnythingToOld fromrepo
           _ -> copy_oldrepo_patches opts fromrepo todir

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

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

copyFullRepository :: RepoPatch p => Repository p -> 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 format_has HashedInventory rffrom && format_has 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 format_has HashedInventory rfto
           then do Sealed local_patches <- read_repo torepository
                   withTempDir "newpristine" $ \newpris -> replacePristine torepository newpris
                   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 `unsealM` (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 -> [DarcsFlag] -> IO (Repository p)
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 format_has HashedInventory rf2
       then do HashedRepo.write_tentative_inventory c opts patchset
               HashedRepo.finalize_tentative_changes repo 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 => PatchSet p -> [DarcsFlag] -> IO (Repository p)
patchSetToRepository patchset opts = do
    repo <- writePatchSet patchset opts
    read_repo repo `unsealM` (apply_patches opts . reverseRL . concatRL)
    debugMessage "Writing the pristine"
    pristineFromWorking repo
    return repo

-- | 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 -> IO ()
fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) = 
    unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $
             do putInfo "Copying patches, to get lazy repository hit ctrl-C..."
                Sealed r <- read_repo torepository
                let peekaboo :: PatchInfoAnd p C(x y) -> IO ()
                    peekaboo x = case extractHash x of
                                 Left _ -> return ()
                                 Right h -> fetchFileUsingCache c "patches" h >> return ()
                sequence_ $ mapRL peekaboo $ progressRL "Copying patches" $ concatRL r
  where putInfo = when (not $ Quiet `elem` opts) . putStrLn

\end{code}