hxt-cache 0.0.1 → 0.0.3
raw patch · 5 files changed
+228/−44 lines, 5 filesdep +containersdep +deepseqdep +old-localedep ~hxt
Dependencies added: containers, deepseq, old-locale, unix
Dependency ranges changed: hxt
Files
- examples/mini/Cache.hs +19/−0
- hxt-cache.cabal +8/−2
- src/Control/Concurrent/ResourceTable.hs +43/−0
- src/Text/XML/HXT/Arrow/XmlCache.hs +144/−36
- test/TestXmlCache.hs +14/−6
+ examples/mini/Cache.hs view
@@ -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 ()
hxt-cache.cabal view
@@ -1,5 +1,5 @@ name: hxt-cache-version: 0.0.1+version: 0.0.3 license: OtherLicense license-file: LICENCE maintainer: Uwe Schmidt <uwe@fh-wedel.de>@@ -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
+ src/Control/Concurrent/ResourceTable.hs view
@@ -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++-----------------------------------------------------------------------------
src/Text/XML/HXT/Arrow/XmlCache.hs view
@@ -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+ +-----------------------------------------------------------------------------
test/TestXmlCache.hs view
@@ -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 -- -----------------------------------------------------------------------------