hakyll/src/Hakyll/Core/Provider/Internal.hs

--------------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Core.Provider.Internal
    ( ResourceInfo (..)
    , Provider (..)
    , newProvider

    , resourceList
    , resourceExists

    , resourceFilePath
    , resourceString
    , resourceLBS

    , resourceModified
    , resourceModificationTime
    ) where


--------------------------------------------------------------------------------
import           Control.Applicative    ((<$>), (<*>))
import           Control.DeepSeq        (NFData (..), deepseq)
import           Control.Monad          (forM)
import           Data.Binary            (Binary (..))
import qualified Data.ByteString.Lazy   as BL
import           Data.Map               (Map)
import qualified Data.Map               as M
import           Data.Maybe             (fromMaybe)
import           Data.Monoid            (mempty)
import           Data.Set               (Set)
import qualified Data.Set               as S
import           Data.Time              (Day (..), UTCTime (..),
                                         secondsToDiffTime)
import           Data.Typeable          (Typeable)
import           System.Directory       (getModificationTime)
import           System.FilePath        (addExtension, (</>))


--------------------------------------------------------------------------------
#if !MIN_VERSION_directory(1,2,0)
import           Data.Time              (readTime)
import           System.Locale          (defaultTimeLocale)
import           System.Time            (formatCalendarTime, toCalendarTime)
#endif


--------------------------------------------------------------------------------
import           Hakyll.Core.Identifier
import           Hakyll.Core.Store      (Store)
import qualified Hakyll.Core.Store      as Store
import           Hakyll.Core.Util.File


--------------------------------------------------------------------------------
-- | Because UTCTime doesn't have a Binary instance...
newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
    deriving (Eq, NFData, Ord, Show, Typeable)


--------------------------------------------------------------------------------
instance Binary BinaryTime where
    put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
        put d >> put (floor dt :: Integer)

    get = fmap BinaryTime $ UTCTime
        <$> (ModifiedJulianDay <$> get)
        <*> (secondsToDiffTime <$> get)


--------------------------------------------------------------------------------
data ResourceInfo = ResourceInfo
    { resourceInfoModified :: BinaryTime
    , resourceInfoMetadata :: Maybe Identifier
    } deriving (Show, Typeable)


--------------------------------------------------------------------------------
instance Binary ResourceInfo where
    put (ResourceInfo mtime meta) = put mtime >> put meta
    get = ResourceInfo <$> get <*> get


--------------------------------------------------------------------------------
instance NFData ResourceInfo where
    rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()


--------------------------------------------------------------------------------
-- | Responsible for retrieving and listing resources
data Provider = Provider
    { -- Top of the provided directory
      providerDirectory :: FilePath
    , -- | A list of all files found
      providerFiles     :: Map Identifier ResourceInfo
    , -- | A list of the files from the previous run
      providerOldFiles  :: Map Identifier ResourceInfo
    , -- | Underlying persistent store for caching
      providerStore     :: Store
    }


--------------------------------------------------------------------------------
-- | Create a resource provider
newProvider :: Store               -- ^ Store to use
            -> (FilePath -> Bool)  -- ^ Should we ignore this file?
            -> FilePath            -- ^ Search directory
            -> IO Provider         -- ^ Resulting provider
newProvider store ignore directory = do
    list <- map fromFilePath <$> getRecursiveContents ignore directory
    let universe = S.fromList list
    files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do
        rInfo <- getResourceInfo directory universe identifier
        return (identifier, rInfo)

    -- Get the old files from the store, and then immediately replace them by
    -- the new files.
    oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey
    oldFiles `deepseq` Store.set store oldKey files

    return $ Provider directory files oldFiles store
  where
    oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]

    -- Update modified if metadata is modified
    maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->
        let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files
        in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}


--------------------------------------------------------------------------------
getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
getResourceInfo directory universe identifier = do
    mtime <- fileModificationTime $ directory </> toFilePath identifier
    return $ ResourceInfo (BinaryTime mtime) $
        if mdRsc `S.member` universe then Just mdRsc else Nothing
  where
    mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier


--------------------------------------------------------------------------------
resourceList :: Provider -> [Identifier]
resourceList = M.keys . providerFiles


--------------------------------------------------------------------------------
-- | Check if a given resource exists
resourceExists :: Provider -> Identifier -> Bool
resourceExists provider =
    (`M.member` providerFiles provider) . setVersion Nothing


--------------------------------------------------------------------------------
resourceFilePath :: Provider -> Identifier -> FilePath
resourceFilePath p i = providerDirectory p </> toFilePath i


--------------------------------------------------------------------------------
-- | Get the raw body of a resource as string
resourceString :: Provider -> Identifier -> IO String
resourceString p i = readFile $ resourceFilePath p i


--------------------------------------------------------------------------------
-- | Get the raw body of a resource of a lazy bytestring
resourceLBS :: Provider -> Identifier -> IO BL.ByteString
resourceLBS p i = BL.readFile $ resourceFilePath p i


--------------------------------------------------------------------------------
-- | A resource is modified if it or its metadata has changed
resourceModified :: Provider -> Identifier -> Bool
resourceModified p r = case (ri, oldRi) of
    (Nothing, _)      -> True
    (Just _, Nothing) -> True
    (Just n, Just o)  -> resourceInfoModified n > resourceInfoModified o
  where
    ri    = M.lookup (setVersion Nothing r) (providerFiles p)
    oldRi = ri >>= resourceInfoMetadata >>= flip M.lookup (providerFiles p)


--------------------------------------------------------------------------------
resourceModificationTime :: Provider -> Identifier -> UTCTime
resourceModificationTime p i =
    case M.lookup (setVersion Nothing i) (providerFiles p) of
        Just ri -> unBinaryTime $ resourceInfoModified ri
        Nothing -> error $
            "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++
            "resource " ++ show i ++ " does not exist"


--------------------------------------------------------------------------------
fileModificationTime :: FilePath -> IO UTCTime
fileModificationTime fp = do
#if MIN_VERSION_directory(1,2,0)
    getModificationTime fp
#else
    ct <- toCalendarTime =<< getModificationTime fp
    let str = formatCalendarTime defaultTimeLocale "%s" ct
    return $ readTime defaultTimeLocale "%s" str
#endif