diff options
Diffstat (limited to 'src/Hakyll/Core/Store.hs')
| -rw-r--r-- | src/Hakyll/Core/Store.hs | 197 |
1 files changed, 0 insertions, 197 deletions
diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs deleted file mode 100644 index fdbcf11..0000000 --- a/src/Hakyll/Core/Store.hs +++ /dev/null @@ -1,197 +0,0 @@ --------------------------------------------------------------------------------- --- | A store for storing and retreiving items -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Hakyll.Core.Store - ( Store - , Result (..) - , toMaybe - , new - , set - , get - , isMember - , delete - , hash - ) where - - --------------------------------------------------------------------------------- -import Control.Exception (IOException, handle) -import qualified Crypto.Hash.MD5 as MD5 -import Data.Binary (Binary, decode, encodeFile) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Cache.LRU.IO as Lru -import Data.List (intercalate) -import Data.Maybe (isJust) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable (TypeRep, Typeable, cast, typeOf) -import System.Directory (createDirectoryIfMissing) -import System.Directory (doesFileExist, removeFile) -import System.FilePath ((</>)) -import System.IO (IOMode (..), hClose, openFile) -import Text.Printf (printf) - - --------------------------------------------------------------------------------- --- | Simple wrapper type -data Box = forall a. Typeable a => Box a - - --------------------------------------------------------------------------------- -data Store = Store - { -- | All items are stored on the filesystem - storeDirectory :: FilePath - , -- | Optionally, items are also kept in-memory - storeMap :: Maybe (Lru.AtomicLRU FilePath Box) - } - - --------------------------------------------------------------------------------- -instance Show Store where - show _ = "<Store>" - - --------------------------------------------------------------------------------- --- | Result of a store query -data Result a - = Found a -- ^ Found, result - | NotFound -- ^ Not found - | WrongType TypeRep TypeRep -- ^ Expected, true type - deriving (Show, Eq) - - --------------------------------------------------------------------------------- --- | Convert result to 'Maybe' -toMaybe :: Result a -> Maybe a -toMaybe (Found x) = Just x -toMaybe _ = Nothing - - --------------------------------------------------------------------------------- --- | Initialize the store -new :: Bool -- ^ Use in-memory caching - -> FilePath -- ^ Directory to use for hard disk storage - -> IO Store -- ^ Store -new inMemory directory = do - createDirectoryIfMissing True directory - ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing - return Store - { storeDirectory = directory - , storeMap = ref - } - where - csize = Just 500 - - --------------------------------------------------------------------------------- --- | Auxiliary: add an item to the in-memory cache -cacheInsert :: Typeable a => Store -> String -> a -> IO () -cacheInsert (Store _ Nothing) _ _ = return () -cacheInsert (Store _ (Just lru)) key x = - Lru.insert key (Box x) lru - - --------------------------------------------------------------------------------- --- | Auxiliary: get an item from the in-memory cache -cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a) -cacheLookup (Store _ Nothing) _ = return NotFound -cacheLookup (Store _ (Just lru)) key = do - res <- Lru.lookup key lru - return $ case res of - Nothing -> NotFound - Just (Box x) -> case cast x of - Just x' -> Found x' - Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x) - - --------------------------------------------------------------------------------- -cacheIsMember :: Store -> String -> IO Bool -cacheIsMember (Store _ Nothing) _ = return False -cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru - - --------------------------------------------------------------------------------- --- | Auxiliary: delete an item from the in-memory cache -cacheDelete :: Store -> String -> IO () -cacheDelete (Store _ Nothing) _ = return () -cacheDelete (Store _ (Just lru)) key = do - _ <- Lru.delete key lru - return () - - --------------------------------------------------------------------------------- --- | Store an item -set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO () -set store identifier value = do - encodeFile (storeDirectory store </> key) value - cacheInsert store key value - where - key = hash identifier - - --------------------------------------------------------------------------------- --- | Load an item -get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a) -get store identifier = do - -- First check the in-memory map - ref <- cacheLookup store key - case ref of - -- Not found in the map, try the filesystem - NotFound -> do - exists <- doesFileExist path - if not exists - -- Not found in the filesystem either - then return NotFound - -- Found in the filesystem - else do - v <- decodeClose - cacheInsert store key v - return $ Found v - -- Found in the in-memory map (or wrong type), just return - s -> return s - where - key = hash identifier - path = storeDirectory store </> key - - -- 'decodeFile' from Data.Binary which closes the file ASAP - decodeClose = do - h <- openFile path ReadMode - lbs <- BL.hGetContents h - BL.length lbs `seq` hClose h - return $ decode lbs - - --------------------------------------------------------------------------------- --- | Strict function -isMember :: Store -> [String] -> IO Bool -isMember store identifier = do - inCache <- cacheIsMember store key - if inCache then return True else doesFileExist path - where - key = hash identifier - path = storeDirectory store </> key - - --------------------------------------------------------------------------------- --- | Delete an item -delete :: Store -> [String] -> IO () -delete store identifier = do - cacheDelete store key - deleteFile $ storeDirectory store </> key - where - key = hash identifier - - --------------------------------------------------------------------------------- --- | Delete a file unless it doesn't exist... -deleteFile :: FilePath -> IO () -deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile - - --------------------------------------------------------------------------------- --- | Mostly meant for internal usage -hash :: [String] -> String -hash = concatMap (printf "%02x") . B.unpack . - MD5.hash . T.encodeUtf8 . T.pack . intercalate "/" |