module Darcs.Repository.Working
    ( applyToWorking
    , setScriptsExecutable
    , setScriptsExecutablePatches
    )  where

import Control.Monad ( when, unless, filterM )
import System.Directory ( doesFileExist )
import System.IO.Error ( catchIOError )

import qualified Data.ByteString as B ( readFile
                                      , isPrefixOf
                                      )
import qualified Data.ByteString.Char8 as BC (pack)

import Darcs.Prelude

import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Workaround ( setExecutable )
import Darcs.Util.Tree ( Tree )
import Darcs.Util.Path ( anchorPath )
import qualified Darcs.Util.Tree as Tree

import Darcs.Patch ( RepoPatch, PrimOf, apply, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..) )
import Darcs.Patch.Inspect ( PatchInspect )

import Darcs.Repository.Format ( RepoProperty( NoWorkingDir ), formatHas )
import Darcs.Repository.Flags  ( Verbosity(..) )
import Darcs.Repository.InternalTypes
    ( Repository
    , repoFormat
    , repoLocation
    , unsafeCoerceU )
import Darcs.Repository.ApplyPatches ( runTolerantly, runSilently )
import Darcs.Repository.State ( readWorking, TreeFilter(..)  )

applyToWorking :: (ApplyState p ~ Tree, RepoPatch p)
               => Repository rt p wR wU wT
               -> Verbosity
               -> FL (PrimOf p) wU wY
               -> IO (Repository rt p wR wY wT)
applyToWorking :: Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wU wT
repo Verbosity
verb FL (PrimOf p) wU wY
patch =
  do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
repo)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        if Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet
          then TolerantWrapper SilentIO () -> IO ()
forall a. TolerantWrapper SilentIO a -> IO a
runSilently (TolerantWrapper SilentIO () -> IO ())
-> TolerantWrapper SilentIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wY -> TolerantWrapper SilentIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL (PrimOf p) wU wY
patch
          else TolerantWrapper TolerantIO () -> IO ()
forall a. TolerantWrapper TolerantIO a -> IO a
runTolerantly (TolerantWrapper TolerantIO () -> IO ())
-> TolerantWrapper TolerantIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wY -> TolerantWrapper TolerantIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL (PrimOf p) wU wY
patch
    Repository rt p wR wY wT -> IO (Repository rt p wR wY wT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wR wY wT -> IO (Repository rt p wR wY wT))
-> Repository rt p wR wY wT -> IO (Repository rt p wR wY wT)
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wT -> Repository rt p wR wY wT
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wU'.
Repository rt p wR wU wT -> Repository rt p wR wU' wT
unsafeCoerceU Repository rt p wR wU wT
repo
  IO (Repository rt p wR wY wT)
-> (IOError -> IO (Repository rt p wR wY wT))
-> IO (Repository rt p wR wY wT)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> String -> IO (Repository rt p wR wY wT)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Repository rt p wR wY wT))
-> String -> IO (Repository rt p wR wY wT)
forall a b. (a -> b) -> a -> b
$ String
"Error applying changes to working tree:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)

-- | Set the given paths executable if they are scripts.
--   A script is any file that starts with the bytes '#!'.
--   This is used for --set-scripts-executable.
setScriptsExecutable_ :: [FilePath] -> IO ()
setScriptsExecutable_ :: [String] -> IO ()
setScriptsExecutable_ [String]
paths = do
    String -> IO ()
debugMessage String
"Making scripts executable"
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
setExecutableIfScript [String]
paths

setScriptsExecutable :: IO ()
setScriptsExecutable :: IO ()
setScriptsExecutable = do
    Tree IO
tree <- TreeFilter IO -> IO (Tree IO)
readWorking ((forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO)
-> TreeFilter IO
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter forall a. a -> a
forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
id)
    [String] -> IO ()
setScriptsExecutable_ [String -> AnchoredPath -> String
anchorPath String
"." AnchoredPath
p | (AnchoredPath
p, Tree.File Blob IO
_) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
Tree.list Tree IO
tree]

setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches :: p wX wY -> IO ()
setScriptsExecutablePatches p wX wY
pw = do
    [String]
paths <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath String
".") ([AnchoredPath] -> [String]) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> a -> b
$ p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles p wX wY
pw
    [String] -> IO ()
setScriptsExecutable_ [String]
paths

setExecutableIfScript :: FilePath -> IO ()
setExecutableIfScript :: String -> IO ()
setExecutableIfScript String
f = do
    ByteString
contents <- String -> IO ByteString
B.readFile String
f
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> ByteString
BC.pack String
"#!" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
contents) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
debugMessage (String
"Making executable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f)
        String -> Bool -> IO ()
setExecutable String
f Bool
True