diff options
Diffstat (limited to 'lib/Hakyll/Core/Store.hs')
-rw-r--r-- | lib/Hakyll/Core/Store.hs | 197 |
1 files changed, 197 insertions, 0 deletions
diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs new file mode 100644 index 0000000..fdbcf11 --- /dev/null +++ b/lib/Hakyll/Core/Store.hs @@ -0,0 +1,197 @@ +-------------------------------------------------------------------------------- +-- | 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 "/" |