diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/hxt-cache.cabal b/hxt-cache.cabal new file mode 100644 --- /dev/null +++ b/hxt-cache.cabal @@ -0,0 +1,37 @@ +name: hxt-cache +version: 0.0.1 +license: OtherLicense +license-file: LICENCE +maintainer: Uwe Schmidt +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 + +extra-source-files: + test/TestXmlCache.hs + +library + exposed-modules: + Text.XML.HXT.Arrow.XmlCache + + hs-source-dirs: src + ghc-options: -Wall + + build-depends: base >= 4 && < 5, + bytestring >= 0.9 && < 1, + binary >= 0.5 && < 1, + directory >= 1 && < 2, + filepath >= 1.1 && < 2, + haskell98 >= 1 && < 2, + hxt >= 8.2 && < 9, + hxt-binary >= 0 && < 1, + old-time >= 1 && < 2, + SHA >= 1.4 && < 2 + diff --git a/src/Text/XML/HXT/Arrow/XmlCache.hs b/src/Text/XML/HXT/Arrow/XmlCache.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/HXT/Arrow/XmlCache.hs @@ -0,0 +1,196 @@ +{-# OPTIONS -fno-warn-unused-imports #-} + +-- ------------------------------------------------------------ + +{- | + Module : Text.XML.HXT.Arrow.XmlCache + Copyright : Copyright (C) 2009 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.Arrow.XmlCache + ( readDocument + , a_cache + , a_compress + , a_document_age + , lookupCache + , writeCache + , sha1HashValue + , sha1HashString + , CacheConfig(..) + ) +where + +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.Time + +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" + +a_compress :: String +a_compress = "compress" + +a_document_age :: String +a_document_age = "document-age" + +-- ------------------------------------------------------------ + +-- | 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'. +-- +-- * '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 +-- 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 +-- +-- - '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. + +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 = ( 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 + + where + + options = addEntries userOptions defaultOptions + defaultOptions = [ ( a_compress, v_0 ) + , ( a_cache, "./.cache" ) + , ( a_document_age, "" ) + ] + compr = optionIsSet a_compress options + withCache = isJust . lookup a_cache $ userOptions + cacheDir = lookup1 a_cache options + cacheAge = readInteger . lookup1 a_document_age $ 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 + } + +-- ------------------------------------------------------------ + +data CacheConfig = CC { c_dir :: FilePath + , c_compress :: Bool + , c_age :: Integer + } + +lookupCache :: (Binary b) => CacheConfig -> String -> IOStateArrow s a b +lookupCache cc f = isIOA (const $ cacheHit cc cf) + `guards` + readBinaryValue (c_compress cc) cf + where + cf = uncurry () $ cacheFile cc f + +writeCache :: (Binary b) => CacheConfig -> String -> IOStateArrow s b () +writeCache cc f = perform (arrIO0 createDir) + >>> + writeBinaryValue (c_compress cc) hf + >>> + perform (arrIO0 $ writeIndex cc f hf) + where + hf = dir file + (dir, file) = cacheFile cc f + createDir = createDirectoryIfMissing True dir + +cacheFile :: CacheConfig -> String -> (FilePath, FilePath) +cacheFile cc f = (c_dir cc fd, fn) + where + (fd, fn) = splitAt 2 . sha1HashString $ f + +cacheHit :: CacheConfig -> FilePath -> IO Bool +cacheHit cc hf = ( try' $ + do + e <- doesFileExist hf + if not e + then return False + else do + mt <- getModificationTime hf + ct <- getClockTime + return $ (dt `addToClockTime` mt) >= ct + ) >>= return . either (const False) 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 + +try' :: IO a -> IO (Either SomeException a) +try' = try + +writeIndex :: CacheConfig -> String -> FilePath -> IO () +writeIndex cc f hf = ( try' $ + do + h <- openBinaryFile (c_dir cc "index") AppendMode + hPutStrLn h $ show (hf, 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 + +sha1HashString :: (Arrow a, Binary b) => a b String +sha1HashString = arr $ showDigest . sha1 . encode + +-- ------------------------------------------------------------ diff --git a/test/TestXmlCache.hs b/test/TestXmlCache.hs new file mode 100644 --- /dev/null +++ b/test/TestXmlCache.hs @@ -0,0 +1,25 @@ +-- ----------------------------------------------------------------------------- + +module Main -- TestXmlCache +where + +import Text.XML.HXT.Arrow hiding ( readDocument ) +import Text.XML.HXT.Arrow.XmlCache + +main :: IO () +main = do + 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/" + >>> + writeDocument [ ( a_indent, v_1 ) + ] "haskell.org.html" + ) + return () + +-- -----------------------------------------------------------------------------