src/Darcs/Repository/Repair.lhs

   1 \begin{code}
   2 module Darcs.Repository.Repair ( replayRepository, cleanupRepositoryReplay,
   3                                  RepositoryConsistency(..), CanRepair(..) )
   4        where
   5
   6 import Control.Monad ( when, unless )
   7 import Data.Maybe ( catMaybes )
   8 import Data.List ( sort )
   9 import System.Directory ( createDirectoryIfMissing )
  10
  11 import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad )
  12 import Darcs.Lock( rm_recursive )
  13 import Darcs.Hopefully ( PatchInfoAnd, info )
  14
  15 import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,
  16                      mapRL )
  17 import Darcs.Patch.Depends ( get_patches_beyond_tag )
  18 import Darcs.Patch.Patchy ( applyAndTryToFix )
  19 import Darcs.Patch.Info ( human_friendly )
  20 import Darcs.Patch ( RepoPatch, patch2patchinfo )
  21
  22 import Darcs.Repository.Format ( identifyRepoFormat,
  23                                  RepoProperty ( HashedInventory ), format_has )
  24 import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) )
  25 import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine,
  26                                    clean_hashdir )
  27 import Darcs.Repository.HashedRepo ( readHashedPristineRoot )
  28 import Darcs.Repository.Checkpoint ( get_checkpoint_by_default )
  29 import Darcs.Repository.InternalTypes ( extractCache )
  30 import Darcs.Repository ( Repository, read_repo,
  31                           checkPristineAgainstSlurpy,
  32                           writePatchSet, makePatchLazy )
  33
  34 import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )
  35 import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )
  36 import Darcs.Utils ( catchall )
  37 import Darcs.Global ( darcsdir )
  38 import Darcs.Flags ( compression )
  39 import Printer ( Doc, putDocLn, text )
  40 import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )
  41
  42 run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a)
  43 run_slurpy s f =
  44     case withSlurpy s f of
  45       Left err -> fail err
  46       Right x -> return x
  47
  48 update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy
  49 update_slurpy r c opts s = do
  50   current <- readHashedPristineRoot r
  51   h <- writeHashedPristine c (compression opts) s
  52   s' <- slurpHashedPristine c (compression opts) h
  53   clean_hashdir c HashedPristineDir $ catMaybes [Just h, current]
  54   return s'
  55
  56 applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy)
  57 applyAndFix _ _ s _ NilFL = return (NilFL, s)
  58 applyAndFix c opts s_ r psin =
  59     do beginTedious k
  60        tediousSize k $ lengthFL psin
  61        ps <- aaf 0 s_ psin
  62        endTedious k
  63        return ps
  64     where k = "Repairing patch" -- FIXME
  65           aaf _ s NilFL = return (NilFL, s)
  66           aaf i s (p:>:ps) = do
  67             (s', mp') <- run_slurpy s $ applyAndTryToFix p
  68             finishedOneIO k $ show $ human_friendly $ info p
  69             p' <- case mp' of
  70                     Nothing -> return p
  71                     Just (e,pp) -> do putStrLn e
  72                                       return pp
  73             p'' <- makePatchLazy r p'
  74             let j = if ((i::Int) + 1 < 100) then i + 1 else 0
  75             (ps', s'') <- aaf j s' ps
  76             s''' <- if j == 0 then update_slurpy r c opts s''
  77                       else return s''
  78             return ((p'':>:ps'), s''')
  79
  80 data RepositoryConsistency = RepositoryConsistent | RepositoryInconsistent Slurpy
  81 data CanRepair = CanRepair | CannotRepair deriving Eq
  82
  83 check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO ()
  84 check_uniqueness putVerbose putInfo repository =
  85     do putVerbose $ text "Checking that patch names are unique..."
  86        r <- read_repo repository
  87        case has_duplicate $ mapRL info $ concatRL r of
  88          Nothing -> return ()
  89          Just pinf -> do putInfo $ text "Error! Duplicate patch name:"
  90                          putInfo $ human_friendly pinf
  91                          fail "Duplicate patches found."
  92
  93 has_duplicate :: Ord a => [a] -> Maybe a
  94 has_duplicate li = hd $ sort li
  95     where hd [_] = Nothing
  96           hd [] = Nothing
  97           hd (x1:x2:xs) | x1 == x2 = Just x1
  98                         | otherwise = hd (x2:xs)
  99 replayRepository :: (RepoPatch p) => CanRepair -> Repository p -> [DarcsFlag] -> IO RepositoryConsistency
 100 replayRepository canrepair repo opts = do
 101   let putVerbose s = when (Verbose `elem` opts) $ putDocLn s
 102       putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
 103   check_uniqueness putVerbose putInfo repo
 104   maybe_chk <- get_checkpoint_by_default repo
 105   let c = extractCache repo
 106   createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed"
 107   rooth <- writeHashedPristine c (compression opts) empty_slurpy
 108   s <- slurpHashedPristine c (compression opts) rooth
 109   putVerbose $ text "Applying patches..."
 110   s' <- case maybe_chk of
 111     Just (Sealed chk) ->
 112         do let chtg = patch2patchinfo chk
 113            putVerbose $ text "I am repairing from a checkpoint."
 114            patches <- read_repo repo
 115            (s'', _) <- run_slurpy s $ applyAndTryToFix chk
 116            (_, s_) <- applyAndFix c opts s'' repo
 117                       (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches)
 118            return s_
 119     Nothing -> do debugMessage "Fixing any broken patches..."
 120                   rawpatches <- read_repo repo
 121                   let psin = reverseRL $ concatRL rawpatches
 122                   (ps, s_) <- applyAndFix c opts s repo psin
 123                   when (canrepair == CanRepair) $ do
 124                        writePatchSet (reverseFL ps :<: NilRL) opts
 125                        return ()
 126                   debugMessage "Done fixing broken patches..."
 127                   return s_
 128   debugMessage "Checking pristine agains slurpy"
 129   is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False
 130   if is_same
 131      then return RepositoryConsistent
 132      else return $ RepositoryInconsistent s'
 133
 134 cleanupRepositoryReplay :: Repository p -> IO ()
 135 cleanupRepositoryReplay r = do
 136   let c = extractCache r
 137   rf_or_e <- identifyRepoFormat "."
 138   rf <- case rf_or_e of Left e -> fail e
 139                         Right x -> return x
 140   unless (format_has HashedInventory rf) $
 141          rm_recursive $ darcsdir ++ "/pristine.hashed"
 142   when (format_has HashedInventory rf) $ do
 143        current <- readHashedPristineRoot r
 144        clean_hashdir c HashedPristineDir $ catMaybes [current]
 145 \end{code}