%  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}
{-# LANGUAGE CPP #-}
module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where

import Control.Arrow ( (***) )
import Control.Monad ( when, unless )
import Control.Monad.Trans ( liftIO )
import Control.Monad.Writer ( 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, JustThisRepo ),
                        check_or_repair, working_repo_dir, just_this_repo
                      )
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, isthisrepo, 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 :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)
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 for this corruption and optionally repairs it.",
   "By default it also does this for any caches you have configured and any other " ++
   "local repositories listed as sources of patches for this one, perhaps because of a " ++
   "lazy get. You can limit the scope to just the current repo with the --just-this-repo " ++
   "flag.",
   "Note that readonly caches, or other repositories listed as sources, " ++
   "will be checked but not repaired. Also, this command will abort if it encounters " ++
   "any non-CRC corruption in compressed files.",
   "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."
  ]

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,
                                                just_this_repo,
                                                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"

#ifdef GADT_WITNESSES
gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p r u t -> IO ()
#else
gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()
#endif
gzcrcs' opts repo = do
  let Ca locs = extractCache repo
  ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do
    unless (JustThisRepo `elem` opts && not (isthisrepo 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) <- 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, isCorrupt) = gzDecompress (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 :: Int)) $ 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}