1 {-# OPTIONS_GHC -cpp #-}
    2 {-# LANGUAGE CPP #-}
    3 
    4 module Darcs.Repository.Repair ( replayRepository,
    5                                  RepositoryConsistency(..) )
    6        where
    7        
    8 import Control.Monad ( when, unless )
    9 import Control.Exception ( finally )
   10 import Data.Maybe ( catMaybes )
   11 import Data.List ( sort )
   12 import System.Directory ( createDirectoryIfMissing )
   13 
   14 import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad, syncSlurpy )
   15 import Darcs.Lock( rm_recursive )
   16 import Darcs.Hopefully ( PatchInfoAnd, info )
   17 
   18 import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,
   19                      mapRL )
   20 import Darcs.Patch.Depends ( get_patches_beyond_tag )
   21 import Darcs.Patch.Patchy ( applyAndTryToFix )
   22 import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly )
   23 import Darcs.Patch.Set ( PatchSet )
   24 import Darcs.Patch ( RepoPatch, patch2patchinfo )
   25 
   26 import Darcs.Repository.Format ( identifyRepoFormat, 
   27                                  RepoProperty ( HashedInventory ), format_has )
   28 import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) )
   29 import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine,
   30                                    clean_hashdir )
   31 import Darcs.Repository.HashedRepo ( readHashedPristineRoot )
   32 import Darcs.Repository.Checkpoint ( get_checkpoint_by_default )
   33 import Darcs.Repository.InternalTypes ( extractCache )
   34 import Darcs.Repository ( Repository, read_repo,
   35                           checkPristineAgainstSlurpy,
   36                           makePatchLazy )
   37 
   38 import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )
   39 import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )
   40 import Darcs.Utils ( catchall )
   41 import Darcs.Global ( darcsdir )
   42 import Darcs.Flags ( compression )
   43 import Printer ( Doc, putDocLn, text )
   44 import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )
   45 #include "impossible.h"
   46 
   47 run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a)
   48 run_slurpy s f =
   49     case withSlurpy s f of
   50       Left err -> fail err
   51       Right x -> return x
   52 
   53 update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy
   54 update_slurpy r c opts s = do
   55   current <- readHashedPristineRoot r
   56   h <- writeHashedPristine c (compression opts) s
   57   s' <- slurpHashedPristine c (compression opts) h
   58   clean_hashdir c HashedPristineDir $ catMaybes [Just h, current]
   59   return s'
   60 
   61 replaceInFL :: FL (PatchInfoAnd a)
   62             -> [(PatchInfo, PatchInfoAnd a)]
   63             -> FL (PatchInfoAnd a)
   64 replaceInFL orig [] = orig
   65 replaceInFL NilFL _ = impossible                                                                                                          
   66 replaceInFL (o:>:orig) ch@((o',c):ch_rest)
   67     | info o == o' = c:>:replaceInFL orig ch_rest
   68     | otherwise = o:>:replaceInFL orig ch
   69 
   70 applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy, Bool)
   71 applyAndFix _ _ s _ NilFL = return (NilFL, s, True)
   72 applyAndFix c opts s_ r psin =
   73     do beginTedious k
   74        tediousSize k $ lengthFL psin
   75        (repaired, slurpy, ok) <- aaf s_ psin
   76        endTedious k
   77        orig <- (reverseRL . concatRL) `fmap` read_repo r
   78        return (replaceInFL orig repaired, slurpy, ok)
   79     where k = "Replaying patch"
   80           aaf s NilFL = return ([], s, True)
   81           aaf s (p:>:ps) = do
   82             (s', mp') <- run_slurpy s $ applyAndTryToFix p
   83             let !infp = info p -- assure that 'p' can be garbage collected.
   84             finishedOneIO k $ show $ human_friendly $ infp
   85             s'' <- syncSlurpy (update_slurpy r c opts) s'
   86             (ps', s''', restok) <- aaf s'' ps
   87             case mp' of
   88               Nothing -> return (ps', s''', restok)
   89               Just (e,pp) -> do putStrLn e
   90                                 p' <- makePatchLazy r pp
   91                                 return ((infp, p'):ps', s''', False)
   92 
   93 data RepositoryConsistency p =
   94     RepositoryConsistent
   95   | BrokenPristine Slurpy
   96   | BrokenPatches Slurpy (PatchSet p)
   97 
   98 check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO ()
   99 check_uniqueness putVerbose putInfo repository =
  100     do putVerbose $ text "Checking that patch names are unique..."
  101        r <- read_repo repository
  102        case has_duplicate $ mapRL info $ concatRL r of
  103          Nothing -> return ()
  104          Just pinf -> do putInfo $ text "Error! Duplicate patch name:"
  105                          putInfo $ human_friendly pinf
  106                          fail "Duplicate patches found."
  107 
  108 has_duplicate :: Ord a => [a] -> Maybe a
  109 has_duplicate li = hd $ sort li
  110     where hd [_] = Nothing
  111           hd [] = Nothing
  112           hd (x1:x2:xs) | x1 == x2 = Just x1
  113                         | otherwise = hd (x2:xs)
  114 replayRepository' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO (RepositoryConsistency p)
  115 replayRepository' repo opts = do
  116   let putVerbose s = when (Verbose `elem` opts) $ putDocLn s
  117       putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
  118   check_uniqueness putVerbose putInfo repo
  119   maybe_chk <- get_checkpoint_by_default repo
  120   let c = extractCache repo
  121   createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed"
  122   rooth <- writeHashedPristine c (compression opts) empty_slurpy
  123   s <- slurpHashedPristine c (compression opts) rooth
  124   putVerbose $ text "Applying patches..."
  125   patches <- read_repo repo
  126   (s', newpatches, patches_ok) <- case maybe_chk of
  127     Just (Sealed chk) ->
  128         do let chtg = patch2patchinfo chk
  129            putVerbose $ text "I am repairing from a checkpoint."
  130            (s'', _) <- run_slurpy s $ applyAndTryToFix chk
  131            (_, s_, ok) <- applyAndFix c opts s'' repo
  132                       (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches)
  133            return (s_, patches, ok)
  134     Nothing -> do debugMessage "Fixing any broken patches..."
  135                   let psin = reverseRL $ concatRL patches
  136                   (ps, s_, ok) <- applyAndFix c opts s repo psin
  137                   debugMessage "Done fixing broken patches..."
  138                   return (s_, (reverseFL ps :<: NilRL), ok)
  139   debugMessage "Checking pristine against slurpy"
  140   is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False
  141   -- TODO is the latter condition needed? Does a broken patch imply pristine
  142   -- difference? Why, or why not?
  143   return (if is_same && patches_ok
  144      then RepositoryConsistent
  145      else if patches_ok
  146             then BrokenPristine s'
  147             else BrokenPatches s' newpatches)
  148 
  149 cleanupRepositoryReplay :: Repository p -> IO ()
  150 cleanupRepositoryReplay r = do
  151   let c = extractCache r
  152   rf_or_e <- identifyRepoFormat "."
  153   rf <- case rf_or_e of Left e -> fail e
  154                         Right x -> return x
  155   unless (format_has HashedInventory rf) $
  156          rm_recursive $ darcsdir ++ "/pristine.hashed" 
  157   when (format_has HashedInventory rf) $ do
  158        current <- readHashedPristineRoot r
  159        clean_hashdir c HashedPristineDir $ catMaybes [current]
  160 
  161 replayRepository :: (RepoPatch p) => Repository p -> [DarcsFlag] -> (RepositoryConsistency p -> IO a) -> IO a
  162 replayRepository r opt f = run `finally` cleanupRepositoryReplay r
  163     where run = do
  164             st <- replayRepository' r opt
  165             f st