GZCRCs.lhs

%  Copyright (C) 2009 Ganesh Sittampalam
%
%  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.

\subsection{darcs gzcrcs}
\darcsCommand{gzcrcs}
\begin{code}
module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where

import Control.Arrow ( (***) )
import Control.Monad ( when )
import Control.Monad.Trans ( liftIO )
import Control.Monad.Writer ( runWriter, runWriterT, tell )
import Data.List ( intersperse )
import Data.Monoid ( Any(..), Sum(..) )

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL

import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist )
import System.Exit ( ExitCode(..), exitWith )

import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair ),
                        check_or_repair, working_repo_dir,
                      )
import Darcs.Repository ( Repository, amInRepository, withRepository )
import Darcs.Patch ( RepoPatch )
import Printer ( putDocLn, text )
import ByteStringUtils ( isGZFile )
import Darcs.Lock ( gzWriteAtomicFilePSs )

-- This command needs access beyond the normal repository APIs (to
-- get at the caches and inspect them directly)
-- Could move the relevant code into Darcs.Repository modules
-- but it doesn't really seem worth it.
import Darcs.Repository.InternalTypes ( extractCache )
import Darcs.Repository.Cache ( Cache(..), writable, hashedFilePath, allHashedDirs )


#ifdef HAVE_HASKELL_ZLIB
import Darcs.Global ( getCRCWarnings, resetCRCWarnings )
import ByteStringUtils ( gzDecompress )
#else
-- These functions aren't available unless we have the Haskell zlib.
-- The gzcrcs command shouldn't be enabled in this case, but we would
-- still like to typecheck this module as much as possible so we include
-- dummy versions 
noChecking :: String -> a
noChecking what = error $ "Darcs.Commands.GZCRCs." ++ what ++ ": gz CRC checking is not possible unless " ++
                          "darcs has been built with the Haskell zlib. This code should be unreachable."
getCRCWarnings :: IO [FilePath]
getCRCWarnings = noChecking "getCRCWarnings"
resetCRCWarnings :: IO ()
resetCRCWarnings = noChecking "resetCRCWarnings"
gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString]
gzDecompress = noChecking "gzDecompress"
#endif

gzcrcs_description :: String
gzcrcs_description = "Check or repair the CRCs of compressed files in the repository."

gzcrcs_help :: String
gzcrcs_help = formatText
  [
   "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++
   "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++
   "reading, so this bug wasn't noticed.",
   "This command inspects your repository and caches for this corruption and optionally " ++
   "repairs it.",
   "You may wish to also run 'darcs check --complete' before repairing the corruption. " ++
   "This is not done automatically because it might result in needing to fetch extra " ++
   "patches if the repository is lazy.",
   "If there are any other problems with your repository, you can still repair the CRCs, " ++
   "but you are advised to first make a backup copy in case the CRC errors are actually " ++
   "caused by bad data and the old CRCs might be useful in recovering that data.",
   "If you were warned about CRC errors during an operation involving another repository, " ++
   "then it is possible that the other repository contains the corrupt CRCs, so you " ++
   "should arrange for that repository to also be checked/repaired.",
   "Note that readonly caches, or other repositories that were sources for lazy gets, " ++
   "will be checked but not repaired. Also, this command will abort if it encounters " ++
   "any non-CRC corruption in compressed files."
  ]

formatText :: [String] -> String
formatText = unlines . concat . intersperse [""] . map (map unwords . para 80 . words)

-- |Take a list of words and split it up so that each chunk fits into the specified width
-- when spaces are included. Any words longer than the specified width end up in a chunk
-- of their own.
para :: Int -> [[a]] -> [[[a]]]
para w = para'
  where para' [] = []
        para' xs = uncurry (:) $ para'' w xs
        para'' r (x:xs) | w == r || length x < r = ((x:) *** id) $ para'' (r - length x - 1) xs
        para'' _ xs = ([], para' xs)

-- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand
doCRCWarnings :: Bool -> IO ()
doCRCWarnings verbose = do
   files <- getCRCWarnings
   resetCRCWarnings
   when (not . null $ files) $ do
      putStr . formatText $
          ["",
           "Warning: CRC errors found. These are probably harmless but should " ++
           "be repaired. See 'darcs gzcrcs --help' for more information.",
           ""]
      when verbose $ putStrLn $ unlines ("The following corrupt files were found:":files)

gzcrcs :: DarcsCommand
gzcrcs = DarcsCommand {command_name = "gzcrcs",
                       command_help = gzcrcs_help,
                       command_description = gzcrcs_description,
                       command_extra_args = 0,
                       command_extra_arg_help = [],
                       command_command = gzcrcs_cmd,
                       command_prereq = amInRepository,
                       command_get_arg_possibilities = return [],
                       command_argdefaults = nodefaults,
                       command_advanced_options = [],
                       command_basic_options = [check_or_repair,
                                                working_repo_dir
                                               ]}

gzcrcs_cmd :: [DarcsFlag] -> [String] -> IO ()
gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts)
gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs"

gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()
gzcrcs' opts repo = do
  let Ca locs = extractCache repo
  ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do
     let w = writable loc
     flip mapM_ allHashedDirs $ \hdir -> do
        let dir = hashedFilePath loc hdir ""
        exists <- liftIO $ doesDirectoryExist dir
        when exists $ do
           liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)")
           files <- liftIO $ getDirectoryContents dir
           ((), Sum (count :: Int)) <- runWriterT $ flip mapM_ files $ \file -> do
              let fn = dir ++ file
              isfile <- liftIO $ doesFileExist fn
              when isfile $ do
                 gz <- liftIO $ isGZFile fn
                 case gz of
                    Nothing -> return ()
                    Just len -> do
                       contents <- liftIO $ B.readFile fn
                       let (uncompressed, Any isCorrupt)
                             = runWriter . gzDecompress (tell (Any True)) (Just len) . BL.fromChunks $ [contents]
                       when isCorrupt $ do
                          tell (Sum 1) -- count of files in current directory
                          liftIO $ putVerbose $ text $ "Corrupt: " ++ fn
                          when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed
           when (count > 0) $ do
              liftIO $ putInfo $ text $
                 "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++
                 (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "")
              tell (Any True) -- something corrupt somewhere
  when (Check `elem` opts && checkFailed) $ exitWith $ ExitFailure 1

 where
     putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
     putVerbose s = when (Verbose `elem` opts) $ putDocLn s

\end{code}