Repository.hs

-- 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, replacePristineFromSlurpy,
                    slurp_recorded, slurp_recorded_and_unrecorded,
                    withRecorded,
                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
                    get_unrecorded_in_files,
                    read_repo, sync_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,
                    checkPristineAgainstSlurpy, getMarkedupFile,
                    PatchSet, SealedPatchSet, PatchInfoAnd,
                    setScriptsExecutable,
                    checkUnrelatedRepos,
                    testTentative, testRecorded
                  ) where

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

import Darcs.Repository.Internal
    (Repository(..), RepoType(..), ($-), pristineFromWorking,
     maybeIdentifyRepository, identifyRepositoryFor,
     findRepository, amInRepository, amNotInRepository,
     makePatchLazy,
     slurp_pending, replacePristine, replacePristineFromSlurpy,
     slurp_recorded, slurp_recorded_and_unrecorded,
     withRecorded,
     get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
     get_unrecorded_in_files,
     read_repo, sync_repo,
     prefsUrl, checkPristineAgainstSlurpy,
     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,
     testTentative, testRecorded
    )
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 )
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 )
import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply )
import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL,
                       concatRL, lengthRL, isShorterThanRL )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),
                                 create_repo_format, format_has, writeRepoFormat )
import Darcs.Repository.Prefs ( write_default_prefs )
import Darcs.Repository.Pristine ( createPristine, flagsToPristine )
import Darcs.Patch.Depends ( get_patches_beyond_tag )
import Darcs.SlurpDirectory ( empty_slurpy )
import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn )
import Darcs.External ( copyFileOrUrl, Cachable(..) )
import Progress ( debugMessage, tediousSize,
                        beginTedious, endTedious, progress )
import Darcs.ProgressPatches (progressRLShowTags, progressFL)
import Darcs.Lock ( writeBinFile )
import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )

import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral,
                                AllowUnrelatedRepos
                              ),
                     compression )
import Darcs.Global ( darcsdir )
#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 = create_repo_format opts
  createPristine $ flagsToPristine opts rf
  createDirectory $ darcsdir ++ "/patches"
  createDirectory $ darcsdir ++ "/prefs"
  write_default_prefs
  writeRepoFormat rf (darcsdir++"/format")
  if format_has 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 (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 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 | 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
                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 $ concatRL ps
           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 :: 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 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 local_patches <- read_repo torepository
                   replacePristineFromSlurpy torepository empty_slurpy
                   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 format_has 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 (format_has 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(x) -> 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 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