1 %  Copyright (C) 2009 Ganesh Sittampalam
    2 %
    3 %  This program is free software; you can redistribute it and/or modify
    4 %  it under the terms of the GNU General Public License as published by
    5 %  the Free Software Foundation; either version 2, or (at your option)
    6 %  any later version.
    7 %
    8 %  This program is distributed in the hope that it will be useful,
    9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 %  GNU General Public License for more details.
   12 %
   13 %  You should have received a copy of the GNU General Public License
   14 %  along with this program; see the file COPYING.  If not, write to
   15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 %  Boston, MA 02110-1301, USA.
   17 
   18 \subsection{darcs gzcrcs}
   19 \darcsCommand{gzcrcs}
   20 \begin{code}
   21 {-# LANGUAGE CPP #-}
   22 module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where
   23 
   24 import Control.Arrow ( (***) )
   25 import Control.Monad ( when, unless )
   26 import Control.Monad.Trans ( liftIO )
   27 import Control.Monad.Writer ( runWriterT, tell )
   28 import Data.List ( intersperse )
   29 import Data.Monoid ( Any(..), Sum(..) )
   30 
   31 import qualified Data.ByteString as B
   32 import qualified Data.ByteString.Lazy as BL
   33 
   34 import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist )
   35 import System.Exit ( ExitCode(..), exitWith )
   36 
   37 import Darcs.Commands ( DarcsCommand(..), nodefaults )
   38 import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ),
   39                         check_or_repair, working_repo_dir, just_this_repo
   40                       )
   41 import Darcs.Repository ( Repository, amInRepository, withRepository )
   42 import Darcs.Patch ( RepoPatch )
   43 import Printer ( putDocLn, text )
   44 import ByteStringUtils ( isGZFile )
   45 import Darcs.Lock ( gzWriteAtomicFilePSs )
   46 
   47 -- This command needs access beyond the normal repository APIs (to
   48 -- get at the caches and inspect them directly)
   49 -- Could move the relevant code into Darcs.Repository modules
   50 -- but it doesn't really seem worth it.
   51 import Darcs.Repository.InternalTypes ( extractCache )
   52 import Darcs.Repository.Cache ( Cache(..), writable, isthisrepo, hashedFilePath, allHashedDirs )
   53 
   54 
   55 import Darcs.Global ( getCRCWarnings, resetCRCWarnings )
   56 import ByteStringUtils ( gzDecompress )
   57 
   58 gzcrcs_description :: String
   59 gzcrcs_description = "Check or repair the CRCs of compressed files in the repository."
   60 
   61 gzcrcs_help :: String
   62 gzcrcs_help = formatText
   63   [
   64    "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++
   65    "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++
   66    "reading, so this bug wasn't noticed.",
   67    "This command inspects your repository for this corruption and optionally repairs it.",
   68    "By default it also does this for any caches you have configured and any other " ++
   69    "local repositories listed as sources of patches for this one, perhaps because of a " ++
   70    "lazy get. You can limit the scope to just the current repo with the --just-this-repo " ++
   71    "flag.",
   72    "Note that readonly caches, or other repositories listed as sources, " ++
   73    "will be checked but not repaired. Also, this command will abort if it encounters " ++
   74    "any non-CRC corruption in compressed files.",
   75    "You may wish to also run 'darcs check --complete' before repairing the corruption. " ++
   76    "This is not done automatically because it might result in needing to fetch extra " ++
   77    "patches if the repository is lazy.",
   78    "If there are any other problems with your repository, you can still repair the CRCs, " ++
   79    "but you are advised to first make a backup copy in case the CRC errors are actually " ++
   80    "caused by bad data and the old CRCs might be useful in recovering that data.",
   81    "If you were warned about CRC errors during an operation involving another repository, " ++
   82    "then it is possible that the other repository contains the corrupt CRCs, so you " ++
   83    "should arrange for that repository to also be checked/repaired."
   84   ]
   85 
   86 formatText :: [String] -> String
   87 formatText = unlines . concat . intersperse [""] . map (map unwords . para 80 . words)
   88 
   89 -- |Take a list of words and split it up so that each chunk fits into the specified width
   90 -- when spaces are included. Any words longer than the specified width end up in a chunk
   91 -- of their own.
   92 para :: Int -> [[a]] -> [[[a]]]
   93 para w = para'
   94   where para' [] = []
   95         para' xs = uncurry (:) $ para'' w xs
   96         para'' r (x:xs) | w == r || length x < r = ((x:) *** id) $ para'' (r - length x - 1) xs
   97         para'' _ xs = ([], para' xs)
   98 
   99 -- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand
  100 doCRCWarnings :: Bool -> IO ()
  101 doCRCWarnings verbose = do
  102    files <- getCRCWarnings
  103    resetCRCWarnings
  104    when (not . null $ files) $ do
  105       putStr . formatText $
  106           ["",
  107            "Warning: CRC errors found. These are probably harmless but should " ++
  108            "be repaired. See 'darcs gzcrcs --help' for more information.",
  109            ""]
  110       when verbose $ putStrLn $ unlines ("The following corrupt files were found:":files)
  111 
  112 gzcrcs :: DarcsCommand
  113 gzcrcs = DarcsCommand {command_name = "gzcrcs",
  114                        command_help = gzcrcs_help,
  115                        command_description = gzcrcs_description,
  116                        command_extra_args = 0,
  117                        command_extra_arg_help = [],
  118                        command_command = gzcrcs_cmd,
  119                        command_prereq = amInRepository,
  120                        command_get_arg_possibilities = return [],
  121                        command_argdefaults = nodefaults,
  122                        command_advanced_options = [],
  123                        command_basic_options = [check_or_repair,
  124                                                 just_this_repo,
  125                                                 working_repo_dir
  126                                                ]}
  127 
  128 gzcrcs_cmd :: [DarcsFlag] -> [String] -> IO ()
  129 gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts)
  130 gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs"
  131 
  132 #ifdef GADT_WITNESSES
  133 gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p r u t -> IO ()
  134 #else
  135 gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()
  136 #endif
  137 gzcrcs' opts repo = do
  138   let Ca locs = extractCache repo
  139   ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do
  140     unless (JustThisRepo `elem` opts && not (isthisrepo loc)) $ do
  141      let w = writable loc
  142      flip mapM_ allHashedDirs $ \hdir -> do
  143         let dir = hashedFilePath loc hdir ""
  144         exists <- liftIO $ doesDirectoryExist dir
  145         when exists $ do
  146            liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)")
  147            files <- liftIO $ getDirectoryContents dir
  148            ((), Sum count) <- runWriterT $ flip mapM_ files $ \file -> do
  149               let fn = dir ++ file
  150               isfile <- liftIO $ doesFileExist fn
  151               when isfile $ do
  152                  gz <- liftIO $ isGZFile fn
  153                  case gz of
  154                     Nothing -> return ()
  155                     Just len -> do
  156                        contents <- liftIO $ B.readFile fn
  157                        let (uncompressed, isCorrupt) = gzDecompress (Just len) . BL.fromChunks $ [contents]
  158                        when isCorrupt $ do
  159                           tell (Sum 1) -- count of files in current directory
  160                           liftIO $ putVerbose $ text $ "Corrupt: " ++ fn
  161                           when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed
  162            when (count > (0 :: Int)) $ do
  163               liftIO $ putInfo $ text $
  164                  "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++
  165                  (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "")
  166               tell (Any True) -- something corrupt somewhere
  167   when (Check `elem` opts && checkFailed) $ exitWith $ ExitFailure 1
  168 
  169  where
  170      putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
  171      putVerbose s = when (Verbose `elem` opts) $ putDocLn s
  172 
  173 \end{code}