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 )
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 "
forall a. [a] -> [a] -> [a]
++ String
"files with bad CRCs (but valid data) to be written out. CRCs were "
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 "
forall a. [a] -> [a] -> [a]
++ String
"optionally repairs it."
, String
"By default it also does this for any caches you have configured and "
forall a. [a] -> [a] -> [a]
++ String
"any other local repositories listed as sources of patches for this "
forall a. [a] -> [a] -> [a]
++ String
"one, perhaps because of a lazy clone. You can limit the scope to just "
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, "
forall a. [a] -> [a] -> [a]
++ String
"will be checked but not repaired. Also, this command will abort if "
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 "
forall a. [a] -> [a] -> [a]
++ String
"corruption. This is not done automatically because it might result "
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 "
forall a. [a] -> [a] -> [a]
++ String
"repair the CRCs, but you are advised to first make a backup copy in "
forall a. [a] -> [a] -> [a]
++ String
"case the CRC errors are actually caused by bad data and the old "
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 "
forall a. [a] -> [a] -> [a]
++ String
"another repository, then it is possible that the other repository "
forall a. [a] -> [a] -> [a]
++ String
"contains the corrupt CRCs, so you should arrange for that "
forall a. [a] -> [a] -> [a]
++ String
"repository to also be checked/repaired."
]
doCRCWarnings :: Bool -> IO ()
doCRCWarnings :: Bool -> IO ()
doCRCWarnings Bool
verbose = do
[String]
files <- IO [String]
getCRCWarnings
IO ()
resetCRCWarnings
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) forall a b. (a -> b) -> a -> b
$ do
Handle -> Doc -> IO ()
hPutDocLn Handle
stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> Doc
formatText Int
80 forall a b. (a -> b) -> a -> b
$
[ String
"Warning: CRC errors found. These are probably harmless but "
forall a. [a] -> [a] -> [a]
++ String
"should be repaired. See 'darcs gzcrcs --help' for more "
forall a. [a] -> [a] -> [a]
++ String
"information."
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$
Handle -> Doc -> IO ()
hPutDocLn Handle
stderr 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 "
forall a. [a] -> [a] -> [a]
++ String
"repository."
gzcrcs :: DarcsCommand
gzcrcs :: DarcsCommand
gzcrcs = 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 = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe GzcrcsAction
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
gzcrcsOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck 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 = PrimDarcsOption (Maybe GzcrcsAction)
O.gzcrcsActions forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.justThisRepo forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
gzcrcsOpts :: DarcsOption
a
(Maybe GzcrcsAction
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
gzcrcsOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` 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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
Maybe GzcrcsAction
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"You must specify --check or --repair for gzcrcs"
Just GzcrcsAction
action -> forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (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 (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' :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
GzcrcsAction -> [DarcsFlag] -> Repository rt p wR wU wT -> IO ()
gzcrcs' GzcrcsAction
action [DarcsFlag]
opts Repository rt p wR wU wT
repo = do
IORef Bool
warnRelatedRepos <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
isJustThisRepo
let locs :: [CacheLoc]
locs = Cache -> [CacheLoc]
cacheEntries forall a b. (a -> b) -> a -> b
$ 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) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CacheLoc]
locs forall a b. (a -> b) -> a -> b
$ \CacheLoc
loc ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isJustThisRepo Bool -> Bool -> Bool
&& Bool -> Bool
not (CacheLoc -> Bool
isThisRepo CacheLoc
loc)) forall a b. (a -> b) -> a -> b
$ do
let isWritable :: Bool
isWritable = CacheLoc -> Bool
writable CacheLoc
loc
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HashedDir]
allHashedDirs 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
dir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Bool
warn <- forall a. IORef a -> IO a
readIORef IORef Bool
warnRelatedRepos
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& Bool -> Bool
not (CacheLoc -> Bool
isThisRepo CacheLoc
loc)) forall a b. (a -> b) -> a -> b
$ do
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
warnRelatedRepos Bool
False
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Also checking related repos and caches; use "
forall a. [a] -> [a] -> [a]
++ String
"--just-this-repo to disable.\n"
forall a. [a] -> [a] -> [a]
++ String
"Checking " forall a. [a] -> [a] -> [a]
++ String
dir
forall a. [a] -> [a] -> [a]
++ (if Bool
isWritable then String
"" else String
" (readonly)")
[String]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getRecursiveContentsFullPath String
dir
(()
_, Sum Int
count) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
files forall a b. (a -> b) -> a -> b
$ \String
file -> do
Bool
isfile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isfile forall a b. (a -> b) -> a -> b
$ do
Maybe Int
gz <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Int)
isGZFile String
file
case Maybe Int
gz of
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Int
len -> do
ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 (forall a. a -> Maybe a
Just Int
len) ByteString
contentsbl
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isCorrupt forall a b. (a -> b) -> a -> b
$ do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall a. a -> Sum a
Sum Int
1)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Corrupt: " forall a. [a] -> [a] -> [a]
++ String
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isWritable Bool -> Bool -> Bool
&& Bool
shouldRepair) forall a b. (a -> b) -> a -> b
$
forall {m :: * -> *} {p}.
(MonadIO m, FilePathLike p) =>
p -> [ByteString] -> m ()
doRepair String
file [ByteString]
uncompressed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Ord a => a -> a -> Bool
> (Int
0 :: Int)) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"Found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
" corrupt file"
forall a. [a] -> [a] -> [a]
++ (if Int
count forall a. Ord a => a -> a -> Bool
> Int
1 then String
"s" else String
"")
forall a. [a] -> [a] -> [a]
++ (if Bool
shouldRepair
then if Bool
isWritable
then String
" (repaired)"
else String
" (not repaired)"
else String
"")
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> Any
Any Bool
True)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GzcrcsAction
action forall a. Eq a => a -> a -> Bool
== GzcrcsAction
O.GzcrcsCheck Bool -> Bool -> Bool
&& Bool
checkFailed) forall a b. (a -> b) -> a -> b
$
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
where
shouldRepair :: Bool
shouldRepair = GzcrcsAction
action forall a. Eq a => a -> a -> Bool
== GzcrcsAction
O.GzcrcsRepair
isJustThisRepo :: Bool
isJustThisRepo = PrimDarcsOption Bool
O.justThisRepo forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
doRepair :: p -> [ByteString] -> m ()
doRepair p
name [ByteString]
contents = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
name [ByteString]
contents