hxt-cache 0.0.5 → 9.0.0

raw patch · 8 files changed

+299/−286 lines, 8 filesdep −hxt-binarydep ~hxtPVP ok

version bump matches the API change (PVP)

Dependencies removed: hxt-binary

Dependency ranges changed: hxt

API changes (from Hackage documentation)

Files

• LICENCE +0/−9
• LICENSE +9/−0
• examples/mini/Cache.hs +14/−9
• hxt-cache.cabal +17/−17
• src/Control/Concurrent/ResourceTable.hs +23/−21
• src/Text/XML/HXT/Arrow/XmlCache.hs +196/−215
• src/Text/XML/HXT/Cache.hs +25/−0
• test/TestXmlCache.hs +15/−15

@@ -1,9 +0,0 @@-The MIT License--Copyright (c) 2005 Uwe Schmidt, Martin Schmidt, Torben Kuseler--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.

@@ -0,0 +1,9 @@+The MIT License++Copyright (c) 2005 Uwe Schmidt, Martin Schmidt, Torben Kuseler++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.

@@ -1,18 +1,23 @@ module Main where -import Text.XML.HXT.Arrow hiding (readDocument)-import Text.XML.HXT.Arrow.XmlCache+import Text.XML.HXT.Core+import Text.XML.HXT.Curl+import Text.XML.HXT.Cache+import Codec.Compression.BZip (compress, decompress) -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")+main = runX ( readDocument [ withParseHTML yes+                           , withWarnings no+                           , withRemoveWS yes+                           , withCache "/tmp" 10 False			-- enable /tmp as cache dir+                                                                        -- documents remain valid 10 seconds (for testing)+                                                                        -- no 404 documents are cached+                           , withCompression (compress, decompress)     -- the cached files will be BZip compressed+                           , withTrace 2+                           , withCurl []                                -- curl is taken for HTTP access                            ] "http://www.fh-wedel.de/"               >>>-              processChildren (hasName "html" /> hasName "body" >>> deep isText)+              processChildren (hasName "html" /> hasName "body" //> isText)               >>>               writeDocument [] ""             )

@@ -1,18 +1,18 @@-name: hxt-cache-version: 0.0.5-license: OtherLicense-license-file: LICENCE-maintainer: Uwe Schmidt <uwe@fh-wedel.de>-stability: experimental-category: XML-synopsis: Cache for HXT XML Documents and other binary data-description: Extension for caching XML documents and other binary data in cache directory- of the local filesystem. The module exports a version of readDocument with the- additional cache functionality.-homepage: http://www.fh-wedel.de/~si/HXmlToolbox/index.html-copyright: Copyright (c) 2009 Uwe Schmidt-build-type: Simple-cabal-version: >=1.6+Name:           hxt-cache+Version:        9.0.0+Synopsis:       Cache for HXT XML Documents and other binary data+Description:    Extension for caching XML documents and other binary data in cache directory+                of the local filesystem.+License:        OtherLicense+License-file:   LICENSE+Author:         Uwe Schmidt+Maintainer:     Uwe Schmidt <uwe@fh-wedel.de>+Stability:      Stable+Category:       XML+Homepage:       http://www.fh-wedel.de/~si/HXmlToolbox/index.html+Copyright:      Copyright (c) 2010 Uwe Schmidt+Build-type:     Simple+Cabal-version:  >=1.6  extra-source-files:  test/TestXmlCache.hs@@ -20,6 +20,7 @@  library  exposed-modules:+  Text.XML.HXT.Cache   Text.XML.HXT.Arrow.XmlCache   Control.Concurrent.ResourceTable @@ -34,8 +35,7 @@                 directory  >= 1   && < 2,                 filepath   >= 1.1 && < 2,                 haskell98  >= 1   && < 2,-                hxt        >= 8.5 && < 9,-                hxt-binary >= 0   && < 1,+                hxt        >= 9   && < 10,                 old-locale >= 1   && < 2,                 old-time   >= 1   && < 2,                 unix       >= 2.3 && < 3,

@@ -5,39 +5,41 @@  import           Control.Concurrent.MVar -import qualified Data.Map                 	as M+import qualified Data.Map                       as M import           Data.Maybe  ----------------------------------------------------------------------------- -type ResourceTable a	= MVar (M.Map a ResourceLock)-type ResourceLock	= (MVar (), Int)+type ResourceTable a    = MVar (M.Map a ResourceLock)+type ResourceLock       = (MVar (), Int)  ----------------------------------------------------------------------------- -requestResource		:: (Ord a) => ResourceTable a -> a -> IO ()+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+                        = 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         :: (Ord a) => ResourceTable a -> a -> IO () releaseResource theLocks r-			= do-			  rt <- takeMVar theLocks-			  let (lk, cnt) = fromJust . M.lookup r $ rt+                        = 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+                                             then M.delete r rt+                                             else M.insert r (lk, cnt - 1) rt                           putMVar lk () -newResourceTable	:: IO (ResourceTable a)-newResourceTable	= newMVar M.empty+newResourceTable        :: IO (ResourceTable a)+newResourceTable        = newMVar M.empty++{-# NOINLINE newResourceTable #-}  -----------------------------------------------------------------------------

@@ -17,168 +17,153 @@ -- ------------------------------------------------------------  module Text.XML.HXT.Arrow.XmlCache-    ( readDocument-    , a_cache-    , a_compress-    , a_document_age-    , a_cache_404+    ( withCache+    , withoutCache+    , isInCache     , lookupCache+    , readCache     , writeCache     , sha1HashValue     , sha1HashString-    , CacheConfig(..)-    , isInCache-    , isInCache'     ) where -import           Control.DeepSeq-import           Control.Concurrent.ResourceTable-import 		 Control.Exception	( SomeException	, try )--import 		 Data.Binary-import qualified Data.ByteString.Lazy	as B-import           Data.Char-import           Data.Either-import           Data.Maybe-import		 Data.Digest.Pure.SHA--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           Text.XML.HXT.Arrow.Binary--import           Text.XML.HXT.DOM.Binary---- --------------------------------------------------------------a_cache			:: String-a_cache			= "document-cache"+import Control.DeepSeq+import Control.Concurrent.ResourceTable+import Control.Exception                        ( SomeException , try ) -a_compress		:: String-a_compress		= "compress"+import Data.Binary+import qualified+       Data.ByteString.Lazy   as B+import Data.Char+import Data.Either+import Data.Maybe+import Data.Digest.Pure.SHA -a_document_age		:: String-a_document_age		= "document-age"+import System.FilePath+import System.Directory+import System.IO+import System.Locale+import System.Posix                            ( touchFile )+import System.Time+import System.IO.Unsafe                        ( unsafePerformIO ) -a_cache_404		:: String-a_cache_404		= "cache-404"+import Text.XML.HXT.Core+import Text.XML.HXT.Arrow.XmlState.TypeDefs+import Text.XML.HXT.Arrow.Binary  -- ------------------------------------------------------------ --- | This readDocument is a wrapper for the 'Text.XML.HXT.Arrow.ReadDocument.readDocument' function.--- The function is controlled by the options 'a_cache', 'a_compress' and 'a_document_age'.+-- | withCache enables reading documents with caching. ----- * '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 out of date, see 'a_document_age', it is read from the---              cache. The document is stored in binary format (used package: binary).+-- When the cache is configured and enabled, every document read and parsed is serialized and stored in binary+-- form in the cache. When reading the same document again, it is just deserialized, no parsing is performed. ----- - 'a_compress' : controls whether the cache contents is compressed with the bzip2 lib for saving space+-- The cache is configured by a path pointing to a directory for storing the docuemnts,+-- by a maximal time span in second for valid documents. After that time span, the documents are read again+-- and the cache is updated.+-- The flag contols, whether documents returning 404 or other errors will be cached.+-- If set, the cache is even activated for 404 (not found) responses, default is false. ----- - 'a_document_age': determines the maximum age of the document in seconds. If this time is exceeded, the cache entry---                     is ignored, the original is re-read and cached again. Default for the document age is 1 day.+-- The serialized documents can be compressed, e.g. with bzip, to save disk space and IO time.+-- The compression can be configured by 'Text.XML.HXT.Arrow.XmlState.withCompression' ----- - 'a_cache_404' : If set, cache is activated even for 404 (not found) responses, default is false.--readDocument		:: Attributes -> String -> IOStateArrow s b XmlTree-readDocument userOptions src-			= maybe rd (\ l -> withTraceLevel (read l) rd) $-                          lookup a_trace userOptions-    where-    rd                  = readDocument' userOptions src-    -readDocument'		:: Attributes -> String -> IOStateArrow s b XmlTree-readDocument' userOptions src-    | withCache		= applyA $ arrIO0 (lookupCache' cacheConfig userOptions src)-    | otherwise		= Text.XML.HXT.Arrow.readDocument userOptions src-      where+-- example:+--+-- > import Text.XML.HXT.Core+-- > import Text.XML.HXT.Cache+-- > import Codec.Compression.BZip (compress, decompress)+-- > ...+-- > readDocument [ withCache "/tmp/cache" 3600 False+-- >              , withCompression (compress, decompress)+-- >              , ....+-- >              ] "http://www.haskell.org/"+-- >+--+-- In the example the document is read and stored in binary serialized form under \/tmp\/cache.+-- The cached document remains valid for the next hour.+-- It is compressed, before written to disk. -      options		= addEntries userOptions defaultOptions-      compr		= optionIsSet a_compress options-      withCache		= isJust . lookup a_cache $ userOptions-      cacheDir		= lookup1 a_cache options-      cacheAge		= readInteger . lookup1 a_document_age $ options-      cache404		= optionIsSet a_cache_404 options-      readInteger s-	  | null s || not (all isDigit s)-			= 60 * 60 * 24				-- default age: 1 day-	  | otherwise	= read s-      cacheConfig	= CC-                          { c_dir      = cacheDir-			  , c_compress = compr-			  , c_age      = cacheAge-                          , c_404	  = cache404-			  }+withCache               :: String -> Int -> Bool -> SysConfig+withCache cachePath documentAge cache404+                        = setS (theWithCache   .&&&.+                                theCacheDir    .&&&.+                                theDocumentAge .&&&.+                                theCache404Err .&&&.+                                theCacheRead+                               ) (True, (cachePath, (documentAge, (cache404, readDocCache)))) -defaultOptions		:: [(String, String)]-defaultOptions		= [ ( a_compress,	v_0	   )-			  , ( a_cache,		"./.cache" )-			  , ( a_document_age,   ""         )-                          , ( a_cache_404,	v_0	   )-			  ]+-- | Disable use of cache+withoutCache            :: SysConfig+withoutCache            = setS theWithCache False  -- ------------------------------------------------------------ --- | Arrow for checking if a document is in the cache.--- The arrow fails if document not there, else the file modification time is returned.+readDocCache              :: String -> IOStateArrow s b XmlTree+readDocCache src          = localSysVar theWithCache+                            $+                            configSysVar withoutCache+                            >>>+                            ( flip readDocCache' src+                              $< getSysVar (theCacheDir    .&&&.+                                            theDocumentAge .&&&.+                                            theCache404Err+                                           )+                            )+    where+    readDocCache' config src'+                          = applyA $ arrIO0 (lookupCache' config src') -isInCache		:: Attributes -> IOStateArrow s String ClockTime-isInCache options	= arrIO ( isInCache' $-                                  defaultCacheConfig-                                  { c_dir = lookup1 a_cache (addEntries options defaultOptions) }-                                )-                          >>>-                          arr maybeToList-                          >>>-                          unlistA-                           -- ------------------------------------------------------------ -data CacheConfig	= CC-                          { c_dir		:: FilePath-                          , c_compress	:: Bool-                          , c_age		:: Integer-                          , c_404		:: Bool-                          }+-- | Predicate arrow for checking if a document is in the cache.+-- The arrow fails if document not there or is not longer valid, else the file name is returned. -defaultCacheConfig	:: CacheConfig-defaultCacheConfig	= CC-                          { c_dir		= "./.cache"-                          , c_compress		= False-                          , c_age		= 0-                          , c_404		= False-                          }+isInCache               :: IOStateArrow s String String+isInCache               = uncurry isInC $< getSysVar (theDocumentAge .&&&. theCacheDir)+    where+    isInC age cdir      = ( traceValue 2 (\ x -> "isInCache: file=" ++ show x ++ " age=" ++ show age ++ " cache dir=" ++ show cdir)+                            >>>+                            arrIO (isInCache' age cdir)+                            >>>+                            arrL ( \ x ->+                                   case x of+                                   Just Nothing -> [x]+                                   _            -> []+                                 )+                          ) `guards` this -lookupCache'		:: CacheConfig -> Attributes -> String -> IO (IOStateArrow s a XmlTree)-lookupCache' cc os src	= do-                          ch <- cacheHit cc cf+    isInCache' age cdir f+                        = cacheHit age cf+        where+        cf              = uncurry (</>) $ cacheFile cdir f++-- ------------------------------------------------------------++lookupCache'            :: (FilePath, (Int, Bool)) -> String -> IO (IOStateArrow s a XmlTree)+lookupCache' (dir, (age, e404)) src+                        = do+                          ch <- cacheHit age cf                           return $                                  case ch of                                  Nothing        -> readAndCacheDocument                                  Just Nothing   -> readDocumentFromCache                                  Just (Just mt) -> readDocumentCond mt     where-    cf			= uncurry (</>) $ cacheFile cc src+    cf                  = uncurry (</>) $ cacheFile dir src      is200-        | c_404 cc	= hasAttrValue transferStatus (`elem` ["200", "404"])-        | otherwise	= hasAttrValue transferStatus (== "200")+        | e404          = hasAttrValue transferStatus (`elem` ["200", "404"])+        | otherwise     = hasAttrValue transferStatus (== "200") -    is304           	= hasAttrValue transferStatus (== "304")+    is304               = hasAttrValue transferStatus (== "304")      readDocumentFromCache-			= traceMsg 1 ("cache hit for " ++ show src ++ " reading " ++ show cf)+                        = traceMsg 1 ("cache hit for " ++ show src ++ " reading " ++ show cf)                           >>>-			  ( readCache cc cf+                          ( readCache' cf                             >>>-                            traceMsg 1 "cache read"+                            traceMsg 2 "cache read"                           )                           `orElse`                           ( clearErrStatus@@ -188,20 +173,20 @@                             readAndCacheDocument                           )     readAndCacheDocument-			= traceMsg 1 ("cache miss, reading original document " ++ show src)+                        = traceMsg 1 ("cache miss, reading original document " ++ show src)                           >>>-                          Text.XML.HXT.Arrow.readDocument os src+                          readDocument [] src                           >>>                           perform ( choiceA-                                    [ is200 :-> ( writeCache cc src >>> none )+                                    [ is200 :-> ( writeCache src >>> none )                                     , this  :-> traceMsg 1 "transfer status /= 200, page not cached"                                     ]                                   )      readDocumentCond mt-			= traceMsg 1 ("cache out of date, read original document if modified " ++ show src)+                        = traceMsg 1 ("cache out of date, read original document if modified " ++ show src)                           >>>-                          Text.XML.HXT.Arrow.readDocument (addEntries (condOpts mt) os) src+                          readDocument [withInputOption a_if_modified_since (fmtTime mt)] src                           >>>                           choiceA                           [ is304            :-> ( traceMsg 1 ("document not modified, using cache data from " ++ show cf)@@ -210,9 +195,12 @@                                                    >>>                                                    readDocumentFromCache                                                  )-                          , is200            :-> ( traceMsg 1 "document read and cache updated"+                          , is200            :-> ( traceMsg 1 "document read, cache will be updated"                                                    >>>-                                                   perform (writeCache cc src)+                                                   perform (writeCache src+                                                            >>>+                                                            traceMsg 2 "cache is updated"+                                                           )                                                  )                           , this             :-> ( traceMsg 1 "document read without caching"                                                    >>>@@ -220,47 +208,54 @@                                                  )                           ]         where-        condOpts t	= [("curl--header", "If-Modified-Since: " ++ fmtTime t)]-                          -- [(a_if_modified_since, fmtTime t)]-        fmtTime		= formatCalendarTime defaultTimeLocale rfc822DateFormat . toUTCTime+        fmtTime         = formatCalendarTime defaultTimeLocale rfc822DateFormat . toUTCTime  -- ------------------------------------------------------------ -lookupCache		:: (NFData b, Binary b) => CacheConfig -> String -> IOStateArrow s a b-lookupCache cc f	= isIOA (const $ hit)-			  `guards`-			  readCache cc cf+lookupCache             :: (NFData b, Binary b) => String -> IOStateArrow s a b+lookupCache f           = uncurry lookupC $< getSysVar (theDocumentAge .&&&. theCacheDir)     where-    cf			= uncurry (</>) $ cacheFile cc f-    hit			= do-                          ch <- cacheHit cc cf+    lookupC age cdir    = isIOA (const $ hit)+                          `guards`+                          readCache' cf+        where+        cf              = uncurry (</>) $ cacheFile cdir f+        hit             = do+                          ch <- cacheHit age 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+readCache               :: (NFData c, Binary c) => String -> IOStateArrow s b c+readCache f             = readC $< getSysVar theCacheDir+    where+    readC cdir          = readCache' $ uncurry (</>) $ cacheFile cdir f -writeCache		:: (Binary b) => CacheConfig -> String -> IOStateArrow s b ()-writeCache cc f		= traceMsg 1 ("writing cache file " ++ show f)+readCache'              :: (NFData c, Binary c) => String -> IOStateArrow s b c+readCache' cf           = withLock cf $ readBinaryValue cf++writeCache              :: (Binary b) => String -> IOStateArrow s b ()+writeCache f            = writeC $< getSysVar theCacheDir+    where+    writeC cdir         = traceMsg 1 ("writing cache file " ++ show cf ++ " for document " ++ show f)                           >>>                           perform (arrIO0 createDir)                           >>>-                          withLock hf (writeBinaryValue (c_compress cc) 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+                          withLock cf (writeBinaryValue cf)+                          >>>+                          perform (withLock ixf (arrIO0 $ writeIndex ixf f cf))+        where+        cf              = dir </> file+        ixf             = cdir </> "index"+        (dir, file)     = cacheFile cdir f+        createDir       = createDirectoryIfMissing True dir  -- ------------------------------------------------------------ -remFile			:: FilePath -> IO ()-remFile f		= ( try' $ do ex <- doesFileExist f+remFile                 :: FilePath -> IO ()+remFile f               = ( try' $ do ex <- doesFileExist f                                       if ex                                         then removeFile f                                         else return ()@@ -268,23 +263,10 @@  -- ------------------------------------------------------------ -cacheFile		:: CacheConfig -> String -> (FilePath, FilePath)-cacheFile cc f		= (c_dir cc </> fd, fn)-    where-    (fd, fn)		= splitAt 2 . sha1HashString $ f---- --------------------------------------------------------------isInCache'		:: CacheConfig -> String -> IO (Maybe ClockTime)-isInCache' cc f		= do-                          h <- cacheHit cc' cf-                          return $-                                 case h of-                                 Just (Just t)	-> Just t-                                 _		-> Nothing+cacheFile               :: FilePath -> String -> (FilePath, FilePath)+cacheFile dir f          = (dir </> fd, fn)     where-    cf			= uncurry (</>) $ cacheFile cc f-    cc'			= cc { c_age = 0 }+    (fd, fn)            = splitAt 2 . sha1HashString $ f  -- ------------------------------------------------------------ @@ -293,69 +275,68 @@ -- 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 (Maybe (Maybe ClockTime))-cacheHit cc hf		= ( try' $-			    do-			    e <- doesFileExist hf-			    if not e-			      then return Nothing-			      else do-			           mt <- getModificationTime hf-				   ct <- getClockTime-				   return . Just $ if (dt `addToClockTime` mt) >= ct++cacheHit                :: Int -> FilePath -> IO (Maybe (Maybe ClockTime))+cacheHit age cf         = ( try' $+                            do+                            e <- doesFileExist cf+                            if not e+                              then return Nothing+                              else do+                                   mt <- getModificationTime cf+                                   ct <- getClockTime+                                   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-    minutes		= fromInteger $ age `div` 60-    dt			= normalizeTimeDiff $ TimeDiff 0 0 0 0 minutes seconds 0+                          ) >>= return . either (const Nothing) id+    where+    seconds             = age `mod` 60+    minutes             = age `div` 60+    dt                  = normalizeTimeDiff $ TimeDiff 0 0 0 0 minutes seconds 0 -try'			:: IO a -> IO (Either SomeException a)-try'			= try+try'                    :: IO a -> IO (Either SomeException a)+try'                    = try -writeIndex		:: String -> String -> FilePath -> IO ()-writeIndex ixf f hf	= ( try' $-			    do-			    h <- openBinaryFile ixf AppendMode-			    hPutStrLn h $ show (hf, f)-			    hClose h-			    return ()-			  ) >> return ()+writeIndex              :: String -> String -> FilePath -> IO ()+writeIndex ixf f cf     = ( try' $+                            do+                            h <- openBinaryFile ixf AppendMode+                            hPutStrLn h $ show (cf, f)+                            hClose h+                            return ()+                          ) >> return ()  -- ------------------------------------------------------------  -- | Compute the SHA1 hash is hexadecimal format for an arbitray serializable value -sha1HashValue		:: (Arrow a, Binary b) => a b Integer-sha1HashValue		= arr $ integerDigest . sha1 . encode+sha1HashValue           :: (Arrow a, Binary b) => a b Integer+sha1HashValue           = arr $ integerDigest . sha1 . encode -sha1HashString		:: (Arrow a, Binary b) => a b String-sha1HashString		= arr $ showDigest . sha1 . encode+sha1HashString          :: (Arrow a, Binary b) => a b String+sha1HashString          = arr $ showDigest . sha1 . encode  -- ------------------------------------------------------------   -- | the internal table of file locks -theLockedFiles		:: ResourceTable String-theLockedFiles		= unsafePerformIO newResourceTable+theLockedFiles          :: ResourceTable String+theLockedFiles          = unsafePerformIO newResourceTable {-# NOINLINE theLockedFiles #-} -lockFile, unlockFile	:: String -> IO ()-lockFile		= requestResource theLockedFiles-unlockFile		= releaseResource 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-		  +withLock                :: String -> IOStateArrow s b c -> IOStateArrow s b c+withLock l a            = ( perform (arrIO0 $ lockFile l)+                            >>>+                            listA a+                            >>>+                            perform (arrIO0 $ unlockFile l)+                          )+                          >>>+                          unlistA+ -----------------------------------------------------------------------------

@@ -0,0 +1,25 @@+-- ------------------------------------------------------------++{- |+   Module     : Text.XML.HXT.Arrow.Cache+   Copyright  : Copyright (C) 2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Caching of XML document trees and other binary data+-}++-- ------------------------------------------------------------++module Text.XML.HXT.Cache+    ( withCache+    , withoutCache+    )+where++import           Text.XML.HXT.Arrow.XmlCache++-- ------------------------------------------------------------

@@ -1,33 +1,33 @@ -- ----------------------------------------------------------------------------- -module Main		-- TestXmlCache+module Main             -- TestXmlCache where  import Data.Maybe  import System.Environment -import Text.XML.HXT.Arrow	hiding ( readDocument )+import Text.XML.HXT.Arrow       hiding ( readDocument ) import Text.XML.HXT.Arrow.XmlCache -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	  )+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       )                                            ] url                               >>>-                              writeDocument [ ( a_indent,	v_1	)+                              writeDocument [ ( a_indent,       v_1     )                                             ] "t.xml"                             )                           >> return () -main			:: IO ()-main			= do-			  as <- getArgs-			  main' . fromMaybe "http://www.haskell.org/" . listToMaybe $ as+main                    :: IO ()+main                    = do+                          as <- getArgs+                          main' . fromMaybe "http://www.haskell.org/" . listToMaybe $ as  -- -----------------------------------------------------------------------------