1 {-# LANGUAGE CPP, FlexibleInstances #-}
    2 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
    3 
    4 -- Copyright (C) 2009 Petr Rockai
    5 --
    6 -- Permission is hereby granted, free of charge, to any person
    7 -- obtaining a copy of this software and associated documentation
    8 -- files (the "Software"), to deal in the Software without
    9 -- restriction, including without limitation the rights to use, copy,
   10 -- modify, merge, publish, distribute, sublicense, and/or sell copies
   11 -- of the Software, and to permit persons to whom the Software is
   12 -- furnished to do so, subject to the following conditions:
   13 --
   14 -- The above copyright notice and this permission notice shall be
   15 -- included in all copies or substantial portions of the Software.
   16 --
   17 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
   18 -- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
   19 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
   20 -- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
   21 -- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
   22 -- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
   23 -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
   24 -- SOFTWARE.
   25 
   26 #include "gadts.h"
   27 
   28 module Darcs.Gorsvet where
   29 
   30 import Prelude hiding ( all, filter, lines, read, readFile, writeFile )
   31 
   32 -- darcs stuff
   33 import ByteStringUtils( is_funky )
   34 import Darcs.Repository ( Repository, slurp_pending )
   35 import Darcs.Repository.Internal ( read_pending )
   36 import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply
   37                    , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert)
   38 import Darcs.Ordered ( FL(..), (+>+) )
   39 import Darcs.Repository.Prefs ( filetype_function, FileType(..) )
   40 import Darcs.IO
   41 import Darcs.Sealed ( Sealed(Sealed), seal )
   42 import Darcs.Patch( apply_to_filepaths )
   43 import Darcs.Patch.Patchy ( Apply )
   44 import Darcs.Patch.TouchesFiles ( choose_touching )
   45 import Darcs.Patch.FileName ( fn2fp, FileName )
   46 
   47 import qualified Data.ByteString.Lazy.Char8 as BL
   48 import qualified Data.ByteString.Char8 as BS
   49 import Control.Monad.State.Strict
   50 import System.Directory( removeFile, doesFileExist )
   51 import Data.Maybe
   52 import Data.List( union )
   53 
   54 import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) )
   55 import Darcs.RepoPath ( SubPath, sp2fn )
   56 
   57 import Text.Regex( matchRegex )
   58 import Darcs.Repository.Prefs( boring_regexps )
   59 
   60 import Storage.Hashed
   61 import Storage.Hashed.Tree
   62 import qualified Storage.Hashed.Index as I
   63 import Storage.Hashed.AnchoredPath
   64 import Storage.Hashed.Darcs( darcsFormatHash, darcsTreeHash )
   65 import Storage.Hashed.Monad
   66     ( virtualTreeIO, hashedTreeIO, plainTreeIO
   67     , unlink, rename, createDirectory, writeFile
   68     , readFile -- ratify readFile: haskell_policy je natvrdlá
   69     , cwd, tree, TreeIO )
   70 import Storage.Hashed
   71 
   72 floatFn :: FileName -> AnchoredPath
   73 floatFn = floatPath . fn2fp
   74 
   75 instance ReadableDirectory TreeIO where
   76     mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d))
   77     mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f))
   78     mInCurrentDirectory d action = do -- TODO bracket?
   79       wd <- gets cwd
   80       modify (\x -> x { cwd = floatFn d })
   81       x <- action
   82       modify (\x' -> x' { cwd = wd })
   83       return x
   84     mGetDirectoryContents = error "get dir contents"
   85     mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ...
   86                        return $ BS.concat (BL.toChunks x)
   87 
   88 instance WriteableDirectory TreeIO where
   89     mWithCurrentDirectory = mInCurrentDirectory
   90     mSetFileExecutable _ _ = return ()
   91     mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid.
   92           (floatFn p) (BL.fromChunks [ps])
   93     mCreateDirectory p = createDirectory (floatFn p)
   94     mRename from to = rename (floatFn from) (floatFn to)
   95     mRemoveDirectory = unlink . floatFn
   96     mRemoveFile = unlink . floatFn
   97 
   98 treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim C(x y))
   99 #ifdef GADT_WITNESSES
  100 treeDiff = undefined -- Sigh.
  101 #else
  102 treeDiff ft t1 t2 = do
  103   (from, to) <- diffTrees t1 t2
  104   diffs <- sequence $ zipTrees diff from to
  105   return $ foldr (+>+) NilFL diffs
  106     where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem
  107                -> IO (FL Prim)
  108           diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL
  109           diff p (Just (SubTree _)) Nothing =
  110               return $ rmdir (anchorPath "" p) :>: NilFL
  111           diff p Nothing (Just (SubTree _)) =
  112               return $ adddir (anchorPath "" p) :>: NilFL
  113           diff p Nothing b'@(Just (File _)) =
  114               do diff' <- diff p (Just (File emptyBlob)) b'
  115                  return $ addfile (anchorPath "" p) :>: diff'
  116           diff p a'@(Just (File _)) Nothing =
  117               do diff' <- diff p a' (Just (File emptyBlob))
  118                  return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL)
  119           diff p (Just (File a')) (Just (File b')) =
  120               do a <- read a'
  121                  b <- read b'
  122                  let path = anchorPath "" p
  123                  case ft path of
  124                    TextFile | no_bin a && no_bin b ->
  125                                 return $ text_diff path a b
  126                    _ -> return $ if a /= b
  127                                     then binary path (strict a) (strict b) :>: NilFL
  128                                     else NilFL
  129           diff p _ _ = fail $ "Missing case at path " ++ show p
  130           text_diff p a b
  131               | BL.null a && BL.null b = NilFL
  132               | BL.null a = diff_from_empty p b
  133               | BL.null b = diff_to_empty p a
  134               | otherwise = line_diff p (lines a) (lines b)
  135           line_diff p a b = canonize (hunk p 1 a b)
  136           diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) []
  137                             | otherwise = line_diff p (lines x) [BS.empty]
  138           diff_from_empty p x = invert (diff_to_empty p x)
  139           no_bin = not . is_funky . strict . BL.take 4096
  140           lines = map strict . BL.split '\n'
  141           strict = BS.concat . BL.toChunks
  142 #endif
  143 
  144 readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO Tree
  145 readRecorded _ = readDarcsPristine "."
  146 
  147 readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree
  148 readRecordedAndPending repo = do
  149   pristine <- readRecorded repo
  150   Sealed pending <- pendingChanges repo []
  151   applyToTree pending pristine
  152 
  153 pendingChanges :: (RepoPatch p) => Repository p C(r u t)
  154                -> [SubPath] -> IO (Sealed (FL Prim C(r)))
  155 pendingChanges repo paths = do
  156   slurp_pending repo -- XXX: only here to get us the "pending conflicts" check
  157                      -- that I don't know yet how to implement properly
  158   Sealed pending <- read_pending repo
  159   let files = map (fn2fp . sp2fn) paths
  160       pre_files = apply_to_filepaths (invert pending) files
  161       relevant = case paths of
  162                    [] -> seal pending
  163                    _ -> choose_touching pre_files pending
  164   return relevant
  165 
  166 applyToTree :: (Apply p) => p C(x y) -> Tree -> IO Tree
  167 applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t
  168 
  169 unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)
  170                   -> [SubPath] -> IO (FL Prim C(r y))
  171 unrecordedChanges opts repo paths = do
  172   pristine <- readDarcsPristine "."
  173   Sealed pending <- pendingChanges repo paths
  174   (_, current') <- virtualTreeIO (apply [] pending) pristine
  175   relevant <- restrictSubpaths repo paths
  176   nonboring <- restrictBoring
  177 
  178   let current = relevant current'
  179   working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of
  180                (False, False) -> do
  181                  all <- readIndex repo
  182                  expand (relevant all)
  183                (False, True) -> do
  184                  guide <- expand current
  185                  all <- readPlainTree "."
  186                  return $ relevant $ (restrict guide) all
  187                -- TODO (True, False) could use a more efficient implementation...
  188                (True, _) -> do
  189                  all <- readPlainTree "."
  190                  return $ relevant $ nonboring all
  191 
  192   ft <- filetype_function
  193   diff <- treeDiff ft current working
  194   return $ sort_coalesceFL (pending +>+ diff)
  195 
  196 applyToTentativePristine :: (Apply p) => t -> p C(x y) -> IO ()
  197 applyToTentativePristine _ patches =
  198     do pristine <- readDarcsPristine "."
  199        (_, t) <- hashedTreeIO (apply [] patches)
  200                  pristine "_darcs/pristine.hashed"
  201        BS.writeFile "_darcs/tentative_pristine" $
  202          BS.concat [BS.pack "pristine:"
  203                    , darcsFormatHash (fromJust $ treeHash t)]
  204 
  205 applyToWorking :: (RepoPatch p) => Repository p C(r u t)
  206                -> Sealed (FL Prim C(u)) -> IO Tree
  207 applyToWorking repo (Sealed patches) =
  208     do working <- readIndex repo
  209        snd `fmap` plainTreeIO (apply [] patches) working "."
  210 
  211 filter_paths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
  212 filter_paths files =
  213     \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files
  214 
  215 restrict_paths :: [AnchoredPath] -> Tree -> Tree
  216 restrict_paths files = if null files
  217                           then id
  218                           else filter $ filter_paths files
  219 
  220 restrict_subpaths :: [SubPath] -> Tree -> Tree
  221 restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn)
  222 
  223 restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree -> Tree)
  224 restrictSubpaths repo subpaths = do
  225   Sealed pending <- read_pending repo
  226   let paths = map (fn2fp . sp2fn) subpaths
  227       paths' = paths `union` apply_to_filepaths pending paths
  228       anchored = map floatPath paths'
  229   return $ restrict_paths anchored
  230 
  231 restrictBoring :: IO (Tree -> Tree)
  232 restrictBoring = do
  233   boring <- boring_regexps
  234   let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False
  235       boring' p _ = not $ any (\rx -> isJust $ matchRegex rx p') boring
  236           where p' = anchorPath "" p
  237   return $ filter boring'
  238 
  239 readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO Tree
  240 readIndex repo = do
  241   invalid <- doesFileExist "_darcs/index_invalid"
  242   exist <- doesFileExist "_darcs/index"
  243   format_valid <- if exist
  244                      then I.indexFormatValid "_darcs/index"
  245                      else return True
  246   when (exist && not format_valid) $ removeFile "_darcs/index"
  247   if (not exist || invalid || not format_valid)
  248      then do pris <- readRecordedAndPending repo
  249              idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris
  250              when invalid $ removeFile "_darcs/index_invalid"
  251              return idx
  252      else I.readIndex "_darcs/index" darcsTreeHash
  253 
  254 invalidateIndex :: t -> IO ()
  255 invalidateIndex _ = do
  256   BS.writeFile "_darcs/index_invalid" BS.empty