--  Copyright (C) 2002-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE RecordWildCards #-}
module Darcs.UI.Commands.Repair ( repair, check ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( when, unless )
import Control.Exception ( catch, IOException )
import System.Exit ( ExitCode(..), exitWith )
import System.Directory( renameFile )
import System.FilePath ( (</>) )

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults
    , putInfo, amInHashedRepository
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( DarcsFlag, verbosity, dryRun, umask, useIndex
    , useCache, compress, diffAlgorithm, quiet
    )
import Darcs.UI.Options
    ( DarcsOption, (^), oid
    , odesc, ocheck, onormalise, defaultFlags, (?)
    )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository.Flags ( UpdateWorking (..) )
import Darcs.Repository.Repair
    ( replayRepository, checkIndex, replayRepositoryInTemp
    , RepositoryConsistency(..)
    )
import Darcs.Repository
    ( Repository, withRepository, readRecorded, RepoJob(..)
    , withRepoLock, replacePristine, writePatchSet
    )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Diff( treeDiff )

import Darcs.Patch ( RepoPatch, showNicely, PrimOf )
import Darcs.Patch.Witnesses.Ordered ( FL(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )

import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Printer ( text, ($$), (<+>) )
import Darcs.Util.Tree( Tree )


repairDescription :: String
repairDescription = "Repair a corrupted repository."

repairHelp :: String
repairHelp =
 "The `darcs repair` command attempts to fix corruption in the current\n" ++
 "repository.  Currently it can only repair damage to the pristine tree,\n" ++
 "which is where most corruption occurs.\n" ++
 "This command rebuilds a pristine tree by applying successively the\n" ++
 "patches in the repository to an empty tree.\n" ++
 "\n" ++
 "The flag `--dry-run` make this operation read-only, making darcs exit\n" ++
 "unsuccessfully (with a non-zero exit status) if the rebuilt pristine is\n" ++
 "different from the current pristine.\n"

commonBasicOpts :: DarcsOption a
                   (Maybe String -> O.UseIndex -> O.DiffAlgorithm -> a)
commonBasicOpts = O.repoDir ^ O.useIndex ^ O.diffAlgorithm

repair :: DarcsCommand [DarcsFlag]
repair = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "repair"
    , commandHelp = repairHelp
    , commandDescription = repairDescription
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = withFpsAndArgs repairCmd
    , commandPrereq = amInHashedRepository
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , ..
    }
  where
    basicOpts = commonBasicOpts ^ O.dryRun
    advancedOpts = O.umask
    allOpts = basicOpts `withStdOpts` advancedOpts
    commandAdvancedOptions = odesc advancedOpts
    commandBasicOptions = odesc basicOpts
    commandDefaults = defaultFlags allOpts
    commandCheckOptions = ocheck allOpts
    commandParseOptions = onormalise allOpts

withFpsAndArgs :: (b -> d) -> a -> b -> c -> d
withFpsAndArgs cmd _ opts _ = cmd opts

repairCmd :: [DarcsFlag] -> IO ()
repairCmd opts = case dryRun ? opts of
 O.YesDryRun -> checkCmd opts
 O.NoDryRun ->
  withRepoLock O.NoDryRun (useCache ? opts) YesUpdateWorking (umask ? opts)
  $ RepoJob $ \repository -> do
    replayRepository (diffAlgorithm ? opts) repository (compress ? opts) (verbosity ? opts) $ \state ->
      case state of
        RepositoryConsistent ->
          putStrLn "The repository is already consistent, no changes made."
        BrokenPristine tree -> do
          putStrLn "Fixing pristine tree..."
          replacePristine repository tree
        BrokenPatches tree newps  -> do
          putStrLn "Writing out repaired patches..."
          _ <- writePatchSet newps (useCache ? opts)
          putStrLn "Fixing pristine tree..."
          replacePristine repository tree
    index_ok <- checkIndex repository (quiet opts)
    unless index_ok $ do renameFile (darcsdir </> "index") (darcsdir </> "index.bad")
                         putStrLn "Bad index discarded."

-- |check is an alias for repair, with implicit DryRun flag.
check :: DarcsCommand [DarcsFlag]
check = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "check"
    , commandHelp = "See `darcs repair` for details."
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = withFpsAndArgs checkCmd
    , commandPrereq = amInHashedRepository
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , ..
    }
  where
    basicOpts = commonBasicOpts
    advancedOpts = oid
    allOpts = basicOpts `withStdOpts` advancedOpts
    commandAdvancedOptions = odesc advancedOpts
    commandBasicOptions = odesc basicOpts
    commandDefaults = defaultFlags allOpts
    commandCheckOptions = ocheck allOpts
    commandParseOptions = onormalise allOpts
    commandDescription = "Alias for `darcs " ++ commandName repair ++ " --dry-run'."

checkCmd :: [DarcsFlag] -> IO ()
checkCmd opts = withRepository (useCache ? opts) $ RepoJob $ \repository -> do
  state <- replayRepositoryInTemp (diffAlgorithm ? opts) repository (compress ? opts) (verbosity ? opts)
  failed <-
    case state of
      RepositoryConsistent -> do
        putInfo opts $ text "The repository is consistent!"
        return False
      BrokenPristine newpris -> do
        brokenPristine opts repository newpris
        return True
      BrokenPatches newpris _ -> do
        brokenPristine opts repository newpris
        putInfo opts $ text "Found broken patches."
        return True
  bad_index <- if useIndex ? opts == O.IgnoreIndex
                 then return False
                 else not <$> checkIndex repository (quiet opts)
  when bad_index $ putInfo opts $ text "Bad index."
  exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess

brokenPristine
  :: forall rt p wR wU wT . (RepoPatch p)
  => [DarcsFlag] -> Repository rt p wR wU wT -> Tree IO -> IO ()
brokenPristine opts repository newpris = do
  putInfo opts $ text "Looks like we have a difference..."
  mc' <- (Just `fmap` readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing)
  case mc' of
    Nothing -> do
      putInfo opts $ text "cannot compute that difference, try repair"
      putInfo opts $ text "" $$ text "Inconsistent repository"
    Just mc -> do
      ftf <- filetypeFunction
      Sealed (diff :: FL (PrimOf p) wR wR2)
        <- unFreeLeft `fmap` treeDiff (diffAlgorithm ? opts) ftf newpris mc :: IO (Sealed (FL (PrimOf p) wR))
      putInfo opts $ case diff of
        NilFL -> text "Nothing"
        patch -> text "Difference: " <+> showNicely patch
      putInfo opts $ text "" $$ text "Inconsistent repository!"