src/Darcs/Repository/Cache.lhs

   1 \begin{code}
   2 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
   3 {-# LANGUAGE CPP #-}
   4
   5 #include "gadts.h"
   6
   7 module Darcs.Repository.Cache (
   8                    cacheHash, okayHash, takeHash,
   9                    Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..),
  10                    HashedDir(..), hashedDir,
  11                    unionCaches, cleanCaches, cleanCachesWithHint,
  12                    fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,
  13                    findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache,
  14                    repo2cache
  15                  ) where
  16
  17 import Control.Monad ( liftM, when, guard )
  18 import Data.List ( nub )
  19 import Data.Maybe ( listToMaybe )
  20 import System.Directory ( removeFile, doesFileExist, getDirectoryContents )
  21 import System.Posix ( setFileTimes )
  22 import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus )
  23 import System.Posix.Types ( EpochTime )
  24 import System.IO ( hPutStrLn, stderr )
  25
  26 import Crypt.SHA256 ( sha256sum )
  27
  28 import ByteStringUtils ( gzWriteFilePS, linesPS )
  29 import qualified Data.ByteString as B (length, drop, ByteString )
  30 import qualified Data.ByteString.Char8 as BC (unpack)
  31
  32 import SHA1 ( sha1PS )
  33 import System.Posix.Files ( createLink )
  34 import System.Directory ( createDirectoryIfMissing )
  35
  36 import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl,
  37                         Cachable( Cachable ) )
  38 import Darcs.Flags ( Compression( .. ) )
  39 import Darcs.Global ( darcsdir )
  40 import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS )
  41 import Darcs.Progress ( progressList, debugMessage, debugFail )
  42 import Darcs.SlurpDirectory ( undefined_time )
  43 import Darcs.URL ( is_file )
  44 import Darcs.Utils ( withCurrentDirectory, catchall )
  45
  46 \end{code}
  47
  48 \begin{code}
  49 data HashedDir = HashedPristineDir | HashedPatchesDir | HashedInventoriesDir
  50 hashedDir :: HashedDir -> String
  51 hashedDir HashedPristineDir = "pristine.hashed"
  52 hashedDir HashedPatchesDir = "patches"
  53 hashedDir HashedInventoriesDir = "inventories"
  54
  55 data WritableOrNot = Writable | NotWritable deriving ( Show )
  56 data CacheType = Repo | Directory deriving ( Eq, Show )
  57 data CacheLoc = Cache !CacheType !WritableOrNot !String
  58 newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache
  59
  60 instance Eq CacheLoc where
  61     (Cache Repo _ a) == (Cache Repo _ b) = a == b
  62     (Cache Directory _ a) == (Cache Directory _ b) = a == b
  63     _ == _ = False
  64 instance Show CacheLoc where
  65     show (Cache Repo Writable a) = "thisrepo:" ++ a
  66     show (Cache Repo NotWritable a) = "repo:" ++ a
  67     show (Cache Directory Writable a) = "cache:" ++ a
  68     show (Cache Directory NotWritable a) = "readonly:" ++ a
  69 instance Show Cache where
  70     show (Ca cs) = unlines $ map show cs
  71
  72 unionCaches :: Cache -> Cache -> Cache
  73 unionCaches (Ca a) (Ca b) = Ca (nub (a++b))
  74
  75 repo2cache :: String -> Cache
  76 repo2cache r = Ca [Cache Repo NotWritable r]
  77
  78 -- This function computes the cache hash (i.e. filename) of a packed string.
  79 cacheHash :: B.ByteString -> String
  80 cacheHash ps = case show (B.length ps) of
  81                  x | l > 10 -> sha256sum ps
  82                    | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps
  83                                         where l = length x
  84
  85 okayHash :: String -> Bool
  86 okayHash s = length s == 40 || length s == 64 || length s == 75
  87
  88 takeHash :: B.ByteString -> Maybe (String, B.ByteString)
  89 takeHash ps = do h <- listToMaybe $ linesPS ps
  90                  let v = BC.unpack h
  91                  guard $ okayHash v
  92                  Just (v, B.drop (B.length h) ps)
  93
  94 checkHash :: String -> B.ByteString -> Bool
  95 checkHash h s | length h == 40 = sha1PS s == h
  96               | length h == 64 = sha256sum s == h
  97               | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h
  98               | otherwise = False
  99
 100
 101 findFileMtimeUsingCache :: Cache -> HashedDir -> String -> IO EpochTime
 102 findFileMtimeUsingCache (Ca cache) subdir f = mt cache
 103     where mt [] = return undefined_time
 104           mt (Cache Repo Writable r:_) = (modificationTime `fmap`
 105                                           getSymbolicLinkStatus (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f))
 106                                          `catchall` return undefined_time
 107           mt (_:cs) = mt cs
 108
 109 setFileMtimeUsingCache :: Cache -> HashedDir -> String -> EpochTime -> IO ()
 110 setFileMtimeUsingCache (Ca cache) subdir f t = st cache
 111     where st [] = return ()
 112           st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f) t t
 113                                          `catchall` return ()
 114           st (_:cs) = st cs
 115
 116 fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString)
 117 fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere
 118
 119 writable :: CacheLoc -> Bool
 120 writable (Cache _ NotWritable _) = False
 121 writable (Cache _ Writable _) = True
 122
 123 hashedFilePath :: CacheLoc -> HashedDir -> String -> String
 124 hashedFilePath (Cache Directory _ d) s f = d ++ "/" ++ (hashedDir s) ++ "/" ++ f
 125 hashedFilePath (Cache Repo _ r) s f =
 126     r ++ "/"++darcsdir++"/" ++ (hashedDir s) ++ "/" ++ f
 127
 128 peekInCache :: Cache -> HashedDir -> String -> IO Bool
 129 peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False
 130     where cacheHasIt [] = return False
 131           cacheHasIt (c:cs) | not $ writable c = cacheHasIt cs
 132                             | otherwise = do ex <- doesFileExist $ fn c
 133                                              if ex then return True
 134                                                    else cacheHasIt cs
 135           fn c = hashedFilePath c subdir f
 136
 137 -- |Note that the file is likely to be useful soon: pipelined downloads will
 138 -- add it to the (low-priority) queue, for the rest it is a noop.
 139 speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()
 140 speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h
 141                                     copyFileUsingCache OnlySpeculate c sd h
 142
 143 data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq )
 144
 145 copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()
 146 copyFileUsingCache oos (Ca cache) subdir f =
 147     do debugMessage $ "I'm doing copyFileUsingCache on "++(hashedDir subdir)++"/"++f
 148        Just stickItHere <- cacheLoc cache
 149        createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere)
 150        sfuc cache stickItHere
 151     `catchall` return ()
 152     where cacheLoc [] = return Nothing
 153           cacheLoc (c:cs) | not $ writable c = cacheLoc cs
 154                           | otherwise =
 155               do ex <- doesFileExist $ fn c
 156                  if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache"
 157                        else do othercache <- cacheLoc cs
 158                                case othercache of Just x -> return $ Just x
 159                                                   Nothing -> return $ Just (fn c)
 160           sfuc [] _ = return ()
 161           sfuc (c:cs) out | not $ writable c =
 162               if oos == OnlySpeculate
 163                  then speculateFileOrUrl (fn c) out
 164                  else copyFileOrUrl [] (fn c) out Cachable
 165                           | otherwise = sfuc cs out
 166           fn c = hashedFilePath c subdir f
 167
 168
 169 data FromWhere = LocalOnly | Anywhere deriving ( Eq )
 170
 171 fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String -> IO (String, B.ByteString)
 172 fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f =
 173     do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f
 174        ffuc cache
 175     `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++(hashedDir subdir)++
 176                           " from sources:\n\n"++show (Ca cache))
 177     where ffuc (c:cs)
 178            | not (writable c) && (Anywhere == fromWhere || is_file (fn c)) =
 179               do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually"
 180                  debugMessage $ "    getting "++f
 181                  debugMessage $ "    from " ++ fn c
 182                  x <- gzFetchFilePS (fn c) Cachable
 183                  if not $ checkHash f x
 184                     then do x' <- fetchFilePS (fn c) Cachable
 185                             when (not $ checkHash f x') $
 186                                  do hPutStrLn stderr $ "Hash failure in " ++ fn c
 187                                     fail $ "Hash failure in " ++ fn c
 188                             return (fn c, x')
 189                     else return (fn c, x) -- FIXME: create links in caches
 190               `catchall` ffuc cs
 191
 192            | writable c =
 193               do x1 <- gzFetchFilePS (fn c) Cachable
 194                  x <- if not $ checkHash f x1
 195                       then do x2 <- fetchFilePS (fn c) Cachable
 196                               when (not $ checkHash f x2) $
 197                                  do hPutStrLn stderr $ "Hash failure in " ++ fn c
 198                                     removeFile $ fn c
 199                                     fail $ "Hash failure in " ++ fn c
 200                               return x2
 201                       else return x1
 202                  mapM_ (tryLinking (fn c)) cs
 203                  return (fn c, x)
 204               `catchall` do (fname,x) <- ffuc cs
 205                             do createCache c subdir
 206                                createLink fname (fn c)
 207                                return (fn c, x)
 208                              `catchall`
 209                              do gzWriteFilePS (fn c) x `catchall` return ()
 210                                 return (fname,x)
 211            | otherwise = ffuc cs
 212
 213           ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache)
 214
 215           tryLinking ff c@(Cache Directory Writable d) =
 216               do createDirectoryIfMissing False (d++"/"++(hashedDir subdir))
 217                  createLink ff (fn c)
 218               `catchall` return ()
 219           tryLinking _ _ = return ()
 220           fn c = hashedFilePath c subdir f
 221
 222 createCache :: CacheLoc -> HashedDir -> IO ()
 223 createCache (Cache Directory _ d) subdir =
 224     createDirectoryIfMissing True (d ++ "/" ++ (hashedDir subdir))
 225 createCache _ _ = return ()
 226
 227 write :: Compression -> String -> B.ByteString -> IO ()
 228 write NoCompression = writeAtomicFilePS
 229 write GzipCompression = gzWriteAtomicFilePS
 230
 231 writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString -> IO String
 232 writeFileUsingCache (Ca cache) compr subdir ps =
 233     (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall`
 234     wfuc cache `catchall`
 235          debugFail ("Couldn't write `"++hash++"'\nin subdir "++(hashedDir subdir)++" to sources:\n\n"++
 236                     show (Ca cache))
 237     where hash = cacheHash ps
 238           wfuc (c:cs) | not $ writable c = wfuc cs
 239                       | otherwise = do createCache c subdir
 240                                        write compr (fn c) ps -- FIXME: create links in caches
 241                                        return hash
 242           wfuc [] = debugFail $ "No location to write file `" ++ (hashedDir subdir) ++"/"++hash ++ "'"
 243           fn c = hashedFilePath c subdir hash
 244
 245 cleanCaches :: Cache -> HashedDir -> IO ()
 246 cleanCaches c d = cleanCachesWithHint' c d Nothing
 247
 248 cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()
 249 cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h)
 250
 251 cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()
 252 cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs
 253     where cleanCache (Cache Directory Writable d) =
 254              (withCurrentDirectory (d++"/"++(hashedDir subdir)) $
 255               do fs' <- getDirectoryContents "."
 256                  let fs = case hint of
 257                             Just h -> h
 258                             Nothing -> fs'
 259                  mapM_ clean $ progressList ("Cleaning cache "++d++"/"++(hashedDir subdir)) $
 260                        filter okayHash fs) `catchall` return ()
 261           cleanCache _ = return ()
 262           clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f
 263                        when (lc < 2) $ removeFile f
 264                     `catchall` return ()
 265
 266 \end{code}
 267