--  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.Util.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, (?) )
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
    files <- IO [String]
getCRCWarnings
    resetCRCWarnings
    unless (null files) $ do
        hPutDocLn stderr . formatText 80 $
            [ "Warning: CRC errors found. These are probably harmless but "
              ++ "should be repaired. See 'darcs gzcrcs --help' for more "
              ++ "information."
            ]
        when verbose $
            hPutDocLn stderr $
                text "The following corrupt files were found:" $$ pathlist 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
    { 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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
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 :: CommandOptions
gzcrcsOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe GzcrcsAction -> Bool -> Maybe String -> a)
gzcrcsBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe GzcrcsAction
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
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 PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe GzcrcsAction)
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"You must specify --check or --repair for gzcrcs"
    Just GzcrcsAction
action -> UseCache -> RepoJob 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (GzcrcsAction -> [DarcsFlag] -> Repository 'RO p wU wR -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
GzcrcsAction -> [DarcsFlag] -> Repository rt p wU wR -> IO ()
gzcrcs' GzcrcsAction
action [DarcsFlag]
opts))

gzcrcs' :: O.GzcrcsAction -> [DarcsFlag] -> Repository rt p wU wR -> IO ()
gzcrcs' :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
GzcrcsAction -> [DarcsFlag] -> Repository rt p wU wR -> IO ()
gzcrcs' GzcrcsAction
action [DarcsFlag]
opts Repository rt p wU wR
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.
    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 = Cache -> [CacheLoc]
cacheEntries (Cache -> [CacheLoc]) -> Cache -> [CacheLoc]
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
repo
    (_, Any checkFailed) <- runWriterT $ forM_ locs $ \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
""
                exists <- IO Bool -> WriterT Any IO Bool
forall a. IO a -> WriterT Any IO a
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
                when exists $ do
                    liftIO $ do
                        warn <- readIORef warnRelatedRepos
                        when (warn && not (isThisRepo loc)) $ do
                            writeIORef warnRelatedRepos False
                            putInfo opts $ text $
                                "Also checking related repos and caches; use "
                                ++ "--just-this-repo to disable.\n"
                                ++ "Checking " ++ dir
                                ++ (if isWritable then "" else " (readonly)")
                    files <- liftIO $ getRecursiveContentsFullPath dir
                    (_, Sum count) <- runWriterT $ forM_ files $ \String
file -> do
                        isfile <- IO Bool -> WriterT (Sum Int) (WriterT Any IO) Bool
forall a. IO a -> WriterT (Sum Int) (WriterT Any IO) a
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
                        when isfile $ do
                            gz <- liftIO $ isGZFile file
                            case gz of
                                Maybe Int
Nothing -> () -> WriterT (Sum Int) (WriterT Any IO) ()
forall a. a -> WriterT (Sum Int) (WriterT Any IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just Int
len -> do
                                    contents <- IO ByteString -> WriterT (Sum Int) (WriterT Any IO) ByteString
forall a. IO a -> WriterT (Sum Int) (WriterT Any IO) a
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] -> LazyByteString
BL.fromChunks [ByteString
contents]
                                        (uncompressed, isCorrupt) =
                                            gzDecompress (Just len) contentsbl
                                    when isCorrupt $ do
                                        -- Count of files in current directory
                                        tell (Sum 1)
                                        liftIO . putVerbose opts $ text $
                                            "Corrupt: " ++ file
                                        when (isWritable && shouldRepair) $
                                            doRepair file uncompressed
                    when (count > (0 :: Int)) $ do
                        liftIO . putInfo opts $ text $
                            "Found " ++ show count ++ " corrupt file"
                            ++ (if count > 1 then "s" else "")
                            ++ (if shouldRepair
                                    then if isWritable
                                            then " (repaired)"
                                            else " (not repaired)"
                                    else "")
                        -- Something corrupt somewhere
                        tell (Any True)
    when (action == O.GzcrcsCheck && checkFailed) $
        exitWith (ExitFailure 1)
  where
    shouldRepair :: Bool
shouldRepair = GzcrcsAction
action GzcrcsAction -> GzcrcsAction -> Bool
forall a. Eq a => a -> a -> Bool
== GzcrcsAction
O.GzcrcsRepair
    isJustThisRepo :: Bool
isJustThisRepo = PrimOptSpec DarcsOptDescr DarcsFlag a Bool
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 a. IO a -> m a
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