--  Copyright (C) 2009 Ganesh Sittampalam
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use, copy,
-- modify, merge, publish, distribute, sublicense, and/or sell copies
-- of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.

module Darcs.UI.Commands.GZCRCs
    ( gzcrcs
    , doCRCWarnings
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( when, unless, forM_ )
import Control.Monad.Trans ( liftIO )
import Control.Monad.Writer ( runWriterT, tell )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Monoid ( Any(..), Sum(..) )
import System.Directory ( doesFileExist, doesDirectoryExist )
import System.Exit ( ExitCode(..), exitWith )
import System.IO ( hPutStr, hPutStrLn, stderr )
import Darcs.Util.File ( getRecursiveContentsFullPath )
import Darcs.Util.ByteString ( isGZFile, gzDecompress )
import Darcs.Util.Global ( getCRCWarnings, resetCRCWarnings )
import Darcs.Repository ( Repository, withRepository, RepoJob(..), repoCache )
-- 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.Cache ( Cache(..), writable, isThisRepo,
                                hashedFilePath, allHashedDirs )
import Darcs.Util.Lock ( gzWriteAtomicFilePSs )
import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository
    , putInfo, putVerbose
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Options ( (^), oid, odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Path ( AbsolutePath )
import Darcs.UI.Flags ( DarcsFlag, useCache )
import Darcs.Util.Text ( formatText )
import Darcs.Util.Printer ( text )

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

-- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand
doCRCWarnings :: Bool -> IO ()
doCRCWarnings :: Bool -> IO ()
doCRCWarnings verbose :: Bool
verbose = do
    [String]
files <- IO [String]
getCRCWarnings
    IO ()
resetCRCWarnings
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> String
formatText 80 ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [""
            , "Warning: CRC errors found. These are probably harmless but "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ "should be repaired. See 'darcs gzcrcs --help' for more "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ "information."
            , ""
            ]
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
                "The following corrupt files were found:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
files

gzcrcsDescription :: String
gzcrcsDescription :: String
gzcrcsDescription = "Check or repair the CRCs of compressed files in the "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "repository."

gzcrcs :: DarcsCommand [DarcsFlag]
gzcrcs :: DarcsCommand [DarcsFlag]
gzcrcs = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "gzcrcs"
    , commandHelp :: String
commandHelp = String
gzcrcsHelp
    , commandDescription :: String
commandDescription = String
gzcrcsDescription
    , commandExtraArgs :: Int
commandExtraArgs = 0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
gzcrcsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe GzcrcsAction -> Bool -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe GzcrcsAction -> Bool -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
gzcrcsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
gzcrcsOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
gzcrcsOpts
    }
  where
    gzcrcsBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Maybe String -> a)
  (Maybe GzcrcsAction)
PrimDarcsOption (Maybe GzcrcsAction)
O.gzcrcsActions PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Maybe String -> a)
  (Maybe GzcrcsAction)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (Bool -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (Bool -> Maybe String -> a)
PrimDarcsOption Bool
O.justThisRepo OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
    gzcrcsOpts :: DarcsOption
  a
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
gzcrcsOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe GzcrcsAction
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
gzcrcsCmd _ opts :: [DarcsFlag]
opts _ =
  case PrimDarcsOption (Maybe GzcrcsAction)
O.gzcrcsActions PrimDarcsOption (Maybe GzcrcsAction)
-> [DarcsFlag] -> Maybe GzcrcsAction
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
    Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "You must specify --check or --repair for gzcrcs"
    Just action :: GzcrcsAction
action -> UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob (GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
gzcrcs' GzcrcsAction
action [DarcsFlag]
opts))

gzcrcs' :: O.GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
gzcrcs' :: GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
gzcrcs' action :: GzcrcsAction
action opts :: [DarcsFlag]
opts repo :: Repository rt p wR wU wT
repo = do
    -- Somewhat ugly IORef use here because it's convenient, would be nicer to
    -- pre-filter the list of locs to check and then decide whether to print
    -- the message up front.
    IORef Bool
warnRelatedRepos <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef (Bool -> IO (IORef Bool)) -> Bool -> IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
isJustThisRepo
    let Ca locs :: [CacheLoc]
locs = Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
repo
    (_, Any checkFailed :: Bool
checkFailed) <- WriterT Any IO () -> IO ((), Any)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Any IO () -> IO ((), Any))
-> WriterT Any IO () -> IO ((), Any)
forall a b. (a -> b) -> a -> b
$ [CacheLoc] -> (CacheLoc -> WriterT Any IO ()) -> WriterT Any IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CacheLoc]
locs ((CacheLoc -> WriterT Any IO ()) -> WriterT Any IO ())
-> (CacheLoc -> WriterT Any IO ()) -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ \loc :: CacheLoc
loc ->
        Bool -> WriterT Any IO () -> WriterT Any IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isJustThisRepo Bool -> Bool -> Bool
&& Bool -> Bool
not (CacheLoc -> Bool
isThisRepo CacheLoc
loc)) (WriterT Any IO () -> WriterT Any IO ())
-> WriterT Any IO () -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ do
            let isWritable :: Bool
isWritable = CacheLoc -> Bool
writable CacheLoc
loc
            [HashedDir]
-> (HashedDir -> WriterT Any IO ()) -> WriterT Any IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HashedDir]
allHashedDirs ((HashedDir -> WriterT Any IO ()) -> WriterT Any IO ())
-> (HashedDir -> WriterT Any IO ()) -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ \hdir :: HashedDir
hdir -> do
                let dir :: String
dir = CacheLoc -> HashedDir -> String -> String
hashedFilePath CacheLoc
loc HashedDir
hdir ""
                Bool
exists <- IO Bool -> WriterT Any IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT Any IO Bool) -> IO Bool -> WriterT Any IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
dir
                Bool -> WriterT Any IO () -> WriterT Any IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (WriterT Any IO () -> WriterT Any IO ())
-> WriterT Any IO () -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ do
                    IO () -> WriterT Any IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT Any IO ()) -> IO () -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ do
                        Bool
warn <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
warnRelatedRepos
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& Bool -> Bool
not (CacheLoc -> Bool
isThisRepo CacheLoc
loc)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
warnRelatedRepos Bool
False
                            [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
                                "Also checking related repos and caches; use "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ "--just-this-repo to disable.\n"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Checking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
isWritable then "" else " (readonly)")
                    [String]
files <- IO [String] -> WriterT Any IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> WriterT Any IO [String])
-> IO [String] -> WriterT Any IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getRecursiveContentsFullPath String
dir
                    (_, Sum count :: Int
count) <- WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT Any IO ((), Sum Int)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Sum Int) (WriterT Any IO) ()
 -> WriterT Any IO ((), Sum Int))
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT Any IO ((), Sum Int)
forall a b. (a -> b) -> a -> b
$ [String]
-> (String -> WriterT (Sum Int) (WriterT Any IO) ())
-> WriterT (Sum Int) (WriterT Any IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
files ((String -> WriterT (Sum Int) (WriterT Any IO) ())
 -> WriterT (Sum Int) (WriterT Any IO) ())
-> (String -> WriterT (Sum Int) (WriterT Any IO) ())
-> WriterT (Sum Int) (WriterT Any IO) ()
forall a b. (a -> b) -> a -> b
$ \file :: String
file -> do
                        Bool
isfile <- IO Bool -> WriterT (Sum Int) (WriterT Any IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT (Sum Int) (WriterT Any IO) Bool)
-> IO Bool -> WriterT (Sum Int) (WriterT Any IO) Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file
                        Bool
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT (Sum Int) (WriterT Any IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isfile (WriterT (Sum Int) (WriterT Any IO) ()
 -> WriterT (Sum Int) (WriterT Any IO) ())
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT (Sum Int) (WriterT Any IO) ()
forall a b. (a -> b) -> a -> b
$ do
                            Maybe Int
gz <- IO (Maybe Int) -> WriterT (Sum Int) (WriterT Any IO) (Maybe Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int) -> WriterT (Sum Int) (WriterT Any IO) (Maybe Int))
-> IO (Maybe Int) -> WriterT (Sum Int) (WriterT Any IO) (Maybe Int)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Int)
isGZFile String
file
                            case Maybe Int
gz of
                                Nothing -> () -> WriterT (Sum Int) (WriterT Any IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just len :: Int
len -> do
                                    ByteString
contents <- IO ByteString -> WriterT (Sum Int) (WriterT Any IO) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> WriterT (Sum Int) (WriterT Any IO) ByteString)
-> IO ByteString -> WriterT (Sum Int) (WriterT Any IO) ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
file
                                    let contentsbl :: ByteString
contentsbl = [ByteString] -> ByteString
BL.fromChunks [ByteString
contents]
                                        (uncompressed :: [ByteString]
uncompressed, isCorrupt :: Bool
isCorrupt) =
                                            Maybe Int -> ByteString -> ([ByteString], Bool)
gzDecompress (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
len) ByteString
contentsbl
                                    Bool
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT (Sum Int) (WriterT Any IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCorrupt (WriterT (Sum Int) (WriterT Any IO) ()
 -> WriterT (Sum Int) (WriterT Any IO) ())
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT (Sum Int) (WriterT Any IO) ()
forall a b. (a -> b) -> a -> b
$ do
                                        -- Count of files in current directory
                                        Sum Int -> WriterT (Sum Int) (WriterT Any IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Int -> Sum Int
forall a. a -> Sum a
Sum 1)
                                        IO () -> WriterT (Sum Int) (WriterT Any IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT (Sum Int) (WriterT Any IO) ())
-> (Doc -> IO ()) -> Doc -> WriterT (Sum Int) (WriterT Any IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts (Doc -> WriterT (Sum Int) (WriterT Any IO) ())
-> Doc -> WriterT (Sum Int) (WriterT Any IO) ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
                                            "Corrupt: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file
                                        Bool
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT (Sum Int) (WriterT Any IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isWritable Bool -> Bool -> Bool
&& Bool
shouldRepair) (WriterT (Sum Int) (WriterT Any IO) ()
 -> WriterT (Sum Int) (WriterT Any IO) ())
-> WriterT (Sum Int) (WriterT Any IO) ()
-> WriterT (Sum Int) (WriterT Any IO) ()
forall a b. (a -> b) -> a -> b
$
                                            String -> [ByteString] -> WriterT (Sum Int) (WriterT Any IO) ()
forall (m :: * -> *) p.
(MonadIO m, FilePathLike p) =>
p -> [ByteString] -> m ()
doRepair String
file [ByteString]
uncompressed
                    Bool -> WriterT Any IO () -> WriterT Any IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (0 :: Int)) (WriterT Any IO () -> WriterT Any IO ())
-> WriterT Any IO () -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ do
                        IO () -> WriterT Any IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT Any IO ())
-> (Doc -> IO ()) -> Doc -> WriterT Any IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> WriterT Any IO ()) -> Doc -> WriterT Any IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
                            "Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> String -> String
forall a. [a] -> [a] -> [a]
++ " corrupt file"
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 then "s" else "")
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
shouldRepair
                                    then if Bool
isWritable
                                            then " (repaired)"
                                            else " (not repaired)"
                                    else "")
                        -- Something corrupt somewhere
                        Any -> WriterT Any IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> Any
Any Bool
True)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GzcrcsAction
action GzcrcsAction -> GzcrcsAction -> Bool
forall a. Eq a => a -> a -> Bool
== GzcrcsAction
O.GzcrcsCheck Bool -> Bool -> Bool
&& Bool
checkFailed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 1)
  where
    shouldRepair :: Bool
shouldRepair = GzcrcsAction
action GzcrcsAction -> GzcrcsAction -> Bool
forall a. Eq a => a -> a -> Bool
== GzcrcsAction
O.GzcrcsRepair
    isJustThisRepo :: Bool
isJustThisRepo = PrimDarcsOption Bool
O.justThisRepo PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
    doRepair :: p -> [ByteString] -> m ()
doRepair name :: p
name contents :: [ByteString]
contents = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ p -> [ByteString] -> IO ()
forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
name [ByteString]
contents