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

    , resourceList
    , resourceExists

    , resourceFilePath
    , resourceString
    , resourceLBS

    , resourceModified
    , resourceModificationTime
    ) where


--------------------------------------------------------------------------------
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.Set               (Set)
import qualified Data.Set               as S
import           Data.Time              (Day (..), UTCTime (..))
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 {BinaryTime -> UTCTime
unBinaryTime :: UTCTime}
    deriving (BinaryTime -> BinaryTime -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinaryTime -> BinaryTime -> Bool
$c/= :: BinaryTime -> BinaryTime -> Bool
== :: BinaryTime -> BinaryTime -> Bool
$c== :: BinaryTime -> BinaryTime -> Bool
Eq, BinaryTime -> ()
forall a. (a -> ()) -> NFData a
rnf :: BinaryTime -> ()
$crnf :: BinaryTime -> ()
NFData, Eq BinaryTime
BinaryTime -> BinaryTime -> Bool
BinaryTime -> BinaryTime -> Ordering
BinaryTime -> BinaryTime -> BinaryTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BinaryTime -> BinaryTime -> BinaryTime
$cmin :: BinaryTime -> BinaryTime -> BinaryTime
max :: BinaryTime -> BinaryTime -> BinaryTime
$cmax :: BinaryTime -> BinaryTime -> BinaryTime
>= :: BinaryTime -> BinaryTime -> Bool
$c>= :: BinaryTime -> BinaryTime -> Bool
> :: BinaryTime -> BinaryTime -> Bool
$c> :: BinaryTime -> BinaryTime -> Bool
<= :: BinaryTime -> BinaryTime -> Bool
$c<= :: BinaryTime -> BinaryTime -> Bool
< :: BinaryTime -> BinaryTime -> Bool
$c< :: BinaryTime -> BinaryTime -> Bool
compare :: BinaryTime -> BinaryTime -> Ordering
$ccompare :: BinaryTime -> BinaryTime -> Ordering
Ord, Int -> BinaryTime -> ShowS
[BinaryTime] -> ShowS
BinaryTime -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinaryTime] -> ShowS
$cshowList :: [BinaryTime] -> ShowS
show :: BinaryTime -> String
$cshow :: BinaryTime -> String
showsPrec :: Int -> BinaryTime -> ShowS
$cshowsPrec :: Int -> BinaryTime -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Binary BinaryTime where
    put :: BinaryTime -> Put
put (BinaryTime (UTCTime (ModifiedJulianDay Integer
d) DiffTime
dt)) =
        forall t. Binary t => t -> Put
put Integer
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put (forall a. Real a => a -> Rational
toRational DiffTime
dt)

    get :: Get BinaryTime
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> BinaryTime
BinaryTime forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Day
ModifiedJulianDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Fractional a => Rational -> a
fromRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get)


--------------------------------------------------------------------------------
data ResourceInfo = ResourceInfo
    { ResourceInfo -> BinaryTime
resourceInfoModified :: BinaryTime
    , ResourceInfo -> Maybe Identifier
resourceInfoMetadata :: Maybe Identifier
    } deriving (Int -> ResourceInfo -> ShowS
[ResourceInfo] -> ShowS
ResourceInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResourceInfo] -> ShowS
$cshowList :: [ResourceInfo] -> ShowS
show :: ResourceInfo -> String
$cshow :: ResourceInfo -> String
showsPrec :: Int -> ResourceInfo -> ShowS
$cshowsPrec :: Int -> ResourceInfo -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Binary ResourceInfo where
    put :: ResourceInfo -> Put
put (ResourceInfo BinaryTime
mtime Maybe Identifier
meta) = forall t. Binary t => t -> Put
put BinaryTime
mtime forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Maybe Identifier
meta
    get :: Get ResourceInfo
get = BinaryTime -> Maybe Identifier -> ResourceInfo
ResourceInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get


--------------------------------------------------------------------------------
instance NFData ResourceInfo where
    rnf :: ResourceInfo -> ()
rnf (ResourceInfo BinaryTime
mtime Maybe Identifier
meta) = forall a. NFData a => a -> ()
rnf BinaryTime
mtime seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe Identifier
meta seq :: forall a b. a -> b -> b
`seq` ()


--------------------------------------------------------------------------------
-- | Responsible for retrieving and listing resources
data Provider = Provider
    { -- Top of the provided directory
      Provider -> String
providerDirectory :: FilePath
    , -- | A list of all files found
      Provider -> Map Identifier ResourceInfo
providerFiles     :: Map Identifier ResourceInfo
    , -- | A list of the files from the previous run
      Provider -> Map Identifier ResourceInfo
providerOldFiles  :: Map Identifier ResourceInfo
    , -- | Underlying persistent store for caching
      Provider -> Store
providerStore     :: Store
    } deriving (Int -> Provider -> ShowS
[Provider] -> ShowS
Provider -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Provider] -> ShowS
$cshowList :: [Provider] -> ShowS
show :: Provider -> String
$cshow :: Provider -> String
showsPrec :: Int -> Provider -> ShowS
$cshowsPrec :: Int -> Provider -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Create a resource provider
newProvider :: Store                  -- ^ Store to use
            -> (FilePath -> IO Bool)  -- ^ Should we ignore this file?
            -> FilePath               -- ^ Search directory
            -> IO Provider            -- ^ Resulting provider
newProvider :: Store -> (String -> IO Bool) -> String -> IO Provider
newProvider Store
store String -> IO Bool
ignore String
directory = do
    [Identifier]
list <- forall a b. (a -> b) -> [a] -> [b]
map String -> Identifier
fromFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO Bool) -> String -> IO [String]
getRecursiveContents String -> IO Bool
ignore String
directory
    let universe :: Set Identifier
universe = forall a. Ord a => [a] -> Set a
S.fromList [Identifier]
list
    Map Identifier ResourceInfo
files <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Identifier ResourceInfo -> Map Identifier ResourceInfo
maxmtime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Identifier]
list forall a b. (a -> b) -> a -> b
$ \Identifier
identifier -> do
        ResourceInfo
rInfo <- String -> Set Identifier -> Identifier -> IO ResourceInfo
getResourceInfo String
directory Set Identifier
universe Identifier
identifier
        forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier
identifier, ResourceInfo
rInfo)

    -- Get the old files from the store, and then immediately replace them by
    -- the new files.
    Map Identifier ResourceInfo
oldFiles <- forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Result a -> Maybe a
Store.toMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Binary a, Typeable a) =>
Store -> [String] -> IO (Result a)
Store.get Store
store [String]
oldKey
    Map Identifier ResourceInfo
oldFiles forall a b. NFData a => a -> b -> b
`deepseq` forall a. (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
Store.set Store
store [String]
oldKey Map Identifier ResourceInfo
files

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
-> Map Identifier ResourceInfo
-> Map Identifier ResourceInfo
-> Store
-> Provider
Provider String
directory Map Identifier ResourceInfo
files Map Identifier ResourceInfo
oldFiles Store
store
  where
    oldKey :: [String]
oldKey = [String
"Hakyll.Core.Provider.Internal.newProvider", String
"oldFiles"]

    -- Update modified if metadata is modified
    maxmtime :: Map Identifier ResourceInfo -> Map Identifier ResourceInfo
maxmtime Map Identifier ResourceInfo
files = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b k. (a -> b) -> Map k a -> Map k b
M.map Map Identifier ResourceInfo
files forall a b. (a -> b) -> a -> b
$ \rInfo :: ResourceInfo
rInfo@(ResourceInfo BinaryTime
mtime Maybe Identifier
meta) ->
        let metaMod :: Maybe BinaryTime
metaMod = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResourceInfo -> BinaryTime
resourceInfoModified forall a b. (a -> b) -> a -> b
$ Maybe Identifier
meta forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Identifier ResourceInfo
files
        in ResourceInfo
rInfo {resourceInfoModified :: BinaryTime
resourceInfoModified = forall b a. b -> (a -> b) -> Maybe a -> b
maybe BinaryTime
mtime (forall a. Ord a => a -> a -> a
max BinaryTime
mtime) Maybe BinaryTime
metaMod}


--------------------------------------------------------------------------------
getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
getResourceInfo :: String -> Set Identifier -> Identifier -> IO ResourceInfo
getResourceInfo String
directory Set Identifier
universe Identifier
identifier = do
    UTCTime
mtime <- String -> IO UTCTime
fileModificationTime forall a b. (a -> b) -> a -> b
$ String
directory String -> ShowS
</> Identifier -> String
toFilePath Identifier
identifier
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BinaryTime -> Maybe Identifier -> ResourceInfo
ResourceInfo (UTCTime -> BinaryTime
BinaryTime UTCTime
mtime) forall a b. (a -> b) -> a -> b
$
        if Identifier
mdRsc forall a. Ord a => a -> Set a -> Bool
`S.member` Set Identifier
universe then forall a. a -> Maybe a
Just Identifier
mdRsc else forall a. Maybe a
Nothing
  where
    mdRsc :: Identifier
mdRsc = String -> Identifier
fromFilePath forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
addExtension String
"metadata" forall a b. (a -> b) -> a -> b
$ Identifier -> String
toFilePath Identifier
identifier


--------------------------------------------------------------------------------
resourceList :: Provider -> [Identifier]
resourceList :: Provider -> [Identifier]
resourceList = forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Provider -> Map Identifier ResourceInfo
providerFiles


--------------------------------------------------------------------------------
-- | Check if a given resource exists
resourceExists :: Provider -> Identifier -> Bool
resourceExists :: Provider -> Identifier -> Bool
resourceExists Provider
provider =
    (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Provider -> Map Identifier ResourceInfo
providerFiles Provider
provider) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Identifier -> Identifier
setVersion forall a. Maybe a
Nothing


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


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


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


--------------------------------------------------------------------------------
-- | A resource is modified if it or its metadata has changed
resourceModified :: Provider -> Identifier -> Bool
resourceModified :: Provider -> Identifier -> Bool
resourceModified Provider
p Identifier
r = case (Maybe ResourceInfo
ri, Maybe ResourceInfo
oldRi) of
    (Maybe ResourceInfo
Nothing, Maybe ResourceInfo
_)      -> Bool
False
    (Just ResourceInfo
_, Maybe ResourceInfo
Nothing) -> Bool
True
    (Just ResourceInfo
n, Just ResourceInfo
o)  ->
        ResourceInfo -> BinaryTime
resourceInfoModified ResourceInfo
n forall a. Ord a => a -> a -> Bool
>  ResourceInfo -> BinaryTime
resourceInfoModified ResourceInfo
o Bool -> Bool -> Bool
||
        ResourceInfo -> Maybe Identifier
resourceInfoMetadata ResourceInfo
n forall a. Eq a => a -> a -> Bool
/= ResourceInfo -> Maybe Identifier
resourceInfoMetadata ResourceInfo
o
  where
    normal :: Identifier
normal = Maybe String -> Identifier -> Identifier
setVersion forall a. Maybe a
Nothing Identifier
r
    ri :: Maybe ResourceInfo
ri     = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
normal (Provider -> Map Identifier ResourceInfo
providerFiles Provider
p)
    oldRi :: Maybe ResourceInfo
oldRi  = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
normal (Provider -> Map Identifier ResourceInfo
providerOldFiles Provider
p)


--------------------------------------------------------------------------------
resourceModificationTime :: Provider -> Identifier -> UTCTime
resourceModificationTime :: Provider -> Identifier -> UTCTime
resourceModificationTime Provider
p Identifier
i =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Maybe String -> Identifier -> Identifier
setVersion forall a. Maybe a
Nothing Identifier
i) (Provider -> Map Identifier ResourceInfo
providerFiles Provider
p) of
        Just ResourceInfo
ri -> BinaryTime -> UTCTime
unBinaryTime forall a b. (a -> b) -> a -> b
$ ResourceInfo -> BinaryTime
resourceInfoModified ResourceInfo
ri
        Maybe ResourceInfo
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
            String
"Hakyll.Core.Provider.Internal.resourceModificationTime: " forall a. [a] -> [a] -> [a]
++
            String
"resource " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
i forall a. [a] -> [a] -> [a]
++ String
" does not exist"


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