1 -- Copyright (C) 2002-2004 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 {-# OPTIONS_GHC -cpp #-} 19 {-# LANGUAGE CPP #-} 20 21 -- | SlurpDirectory is intended to give a nice lazy way of traversing directory 22 -- trees. 23 module Darcs.SlurpDirectory.Internal 24 ( Slurpy(..), SlurpyContents(..), slurpies_to_map, map_to_slurpies, 25 FileContents, empty_slurpy, 26 slurp, mmap_slurp, slurp_unboring, co_slurp, 27 slurp_name, is_file, is_dir, 28 get_filecontents, get_dircontents, get_mtime, 29 get_length, get_slurp, 30 slurp_removefile, slurp_removedir, 31 slurp_remove, 32 slurp_modfile, slurp_hasfile, slurp_hasdir, 33 slurp_has_anycase, wait_a_moment, undefined_time, 34 undefined_size, 35 slurp_has, list_slurpy, list_slurpy_files, 36 get_path_list, 37 list_slurpy_dirs, 38 isFileReallySymlink, 39 doesFileReallyExist, doesDirectoryReallyExist, 40 SlurpMonad, withSlurpy, write_files, 41 writeSlurpy, syncSlurpy 42 ) where 43 44 import System.IO 45 import System.Directory hiding ( getCurrentDirectory, renameFile ) 46 import Workaround ( getCurrentDirectory ) 47 import Darcs.Utils ( withCurrentDirectory, formatPath ) 48 import Darcs.RepoPath ( FilePathLike, toPath ) 49 import System.IO.Unsafe ( unsafeInterleaveIO ) 50 import Data.List ( isPrefixOf ) 51 import Control.Monad ( MonadPlus(..), when ) 52 import Data.Char ( toLower ) 53 import System.Posix.Types ( EpochTime ) 54 import System.Posix.Files 55 ( getSymbolicLinkStatus, modificationTime, 56 fileSize, 57 isRegularFile, isDirectory, isSymbolicLink 58 ) 59 import System.Posix ( sleep ) 60 import Data.Maybe ( catMaybes, isJust, maybeToList ) 61 import Data.Map (Map) 62 import qualified Data.Map as Map 63 64 import Darcs.SignalHandler ( tryNonSignal ) 65 import Darcs.CheckFileSystem ( can_I_use_mmap ) 66 import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) ) 67 68 import ByteStringUtils 69 import qualified Data.ByteString as B 70 71 import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir, 72 own_name, super_name ) 73 #if mingw32_HOST_OS 74 import Data.Int ( Int64 ) 75 #else 76 import System.Posix.Types ( FileOffset ) 77 #endif 78 79 #include "impossible.h" 80 81 #if mingw32_HOST_OS 82 type FileOffset = Int64 83 #endif 84 85 data Slurpy = Slurpy !FileName !SlurpyContents 86 87 slurpy_to_pair :: Slurpy -> (FileName, SlurpyContents) 88 slurpy_to_pair (Slurpy fn sc) = (fn, sc) 89 90 pair_to_slurpy :: (FileName, SlurpyContents) -> Slurpy 91 pair_to_slurpy = uncurry Slurpy 92 93 type SlurpyMap = Map FileName SlurpyContents 94 95 slurpies_to_map :: [Slurpy] -> SlurpyMap 96 slurpies_to_map = Map.fromList . map slurpy_to_pair 97 98 map_to_slurpies :: SlurpyMap -> [Slurpy] 99 map_to_slurpies = map pair_to_slurpy . Map.toList 100 101 data SlurpyContents = SlurpDir (Maybe String) SlurpyMap 102 | SlurpFile (Maybe String,EpochTime,FileOffset) FileContents 103 type FileContents = B.ByteString 104 105 instance Show Slurpy where 106 show (Slurpy fn (SlurpDir _ l)) = 107 "Dir " ++ (fn2fp fn) ++ "\n" ++ 108 concat (map show $ map_to_slurpies l) ++ "End Dir " ++ (fn2fp fn) ++ "\n" 109 show (Slurpy fn (SlurpFile _ _)) = "File " ++ (fn2fp fn) ++ "\n" 110 111 mapSlurpyNames :: (FileName -> FileName) -> Slurpy -> Slurpy 112 mapSlurpyNames f = onSlurpy 113 where onSlurpy (Slurpy fn sc) = Slurpy (f fn) (onSlurpyContents sc) 114 onSlurpyContents sf@(SlurpFile _ _) = sf 115 onSlurpyContents (SlurpDir x sm) = SlurpDir x . slurpies_to_map . map onSlurpy . map_to_slurpies $ sm 116 117 slurp :: FilePathLike p => p -> IO Slurpy 118 mmap_slurp :: FilePath -> IO Slurpy 119 slurp_unboring :: (FilePath->Bool) -> FilePath -> IO Slurpy 120 empty_slurpy :: Slurpy 121 empty_slurpy = Slurpy (fp2fn ".") (SlurpDir Nothing Map.empty) 122 slurp_name :: Slurpy -> FilePath 123 is_file :: Slurpy -> Bool 124 is_dir :: Slurpy -> Bool 125 126 get_filecontents :: Slurpy -> FileContents 127 get_dircontents :: Slurpy -> [Slurpy] 128 get_mtime :: Slurpy -> EpochTime 129 get_length :: Slurpy -> FileOffset 130 131 instance Eq Slurpy where 132 s1 == s2 = (slurp_name s1) == (slurp_name s2) 133 instance Ord Slurpy where 134 s1 <= s2 = (slurp_name s1) <= (slurp_name s2) 135 136 data SlurpMonad a = SM ((Either String Slurpy) 137 -> Either String (Slurpy, a)) 138 mksm :: (Slurpy -> Either String (Slurpy, a)) -> SlurpMonad a 139 mksm x = SM sm where sm (Left e) = Left e 140 sm (Right s) = x s 141 142 instance Functor SlurpMonad where 143 fmap f m = m >>= return . f 144 145 instance Monad SlurpMonad where 146 (SM p) >>= k = SM sm 147 where sm e = case p e of 148 Left er -> Left er 149 Right (s, a) -> case k a of 150 (SM q) -> q (Right s) 151 return a = SM ( \s -> case s of 152 Left e -> Left e 153 Right x -> Right (x, a) ) 154 fail e = SM ( \s -> case s of 155 Left x -> Left x 156 _ -> Left e ) 157 158 instance MonadPlus SlurpMonad where 159 mzero = fail "SlurpMonad mzero" 160 (SM p) `mplus` (SM q) = SM sm 161 where sm e = case p e of 162 Left _ -> q e 163 okay -> okay 164 165 instance ReadableDirectory SlurpMonad where 166 mDoesDirectoryExist d = smDoesDirectoryExist d 167 mDoesFileExist f = smDoesFileExist f 168 mInCurrentDirectory = smInSlurpy 169 mGetDirectoryContents = smGetDirContents 170 mReadFilePS = smReadFilePS 171 mReadFilePSs = smReadFilePSs 172 173 instance WriteableDirectory SlurpMonad where 174 mWithCurrentDirectory = modifySubSlurpy 175 mSetFileExecutable _ _ = return () 176 mWriteFilePS = smWriteFilePS 177 mCreateDirectory = smCreateDirectory 178 mRename = smRename 179 mRemoveDirectory = smRemoveDirectory 180 mRemoveFile = smRemoveFile 181 182 write_file :: Slurpy -> FileName -> IO () 183 write_file s fn = case withSlurpy s $ smReadFilePS fn of 184 Left err -> fail err 185 Right (_, c) -> do 186 ensureDirectories (super_name fn) 187 mWriteFilePS fn c 188 189 try_write_file :: Slurpy -> FilePath -> IO () 190 try_write_file s fp = let fn = fp2fn fp in 191 if slurp_hasfile fn s 192 then write_file s fn 193 else if slurp_hasdir fn s 194 then ensureDirectories fn 195 else return () 196 197 ensureDirectories :: WriteableDirectory m => FileName -> m () 198 ensureDirectories d = do 199 isPar <- mDoesDirectoryExist d 200 if isPar 201 then return () 202 else ensureDirectories (super_name d) >> (mCreateDirectory d) 203 204 write_files :: Slurpy -> [FilePath] -> IO () 205 write_files s fps = mapM_ (try_write_file s) fps 206 207 -- don't overwrite non-empty directories unless explicitly asked by 208 -- being passed "." (which always exists) 209 writeSlurpy :: Slurpy -> FilePath -> IO () 210 writeSlurpy s d = do 211 when (d /= ".") $ createDirectory d 212 withCurrentDirectory d $ write_files s (list_slurpy s) 213 214 withSlurpy :: Slurpy -> SlurpMonad a -> Either String (Slurpy, a) 215 withSlurpy s (SM f) = f (Right s) 216 217 smDoesDirectoryExist :: FileName -> SlurpMonad Bool 218 smDoesDirectoryExist d = mksm $ \s -> (Right (s, slurp_hasdir d s)) 219 220 smDoesFileExist :: FileName -> SlurpMonad Bool 221 smDoesFileExist f = mksm $ \s -> (Right (s, slurp_hasfile f s)) 222 223 -- smInSlurpy doesn't make any changes to the subdirectory. 224 smInSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a 225 smInSlurpy d job = mksm sm 226 where sm s = case get_slurp d s of 227 Just s' | is_dir s' -> case withSlurpy s' job of 228 Left e -> Left e 229 Right (_,a) -> Right (s, a) 230 _ -> Left $ "smInSlurpy: Couldn't find directory " ++ 231 formatPath (fn2fp d) 232 233 fromSlurpFile :: FileName -> (Slurpy -> a) -> SlurpMonad a 234 fromSlurpFile f job = mksm sm 235 where sm s = case get_slurp f s of 236 Just s' | is_file s' -> Right (s, job s') 237 _ -> Left $ "fromSlurpFile: Couldn't find file " ++ 238 formatPath (fn2fp f) 239 240 modifySubSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a 241 modifySubSlurpy d job = mksm sm 242 where sm s = case get_slurp_context d s of 243 Just (ctx, sub@(Slurpy _ (SlurpDir _ _))) -> 244 case withSlurpy sub job of 245 Left e -> Left e 246 Right (sub',a) -> Right (ctx sub', a) 247 _ -> Left $ "modifySubSlurpy: Couldn't find directory " ++ 248 formatPath (fn2fp d) 249 250 modifyFileSlurpy :: FileName -> (Slurpy -> Slurpy) -> SlurpMonad () 251 modifyFileSlurpy f job = mksm sm 252 where sm s = case get_slurp_context f s of 253 Just (ctx, sf@(Slurpy _ (SlurpFile _ _))) -> Right (ctx $ job sf, ()) 254 _ -> Left $ "modifyFileSlurpy: Couldn't find file " ++ 255 formatPath (fn2fp f) 256 257 insertSlurpy :: FileName -> Slurpy -> SlurpMonad () 258 insertSlurpy f news = mksm $ \s -> 259 if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s) 260 then Left $ "Error creating file "++fn2fp f 261 else Right (addslurp f news s, ()) 262 263 smReadFilePS :: FileName -> SlurpMonad B.ByteString 264 smReadFilePS f = fromSlurpFile f get_filecontents 265 266 smReadFilePSs :: FileName -> SlurpMonad [B.ByteString] 267 smReadFilePSs f = fromSlurpFile f (linesPS . get_filecontents) 268 269 smGetDirContents :: SlurpMonad [FileName] 270 smGetDirContents = mksm $ \s -> Right (s, map slurp_fn $ get_dircontents s) 271 272 smWriteFilePS :: FileName -> B.ByteString -> SlurpMonad () 273 smWriteFilePS f ps = -- this implementation could be made rather more direct 274 -- and limited to a single pass down the Slurpy 275 modifyFileSlurpy f (\_ -> sl) 276 `mplus` insertSlurpy f sl 277 where sl = Slurpy (own_name f) (SlurpFile undef_time_size ps) 278 279 smCreateDirectory :: FileName -> SlurpMonad () 280 smCreateDirectory a = mksm sm 281 where sm s = case slurp_adddir a s of 282 Just s' -> Right (s', ()) 283 Nothing -> Left $ "Error creating directory "++fn2fp a 284 285 smRename :: FileName -> FileName -> SlurpMonad () 286 smRename a b = mksm sm 287 where sm s = case slurp_move a b s of 288 Just s' -> Right (s', ()) 289 Nothing -> 290 -- Workaround for some old patches having moves when the source file doesn't exist. 291 if (slurp_has (fn2fp a) s) 292 then Left $ "Error moving "++fn2fp a++" to "++fn2fp b 293 else Right (s, ()) 294 295 smRemove :: FileName -> SlurpMonad () 296 smRemove f = mksm sm 297 where sm s = case slurp_remove f s of 298 Nothing -> Left $ fn2fp f++" does not exist." 299 Just s' -> Right (s', ()) 300 301 smRemoveFile :: FileName -> SlurpMonad () 302 smRemoveFile f = 303 do exists <- mDoesFileExist f 304 if exists then smRemove f 305 else fail $ "File "++fn2fp f++" does not exist." 306 307 smRemoveDirectory :: FileName -> SlurpMonad () 308 smRemoveDirectory f = 309 do exists <- mDoesDirectoryExist f 310 if exists then smRemove f 311 else fail $ "Directory "++fn2fp f++" does not exist." 312 313 -- | Here are a few access functions. 314 slurp_name (Slurpy n _) = fn2fp n 315 slurp_fn :: Slurpy -> FileName 316 slurp_fn (Slurpy n _) = n 317 slurp_setname :: FileName -> Slurpy -> Slurpy 318 slurp_setname f (Slurpy _ s) = Slurpy f s 319 320 is_file (Slurpy _ (SlurpDir _ _)) = False 321 is_file (Slurpy _ (SlurpFile _ _)) = True 322 323 is_dir (Slurpy _ (SlurpDir _ _)) = True 324 is_dir (Slurpy _ (SlurpFile _ _)) = False 325 326 get_filecontents (Slurpy _ (SlurpFile _ c)) = c 327 get_filecontents _ = bug "Can't get_filecontents on SlurpDir." 328 329 get_dircontents (Slurpy _ (SlurpDir _ c)) = map_to_slurpies c 330 get_dircontents _ = bug "Can't get_dircontents on SlurpFile." 331 332 get_mtime (Slurpy _ (SlurpFile (_,t,_) _)) = t 333 get_mtime _ = bug "can't get_mtime on SlurpDir." 334 get_length (Slurpy _ (SlurpFile (_,_,l) _)) = l 335 get_length _ = bug "can't get_length on SlurpDir." 336 337 undefined_time :: EpochTime 338 undefined_time = -1 339 undefined_size :: FileOffset 340 undefined_size = -1 341 undef_time_size :: (Maybe String, EpochTime, FileOffset) 342 undef_time_size = (Nothing, undefined_time, undefined_size) 343 344 wait_a_moment :: IO () 345 wait_a_moment = do { sleep 1; return () } 346 -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it 347 -- returns an integer just like sleep(3) does. To stay compatible 348 -- with older versions, though, we just ignore sleep's return 349 -- value. Hackery, like I said. 350 351 isFileReallySymlink :: FilePath -> IO Bool 352 isFileReallySymlink f = do fs <- getSymbolicLinkStatus f 353 return (isSymbolicLink fs) 354 355 doesFileReallyExist :: FilePath -> IO Bool 356 doesFileReallyExist f = do fs <- getSymbolicLinkStatus f 357 return (isRegularFile fs) 358 359 doesDirectoryReallyExist :: FilePath -> IO Bool 360 doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f 361 return (isDirectory fs) 362 363 -- |slurp is how we get a slurpy in the first place\ldots 364 slurp = slurp_unboring (\_->True) . toPath 365 mmap_slurp d = do canmmap <- can_I_use_mmap 366 if canmmap then genslurp True (\_->True) d 367 else genslurp False (\_->True) d 368 slurp_unboring = genslurp False 369 genslurp :: Bool -> (FilePath -> Bool) 370 -> FilePath -> IO Slurpy 371 genslurp usemm nb dirname = do 372 isdir <- doesDirectoryExist dirname 373 ms <- if isdir 374 then withCurrentDirectory dirname $ 375 do actualname <- getCurrentDirectory 376 genslurp_helper usemm nb (reverse actualname) "" "." 377 else do former_dir <- getCurrentDirectory 378 genslurp_helper usemm nb (reverse former_dir) "" dirname 379 case ms of 380 Just s -> return s 381 Nothing -> fail $ "Unable to read directory " ++ dirname ++ 382 " (it appears to be neither file nor directory)" 383 384 unsafeInterleaveMapIO :: (a -> IO b) -> [a] -> IO [b] 385 unsafeInterleaveMapIO _ [] = return [] 386 unsafeInterleaveMapIO f (x:xs) 387 = do x' <- f x 388 xs' <- unsafeInterleaveIO $ unsafeInterleaveMapIO f xs 389 return (x':xs') 390 391 genslurp_helper :: Bool -> (FilePath -> Bool) 392 -> FilePath -> String -> String -> IO (Maybe Slurpy) 393 genslurp_helper usemm nb formerdir fullpath dirname = do 394 fs <- getSymbolicLinkStatus fulldirname 395 if isRegularFile fs 396 then do let mtime = (Nothing, modificationTime fs, fileSize fs) 397 ls <- unsafeInterleaveIO $ myReadFileLinesPSetc fulldirname 398 return $ Just $ Slurpy (fp2fn dirname) $ SlurpFile mtime ls 399 else if isDirectory fs || (isSymbolicLink fs && dirname == ".") 400 then do sl <- unsafeInterleaveIO $ 401 do fnames <- getDirectoryContents fulldirname 402 unsafeInterleaveMapIO 403 (\f -> genslurp_helper usemm nb fulldirname' 404 (fullpath///f) f) 405 $ filter (nb . (fullpath///)) $ filter not_hidden fnames 406 return $ Just $ Slurpy (fp2fn dirname) $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl 407 else return Nothing 408 where fulldirname' = formerdir\\\dirname 409 fulldirname = reverse fulldirname' 410 myReadFileLinesPSetc = if usemm then mmapFilePS 411 else B.readFile 412 413 not_hidden :: FilePath -> Bool 414 not_hidden "." = False 415 not_hidden ".." = False 416 not_hidden _ = True 417 418 (\\\) :: FilePath -> FilePath -> FilePath 419 (\\\) "" d = d 420 (\\\) d "." = d 421 (\\\) d subdir = reverse subdir ++ "/" ++ d 422 423 (///) :: FilePath -> FilePath -> FilePath 424 (///) "" d = d 425 (///) d "." = d 426 (///) d subdir = d ++ "/" ++ subdir 427 428 co_slurp :: Slurpy -> FilePath -> IO Slurpy 429 co_slurp guide dirname = do 430 isdir <- doesDirectoryExist dirname 431 if isdir 432 then withCurrentDirectory dirname $ do 433 actualname <- getCurrentDirectory 434 Just slurpy <- co_slurp_helper (reverse actualname) guide 435 return slurpy 436 else error "Error coslurping!!! Please report this." 437 438 co_slurp_helper :: FilePath -> Slurpy -> IO (Maybe Slurpy) 439 co_slurp_helper former_dir (Slurpy d (SlurpDir _ c)) = unsafeInterleaveIO $ do 440 let d' = fn2fp d 441 fn' = former_dir\\\d' 442 fn = reverse fn' 443 efs <- tryNonSignal $ getSymbolicLinkStatus fn 444 case efs of 445 Right fs 446 | isDirectory fs || (isSymbolicLink fs && d' == ".") -> 447 do sl <- unsafeInterleaveIO 448 $ unsafeInterleaveMapIO (co_slurp_helper fn') (map_to_slurpies c) 449 return $ Just $ Slurpy d $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl 450 _ -> return Nothing 451 co_slurp_helper former_dir (Slurpy f (SlurpFile _ _)) = unsafeInterleaveIO $ do 452 let fn' = former_dir\\\fn2fp f 453 fn = reverse fn' 454 efs <- tryNonSignal $ getSymbolicLinkStatus fn 455 case efs of 456 Right fs 457 | isRegularFile fs -> 458 do let mtime = (Nothing, modificationTime fs, fileSize fs) 459 ls <- unsafeInterleaveIO $ B.readFile fn 460 return $ Just $ Slurpy f $ SlurpFile mtime ls 461 _ -> return Nothing 462 463 get_slurp_context_generic :: (Slurpy -> a) -> (a -> [Slurpy]) -> FileName -> Slurpy -> Maybe (a -> a, Slurpy) 464 get_slurp_context_generic h1 h2 fn0 s0 = 465 let norm_fn0 = norm_path fn0 in 466 if norm_fn0 == empty 467 then Just (id, s0) 468 else slurp_context_private norm_fn0 id s0 469 where 470 slurp_context_private f ctx s@(Slurpy f' (SlurpFile _ _)) = 471 if f == f' then Just (ctx, s) 472 else Nothing 473 slurp_context_private f ctx s@(Slurpy d (SlurpDir _ c)) 474 | f == d = Just (ctx, s) 475 | d == dot = 476 case break_on_dir f of 477 Just (dn,fn) | dn == dot -> 478 descend fn 479 _ -> 480 descend f 481 | otherwise = 482 case break_on_dir f of 483 Just (dn,fn) -> 484 if dn == d 485 then descend fn 486 else Nothing 487 _ -> Nothing 488 where 489 descend fname = 490 case findSubSlurpy fname c of 491 Nothing -> Nothing 492 Just this -> slurp_context_private 493 fname 494 (ctx . h1 . Slurpy d . SlurpDir Nothing . foldr (uncurry Map.insert) (Map.delete (slurp_fn this) c) . map slurpy_to_pair . h2) 495 this 496 497 dot = fp2fn "." 498 empty = fp2fn "" 499 500 -- |get_slurp_context navigates to a specified filename in the given slurpy, 501 -- and returns the child slurpy at that point together with a update function that can be used 502 -- to reconstruct the original slurpy from a replacement value for the child slurpy. 503 get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy) 504 get_slurp_context = get_slurp_context_generic id return 505 506 -- |A variant of 'get_slurp_context' that allows for removing the child slurpy 507 -- altogether by passing in 'Nothing' to the update function. 508 -- If the child slurpy happened to be at the top level and 'Nothing' was passed in, 509 -- then the result of the update function will also be 'Nothing', otherwise it will always 510 -- be a 'Just' value. 511 get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy) 512 get_slurp_context_maybe = get_slurp_context_generic Just maybeToList 513 514 -- |A variant of 'get_slurp_context' that allows for replacing the child slurpy by 515 -- a list of slurpies. The result of the update function will always be a singleton 516 -- list unless the child slurpy was at the top level. 517 -- Currently unused. 518 -- get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy) 519 -- get_slurp_context_list = get_slurp_context_generic return id 520 521 -- | It is important to be able to readily modify a slurpy. 522 slurp_remove :: FileName -> Slurpy -> Maybe Slurpy 523 slurp_remove fname s@(Slurpy _ (SlurpDir _ _)) = 524 case get_slurp_context_maybe fname s of 525 Just (ctx, _) -> ctx Nothing 526 Nothing -> Nothing 527 slurp_remove _ _ = bug "slurp_remove only acts on SlurpDirs" 528 529 slurp_removefile :: FileName -> Slurpy -> Maybe Slurpy 530 slurp_removefile f s = 531 if slurp_hasfile f s 532 then case slurp_remove f s of 533 s'@(Just (Slurpy _ (SlurpDir _ _))) -> s' 534 _ -> impossible 535 else Nothing 536 537 slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy 538 slurp_move f f' s = 539 if not (slurp_has (fn2fp f') s) && slurp_hasdir (super_name f') s 540 then case get_slurp f s of 541 Nothing -> Nothing 542 Just sf -> 543 case slurp_remove f s of 544 Nothing -> Nothing 545 Just (s'@(Slurpy _ (SlurpDir _ _))) -> 546 Just $ addslurp f' (slurp_setname (own_name f') sf) s' 547 _ -> impossible 548 else Nothing 549 550 addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy 551 addslurp fname s s' = 552 case get_slurp_context (super_name fname) s' of 553 Just (ctx, Slurpy d (SlurpDir _ c)) -> ctx (Slurpy d (SlurpDir Nothing (uncurry Map.insert (slurpy_to_pair s) c))) 554 _ -> s' 555 556 get_slurp :: FileName -> Slurpy -> Maybe Slurpy 557 get_slurp f s = fmap snd (get_slurp_context f s) 558 559 slurp_removedir :: FileName -> Slurpy -> Maybe Slurpy 560 slurp_removedir f s = 561 case get_slurp f s of 562 Just (Slurpy _ (SlurpDir _ l)) | Map.null l -> 563 case slurp_remove f s of 564 s'@(Just (Slurpy _ (SlurpDir _ _))) -> s' 565 _ -> impossible 566 _ -> Nothing 567 568 slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy 569 slurp_adddir f s = 570 if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s) 571 then Nothing 572 else Just $ addslurp f (Slurpy (own_name f) (SlurpDir Nothing Map.empty)) s 573 574 -- |Code to modify a given file in a slurpy. 575 slurp_modfile :: FileName -> (FileContents -> Maybe FileContents) 576 -> Slurpy -> Maybe Slurpy 577 slurp_modfile fname modify sl = 578 case get_slurp_context fname sl of 579 Just (ctx, Slurpy ff (SlurpFile _ c)) -> 580 case modify c of 581 Nothing -> Nothing 582 Just c' -> Just (ctx (Slurpy ff (SlurpFile undef_time_size c'))) 583 _ -> 584 Nothing 585 586 slurp_hasfile :: FileName -> Slurpy -> Bool 587 slurp_hasfile f s = 588 case get_slurp f s of 589 Just s' | is_file s' -> True 590 _ -> False 591 592 slurp_has :: FilePath -> Slurpy -> Bool 593 slurp_has f s = isJust (get_slurp (fp2fn f) s) 594 595 slurp_has_anycase :: FilePath -> Slurpy -> Bool 596 slurp_has_anycase fname s = 597 seq normed_name $ isJust $ get_slurp normed_name $ mapSlurpyNames tolower s 598 where normed_name = norm_path $ fp2fn $ map toLower fname 599 600 tolower :: FileName -> FileName 601 tolower = fp2fn . (map toLower) . fn2fp 602 603 findSubSlurpy :: FileName -> SlurpyMap -> Maybe Slurpy 604 findSubSlurpy fn sm = 605 let topname = case break_on_dir fn of 606 Just (dn, _) -> dn 607 Nothing -> fn 608 in fmap (Slurpy topname) (Map.lookup topname sm) 609 610 slurp_hasdir :: FileName -> Slurpy -> Bool 611 slurp_hasdir d _ | norm_path d == fp2fn "" = True 612 slurp_hasdir f (Slurpy _ (SlurpDir _ c)) = 613 seq f $ let f' = norm_path f 614 in case findSubSlurpy f' c of 615 Just s -> slurp_hasdir_private f' s 616 Nothing -> False 617 slurp_hasdir _ _ = False 618 619 slurp_hasdir_private :: FileName -> Slurpy -> Bool 620 slurp_hasdir_private _ (Slurpy _ (SlurpFile _ _)) = False 621 slurp_hasdir_private f (Slurpy d (SlurpDir _ c)) 622 | f == d = True 623 | otherwise = 624 case break_on_dir f of 625 Just (dn,fn) -> 626 if dn == d 627 then case findSubSlurpy fn c of 628 Just s -> slurp_hasdir_private fn s 629 Nothing -> False 630 else False 631 _ -> False 632 633 get_path_list :: Slurpy -> FilePath -> [FilePath] 634 get_path_list s fp = get_path_list' s ("./" ++ fp) 635 636 get_path_list' :: Slurpy -> FilePath -> [FilePath] 637 get_path_list' s "" = list_slurpy s 638 get_path_list' (Slurpy f (SlurpFile _ _)) fp 639 | f' == fp = [f'] 640 where f' = fn2fp f 641 get_path_list' (Slurpy d (SlurpDir _ ss)) fp 642 | (d' ++ "/") `isPrefixOf` (fp ++ "/") 643 = let fp' = drop (length d' + 1) fp 644 in map (d' ///) $ concatMap (\s -> get_path_list' s fp') $ map_to_slurpies ss 645 where d' = fn2fp d 646 get_path_list' _ _ = [] 647 648 list_slurpy :: Slurpy -> [FilePath] 649 list_slurpy (Slurpy f (SlurpFile _ _)) = [fn2fp f] 650 list_slurpy (Slurpy dd (SlurpDir _ ss)) = d : map (d ///) (concatMap list_slurpy (map_to_slurpies ss)) 651 where d = fn2fp dd 652 653 list_slurpy_files :: Slurpy -> [FilePath] 654 list_slurpy_files (Slurpy f (SlurpFile _ _)) = [fn2fp f] 655 list_slurpy_files (Slurpy dd (SlurpDir _ ss)) = 656 map ((fn2fp dd) ///) (concatMap list_slurpy_files (map_to_slurpies ss)) 657 658 list_slurpy_dirs :: Slurpy -> [FilePath] 659 list_slurpy_dirs (Slurpy _ (SlurpFile _ _)) = [] 660 list_slurpy_dirs (Slurpy dd (SlurpDir _ ss)) = 661 d : map (d ///) (concatMap list_slurpy_dirs (map_to_slurpies ss)) 662 where d = fn2fp dd 663 664 unsyncedSlurpySize :: Slurpy -> Int 665 unsyncedSlurpySize (Slurpy _ (SlurpFile (_,_,size) ps)) 666 | size == undefined_size = B.length ps 667 | otherwise = 0 668 unsyncedSlurpySize (Slurpy _ (SlurpDir _ ss)) = 669 sum $ map unsyncedSlurpySize (map_to_slurpies ss) 670 671 slurp_sync_size :: Int 672 slurp_sync_size = 100 * 1000000 673 674 syncSlurpy :: (Slurpy -> IO Slurpy) -> Slurpy -> IO Slurpy 675 syncSlurpy put s = if unsyncedSlurpySize s > slurp_sync_size 676 then put s 677 else return s