--  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 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 ( 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
    ( allHashedDirs
    , cacheEntries
    , hashedFilePath
    , isThisRepo
    , writable
    )
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, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Path ( AbsolutePath )
import Darcs.UI.Flags ( DarcsFlag, useCache )
import Darcs.Util.Printer ( Doc, ($$), formatText, hPutDocLn, pathlist, text )

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

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

gzcrcs :: DarcsCommand
gzcrcs :: DarcsCommand
gzcrcs = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"gzcrcs"
    , commandHelp :: Doc
commandHelp = Doc
gzcrcsHelp
    , commandDescription :: String
commandDescription = String
gzcrcsDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
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
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
gzcrcsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
gzcrcsOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe GzcrcsAction
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
gzcrcsCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
  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
    Maybe GzcrcsAction
Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"You must specify --check or --repair for gzcrcs"
    Just 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' GzcrcsAction
action [DarcsFlag]
opts 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 locs :: [CacheLoc]
locs = Cache -> [CacheLoc]
cacheEntries (Cache -> [CacheLoc]) -> Cache -> [CacheLoc]
forall a b. (a -> b) -> a -> b
$ 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 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
$ \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
$ \HashedDir
hdir -> do
                let dir :: String
dir = CacheLoc -> HashedDir -> String -> String
hashedFilePath CacheLoc
loc HashedDir
hdir String
""
                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
$
                                String
"Also checking related repos and caches; use "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"--just-this-repo to disable.\n"
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Checking " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
isWritable then String
"" else String
" (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 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
$ \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
                                Maybe Int
Nothing -> () -> WriterT (Sum Int) (WriterT Any IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just 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]
                                        ([ByteString]
uncompressed, 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 Int
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
$
                                            String
"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
> (Int
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
$
                            String
"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]
++ String
" corrupt file"
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
shouldRepair
                                    then if Bool
isWritable
                                            then String
" (repaired)"
                                            else String
" (not repaired)"
                                    else String
"")
                        -- 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 Int
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 p
name [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