diff --git a/examples/mini/Cache.hs b/examples/mini/Cache.hs new file mode 100644 --- /dev/null +++ b/examples/mini/Cache.hs @@ -0,0 +1,19 @@ +module Main +where + +import Text.XML.HXT.Arrow hiding (readDocument) +import Text.XML.HXT.Arrow.XmlCache + +main = runX ( readDocument [ (a_parse_html, v_1) + , (a_issue_warnings, v_0) + , (a_remove_whitespace, v_1) + , (a_cache, "/tmp") + , (a_document_age, "60") + , (a_trace, "2") + ] "http://www.fh-wedel.de/" + >>> + processChildren (hasName "html" /> hasName "body" >>> deep isText) + >>> + writeDocument [] "" + ) + >> return () diff --git a/hxt-cache.cabal b/hxt-cache.cabal --- a/hxt-cache.cabal +++ b/hxt-cache.cabal @@ -1,5 +1,5 @@ name: hxt-cache -version: 0.0.1 +version: 0.0.3 license: OtherLicense license-file: LICENCE maintainer: Uwe Schmidt @@ -16,10 +16,12 @@ extra-source-files: test/TestXmlCache.hs + examples/mini/Cache.hs library exposed-modules: Text.XML.HXT.Arrow.XmlCache + Control.Concurrent.ResourceTable hs-source-dirs: src ghc-options: -Wall @@ -27,11 +29,15 @@ build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 1, binary >= 0.5 && < 1, + containers >= 0.3 && < 1, + deepseq >= 1.1 && < 2, directory >= 1 && < 2, filepath >= 1.1 && < 2, haskell98 >= 1 && < 2, - hxt >= 8.2 && < 9, + hxt >= 8.5 && < 9, hxt-binary >= 0 && < 1, + old-locale >= 1 && < 2, old-time >= 1 && < 2, + unix >= 2.4 && < 3, SHA >= 1.4 && < 2 diff --git a/src/Control/Concurrent/ResourceTable.hs b/src/Control/Concurrent/ResourceTable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/ResourceTable.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- + +module Control.Concurrent.ResourceTable +where + +import Control.Concurrent.MVar + +import qualified Data.Map as M +import Data.Maybe + +----------------------------------------------------------------------------- + +type ResourceTable a = MVar (M.Map a ResourceLock) +type ResourceLock = (MVar (), Int) + +----------------------------------------------------------------------------- + +requestResource :: (Ord a) => ResourceTable a -> a -> IO () +requestResource theLocks r + = do + rt <- takeMVar theLocks + (lk, cnt) <- case M.lookup r rt of + Nothing -> do + lk' <- newMVar () + return (lk', 0) + Just l -> return l + putMVar theLocks $ M.insert r (lk, cnt + 1) rt + takeMVar lk + +releaseResource :: (Ord a) => ResourceTable a -> a -> IO () +releaseResource theLocks r + = do + rt <- takeMVar theLocks + let (lk, cnt) = fromJust . M.lookup r $ rt + putMVar theLocks $ if cnt == 1 + then M.delete r rt + else M.insert r (lk, cnt - 1) rt + putMVar lk () + +newResourceTable :: IO (ResourceTable a) +newResourceTable = newMVar M.empty + +----------------------------------------------------------------------------- diff --git a/src/Text/XML/HXT/Arrow/XmlCache.hs b/src/Text/XML/HXT/Arrow/XmlCache.hs --- a/src/Text/XML/HXT/Arrow/XmlCache.hs +++ b/src/Text/XML/HXT/Arrow/XmlCache.hs @@ -29,6 +29,8 @@ ) where +import Control.DeepSeq +import Control.Concurrent.ResourceTable import Control.Exception ( SomeException , try ) import Data.Binary @@ -41,10 +43,13 @@ import System.FilePath import System.Directory import System.IO +import System.Locale +import System.Posix ( touchFile ) import System.Time +import System.IO.Unsafe ( unsafePerformIO ) import Text.XML.HXT.Arrow hiding ( readDocument ) -import qualified Text.XML.HXT.Arrow as X +import qualified Text.XML.HXT.Arrow -- as X import Text.XML.HXT.Arrow.Binary import Text.XML.HXT.DOM.Binary @@ -66,7 +71,7 @@ -- The function is controlled by the options 'a_cache', 'a_compress' and 'a_document_age'. -- -- * 'a_cache': the document tree of the document read is cached in the directory given by this option, --- or, if it is read before and it is not too old, see 'a_document_age', it is read from the +-- or, if it is read before and it is not out of date, see 'a_document_age', it is read from the -- cache. The document is stored in binary format (used package: binary). -- -- - 'a_compress' : controls whether the cache contents is compressed with the bzip2 lib for saving space @@ -83,27 +88,8 @@ readDocument' :: Attributes -> String -> IOStateArrow s b XmlTree readDocument' userOptions src - | withCache = ( traceMsg 1 ("looking up document " ++ show src ++ " in cache") - >>> - lookupCache cacheConfig src - >>> - traceMsg 1 "cache hit" - ) - `orElse` - ( traceMsg 1 "cache miss, reading original document" - >>> - X.readDocument userOptions src - >>> - perform ( ( writeCache cacheConfig src - >>> - none - ) - `when` - documentStatusOk - ) - ) - | otherwise = X.readDocument userOptions src - + | withCache = applyA $ arrIO0 (lookupCache' cacheConfig userOptions src) + | otherwise = Text.XML.HXT.Arrow.readDocument userOptions src where options = addEntries userOptions defaultOptions @@ -131,40 +117,139 @@ , c_age :: Integer } -lookupCache :: (Binary b) => CacheConfig -> String -> IOStateArrow s a b -lookupCache cc f = isIOA (const $ cacheHit cc cf) +lookupCache' :: CacheConfig -> Attributes -> String -> IO (IOStateArrow s a XmlTree) +lookupCache' cc os src = do + ch <- cacheHit cc cf + return $ + case ch of + Nothing -> readAndCacheDocument + Just Nothing -> readDocumentFromCache + Just (Just mt) -> readDocumentCond mt + where + cf = uncurry () $ cacheFile cc src + + readDocumentFromCache + = traceMsg 1 ("cache hit for " ++ show src ++ " reading " ++ show cf) + >>> + ( readCache cc cf + >>> + traceMsg 1 "cache read" + ) + `orElse` + ( clearErrStatus + >>> + traceMsg 1 "cache file was corrupted, reading original" + >>> + readAndCacheDocument + ) + readAndCacheDocument + = traceMsg 1 ("cache miss, reading original document " ++ show src) + >>> + Text.XML.HXT.Arrow.readDocument os src + >>> + perform ( choiceA + [ is200 :-> ( writeCache cc src >>> none ) + , this :-> traceMsg 1 "transfer status /= 200, page not cached" + ] + ) + where + is200 = hasAttrValue transferStatus (== "200") + + readDocumentCond mt + = traceMsg 1 ("cache out of date, read original document if modified " ++ show src) + >>> + Text.XML.HXT.Arrow.readDocument (addEntries (condOpts mt) os) src + >>> + choiceA + [ is304 :-> ( traceMsg 1 ("document not modified, using cache data from " ++ show cf) + >>> + perform (arrIO0 $ touchFile cf) + >>> + readDocumentFromCache + ) + , documentStatusOk :-> ( traceMsg 1 "document read and cache updated" + >>> + perform (writeCache cc src) + ) + , this :-> ( traceMsg 1 "document read without caching" + >>> + perform ( arrIO0 $ remFile cf ) + ) + ] + where + is304 = hasAttrValue transferStatus (== "304") + condOpts t = [("curl--header", "If-Modified-Since: " ++ fmtTime t)] + -- [(a_if_modified_since, fmtTime t)] + fmtTime = formatCalendarTime defaultTimeLocale rfc822DateFormat . toUTCTime + +-- ------------------------------------------------------------ + +lookupCache :: (NFData b, Binary b) => CacheConfig -> String -> IOStateArrow s a b +lookupCache cc f = isIOA (const $ hit) `guards` - readBinaryValue (c_compress cc) cf + readCache cc cf where cf = uncurry () $ cacheFile cc f + hit = do + ch <- cacheHit cc cf + return $ case ch of + Just Nothing -> True + _ -> False +-- ------------------------------------------------------------ + +readCache :: (NFData c, Binary c) => CacheConfig -> String -> IOStateArrow s b c +readCache cc cf = withLock cf $ readBinaryValue (c_compress cc) cf + writeCache :: (Binary b) => CacheConfig -> String -> IOStateArrow s b () -writeCache cc f = perform (arrIO0 createDir) +writeCache cc f = traceMsg 1 ("writing cache file " ++ show f) >>> - writeBinaryValue (c_compress cc) hf + perform (arrIO0 createDir) + >>> + withLock hf (writeBinaryValue (c_compress cc) hf) >>> - perform (arrIO0 $ writeIndex cc f hf) + perform (withLock ixf (arrIO0 $ writeIndex ixf f hf)) where hf = dir file + ixf = c_dir cc "index" (dir, file) = cacheFile cc f createDir = createDirectoryIfMissing True dir +-- ------------------------------------------------------------ + +remFile :: FilePath -> IO () +remFile f = ( try' $ do ex <- doesFileExist f + if ex + then removeFile f + else return () + ) >> return () + +-- ------------------------------------------------------------ + cacheFile :: CacheConfig -> String -> (FilePath, FilePath) cacheFile cc f = (c_dir cc fd, fn) where (fd, fn) = splitAt 2 . sha1HashString $ f + +-- result interpretation for cacheHit +-- +-- Nothing : cache miss: get document +-- Just Nothing : cache hit, cache data valid: use cache data +-- Just (Just t) : cache hit, but cache data out of date: get document conditionally with if-modified-since t -cacheHit :: CacheConfig -> FilePath -> IO Bool +cacheHit :: CacheConfig -> FilePath -> IO (Maybe (Maybe ClockTime)) cacheHit cc hf = ( try' $ do e <- doesFileExist hf if not e - then return False + then return Nothing else do mt <- getModificationTime hf ct <- getClockTime - return $ (dt `addToClockTime` mt) >= ct - ) >>= return . either (const False) id + return . Just $ if (dt `addToClockTime` mt) >= ct + then Nothing + else Just mt + ) >>= return . either (const Nothing) id where age = c_age cc seconds = fromInteger $ age `mod` 60 @@ -174,10 +259,10 @@ try' :: IO a -> IO (Either SomeException a) try' = try -writeIndex :: CacheConfig -> String -> FilePath -> IO () -writeIndex cc f hf = ( try' $ +writeIndex :: String -> String -> FilePath -> IO () +writeIndex ixf f hf = ( try' $ do - h <- openBinaryFile (c_dir cc "index") AppendMode + h <- openBinaryFile ixf AppendMode hPutStrLn h $ show (hf, f) hClose h return () @@ -194,3 +279,26 @@ sha1HashString = arr $ showDigest . sha1 . encode -- ------------------------------------------------------------ + + +-- | the internal table of file locks + +theLockedFiles :: ResourceTable String +theLockedFiles = unsafePerformIO newResourceTable +{-# NOINLINE theLockedFiles #-} + +lockFile, unlockFile :: String -> IO () +lockFile = requestResource theLockedFiles +unlockFile = releaseResource theLockedFiles + +withLock :: String -> IOStateArrow s b c -> IOStateArrow s b c +withLock l a = ( perform (arrIO0 $ lockFile l) + >>> + listA a + >>> + perform (arrIO0 $ unlockFile l) + ) + >>> + unlistA + +----------------------------------------------------------------------------- diff --git a/test/TestXmlCache.hs b/test/TestXmlCache.hs --- a/test/TestXmlCache.hs +++ b/test/TestXmlCache.hs @@ -3,23 +3,31 @@ module Main -- TestXmlCache where +import Data.Maybe + +import System.Environment + import Text.XML.HXT.Arrow hiding ( readDocument ) import Text.XML.HXT.Arrow.XmlCache -main :: IO () -main = do - runX +main' :: String -> IO () +main' url = runX ( readDocument [ ( a_trace, v_1 ) , ( a_parse_html, v_1 ) , ( a_issue_warnings, v_0 ) , ( a_cache, "./cache" ) , ( a_document_age, "10" ) -- 10 sec., just for testing , ( a_compress, v_1 ) - ] "http://www.haskell.org/" + ] url >>> writeDocument [ ( a_indent, v_1 ) - ] "haskell.org.html" + ] "t.xml" ) - return () + >> return () + +main :: IO () +main = do + as <- getArgs + main' . fromMaybe "http://www.haskell.org/" . listToMaybe $ as -- -----------------------------------------------------------------------------