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

import Control.Monad ( when, unless, filterM )
import System.Directory ( doesFileExist, withCurrentDirectory )
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.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.Patch.Progress ( progressFL )

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 wU wR
               -> Verbosity
               -> FL (PrimOf p) wU wY
               -> IO (Repository rt p wY wR)
applyToWorking :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository rt p wY wR)
applyToWorking Repository rt p wU wR
repo Verbosity
verb FL (PrimOf p) wU wY
ps =
  do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
repo)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
debugMessage String
"Applying changes to working tree"
      String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        let ps' :: FL (PrimOf p) wU wY
ps' = String -> FL (PrimOf p) wU wY -> FL (PrimOf p) wU wY
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying patches to working" FL (PrimOf p) wU wY
ps in
        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 (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL (PrimOf p))) m =>
FL (PrimOf p) wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL (PrimOf p) wU wY
ps'
          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 (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL (PrimOf p))) m =>
FL (PrimOf p) wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply FL (PrimOf p) wU wY
ps'
    Repository rt p wY wR -> IO (Repository rt p wY wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wY wR -> IO (Repository rt p wY wR))
-> Repository rt p wY wR -> IO (Repository rt p wY wR)
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> Repository rt p wY wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wU'.
Repository rt p wU wR -> Repository rt p wU' wR
unsafeCoerceU Repository rt p wU wR
repo
  IO (Repository rt p wY wR)
-> (IOError -> IO (Repository rt p wY wR))
-> IO (Repository rt p wY wR)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> String -> IO (Repository rt p wY wR)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Repository rt p wY wR))
-> String -> IO (Repository rt p wY wR)
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

setAllScriptsExecutable :: IO ()
setAllScriptsExecutable :: IO ()
setAllScriptsExecutable = 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 tr IO -> tr IO
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 :: forall (p :: * -> * -> *) wX wY. PatchInspect p => 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 wX wY. 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