--  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 "
      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."
    ]

-- |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
    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
    -- 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 <- 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
                                        -- Count of files in current directory
                                        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
"")
                        -- Something corrupt somewhere
                        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