Gorsvet.hs

{-# LANGUAGE CPP, FlexibleInstances #-}
{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}

-- Copyright (C) 2009 Petr Rockai
--
-- 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.

#include "gadts.h"

module Darcs.Gorsvet where

import Prelude hiding ( all, filter, lines, read, readFile, writeFile )

-- darcs stuff
import ByteStringUtils( is_funky )
import Darcs.Repository ( Repository, slurp_pending )
import Darcs.Repository.Internal ( read_pending )
import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply
                   , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert)
import Darcs.Ordered ( FL(..), (+>+) )
import Darcs.Repository.Prefs ( filetype_function, FileType(..) )
import Darcs.IO
import Darcs.Sealed ( Sealed(Sealed), seal )
import Darcs.Patch( apply_to_filepaths )
import Darcs.Patch.Patchy ( Apply )
import Darcs.Patch.TouchesFiles ( choose_touching )
import Darcs.Patch.FileName ( fn2fp, FileName )

import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
import Control.Monad.State.Strict
import System.Directory( removeFile, doesFileExist )
import Data.Maybe
import Data.List( union )

import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) )
import Darcs.RepoPath ( SubPath, sp2fn )

import Text.Regex( matchRegex )
import Darcs.Repository.Prefs( boring_regexps )

import Storage.Hashed
import Storage.Hashed.Tree
import qualified Storage.Hashed.Index as I
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Darcs( darcsFormatHash, darcsTreeHash )
import Storage.Hashed.Monad
    ( virtualTreeIO, hashedTreeIO, plainTreeIO
    , unlink, rename, createDirectory, writeFile
    , readFile -- ratify readFile: haskell_policy je natvrdlá
    , cwd, tree, TreeIO )
import Storage.Hashed

floatFn :: FileName -> AnchoredPath
floatFn = floatPath . fn2fp

instance ReadableDirectory TreeIO where
    mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d))
    mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f))
    mInCurrentDirectory d action = do -- TODO bracket?
      wd <- gets cwd
      modify (\x -> x { cwd = floatFn d })
      x <- action
      modify (\x' -> x' { cwd = wd })
      return x
    mGetDirectoryContents = error "get dir contents"
    mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ...
                       return $ BS.concat (BL.toChunks x)

instance WriteableDirectory TreeIO where
    mWithCurrentDirectory = mInCurrentDirectory
    mSetFileExecutable _ _ = return ()
    mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid.
          (floatFn p) (BL.fromChunks [ps])
    mCreateDirectory p = createDirectory (floatFn p)
    mRename from to = rename (floatFn from) (floatFn to)
    mRemoveDirectory = unlink . floatFn
    mRemoveFile = unlink . floatFn

treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim C(x y))
#ifdef GADT_WITNESSES
treeDiff = undefined -- Sigh.
#else
treeDiff ft t1 t2 = do
  (from, to) <- diffTrees t1 t2
  diffs <- sequence $ zipTrees diff from to
  return $ foldr (+>+) NilFL diffs
    where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem
               -> IO (FL Prim)
          diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL
          diff p (Just (SubTree _)) Nothing =
              return $ rmdir (anchorPath "" p) :>: NilFL
          diff p Nothing (Just (SubTree _)) =
              return $ adddir (anchorPath "" p) :>: NilFL
          diff p Nothing b'@(Just (File _)) =
              do diff' <- diff p (Just (File emptyBlob)) b'
                 return $ addfile (anchorPath "" p) :>: diff'
          diff p a'@(Just (File _)) Nothing =
              do diff' <- diff p a' (Just (File emptyBlob))
                 return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL)
          diff p (Just (File a')) (Just (File b')) =
              do a <- read a'
                 b <- read b'
                 let path = anchorPath "" p
                 case ft path of
                   TextFile | no_bin a && no_bin b ->
                                return $ text_diff path a b
                   _ -> return $ if a /= b
                                    then binary path (strict a) (strict b) :>: NilFL
                                    else NilFL
          diff p _ _ = fail $ "Missing case at path " ++ show p
          text_diff p a b
              | BL.null a && BL.null b = NilFL
              | BL.null a = diff_from_empty p b
              | BL.null b = diff_to_empty p a
              | otherwise = line_diff p (lines a) (lines b)
          line_diff p a b = canonize (hunk p 1 a b)
          diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) []
                            | otherwise = line_diff p (lines x) [BS.empty]
          diff_from_empty p x = invert (diff_to_empty p x)
          no_bin = not . is_funky . strict . BL.take 4096
          lines = map strict . BL.split '\n'
          strict = BS.concat . BL.toChunks
#endif

readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO Tree
readRecorded _ = readDarcsPristine "."

readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree
readRecordedAndPending repo = do
  pristine <- readRecorded repo
  Sealed pending <- pendingChanges repo []
  applyToTree pending pristine

pendingChanges :: (RepoPatch p) => Repository p C(r u t)
               -> [SubPath] -> IO (Sealed (FL Prim C(r)))
pendingChanges repo paths = do
  slurp_pending repo -- XXX: only here to get us the "pending conflicts" check
                     -- that I don't know yet how to implement properly
  Sealed pending <- read_pending repo
  let files = map (fn2fp . sp2fn) paths
      pre_files = apply_to_filepaths (invert pending) files
      relevant = case paths of
                   [] -> seal pending
                   _ -> choose_touching pre_files pending
  return relevant

applyToTree :: (Apply p) => p C(x y) -> Tree -> IO Tree
applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t

unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)
                  -> [SubPath] -> IO (FL Prim C(r y))
unrecordedChanges opts repo paths = do
  pristine <- readDarcsPristine "."
  Sealed pending <- pendingChanges repo paths
  (_, current') <- virtualTreeIO (apply [] pending) pristine
  relevant <- restrictSubpaths repo paths
  nonboring <- restrictBoring

  let current = relevant current'
  working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of
               (False, False) -> do
                 all <- readIndex repo
                 expand (relevant all)
               (False, True) -> do
                 guide <- expand current
                 all <- readPlainTree "."
                 return $ relevant $ (restrict guide) all
               -- TODO (True, False) could use a more efficient implementation...
               (True, _) -> do
                 all <- readPlainTree "."
                 return $ relevant $ nonboring all

  ft <- filetype_function
  diff <- treeDiff ft current working
  return $ sort_coalesceFL (pending +>+ diff)

applyToTentativePristine :: (Apply p) => t -> p C(x y) -> IO ()
applyToTentativePristine _ patches =
    do pristine <- readDarcsPristine "."
       (_, t) <- hashedTreeIO (apply [] patches)
                 pristine "_darcs/pristine.hashed"
       BS.writeFile "_darcs/tentative_pristine" $
         BS.concat [BS.pack "pristine:"
                   , darcsFormatHash (fromJust $ treeHash t)]

applyToWorking :: (RepoPatch p) => Repository p C(r u t)
               -> Sealed (FL Prim C(u)) -> IO Tree
applyToWorking repo (Sealed patches) =
    do working <- readIndex repo
       snd `fmap` plainTreeIO (apply [] patches) working "."

filter_paths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
filter_paths files =
    \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files

restrict_paths :: [AnchoredPath] -> Tree -> Tree
restrict_paths files = if null files
                          then id
                          else filter $ filter_paths files

restrict_subpaths :: [SubPath] -> Tree -> Tree
restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn)

restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree -> Tree)
restrictSubpaths repo subpaths = do
  Sealed pending <- read_pending repo
  let paths = map (fn2fp . sp2fn) subpaths
      paths' = paths `union` apply_to_filepaths pending paths
      anchored = map floatPath paths'
  return $ restrict_paths anchored

restrictBoring :: IO (Tree -> Tree)
restrictBoring = do
  boring <- boring_regexps
  let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False
      boring' p _ = not $ any (\rx -> isJust $ matchRegex rx p') boring
          where p' = anchorPath "" p
  return $ filter boring'

readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO Tree
readIndex repo = do
  invalid <- doesFileExist "_darcs/index_invalid"
  exist <- doesFileExist "_darcs/index"
  format_valid <- if exist
                     then I.indexFormatValid "_darcs/index"
                     else return True
  when (exist && not format_valid) $ removeFile "_darcs/index"
  if (not exist || invalid || not format_valid)
     then do pris <- readRecordedAndPending repo
             idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris
             when invalid $ removeFile "_darcs/index_invalid"
             return idx
     else I.readIndex "_darcs/index" darcsTreeHash

invalidateIndex :: t -> IO ()
invalidateIndex _ = do
  BS.writeFile "_darcs/index_invalid" BS.empty