{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.PureScript.Make.Cache
( ContentHash
, hash
, CacheDb
, CacheInfo
, checkChanged
, removeModules
) where
import Prelude
import Control.Category ((>>>))
import Control.Monad ((>=>))
import Crypto.Hash (HashAlgorithm, Digest, SHA512)
import qualified Crypto.Hash as Hash
import qualified Data.Aeson as Aeson
import Data.Align (align)
import Data.ByteArray.Encoding (Base(Base16), convertToBase, convertFromBase)
import qualified Data.ByteString as BS
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (All(..))
import Data.Set (Set)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.These (These(..))
import Data.Time.Clock (UTCTime)
import Data.Traversable (for)
import Language.PureScript.Names (ModuleName)
digestToHex :: Digest a -> Text
digestToHex = decodeUtf8 . convertToBase Base16
digestFromHex :: forall a. HashAlgorithm a => Text -> Maybe (Digest a)
digestFromHex =
encodeUtf8
>>> either (const Nothing) Just . convertFromBase Base16
>=> (Hash.digestFromByteString :: BS.ByteString -> Maybe (Digest a))
newtype ContentHash = ContentHash
{ unContentHash :: Digest SHA512 }
deriving (Show, Eq, Ord)
instance Aeson.ToJSON ContentHash where
toJSON = Aeson.toJSON . digestToHex . unContentHash
instance Aeson.FromJSON ContentHash where
parseJSON x = do
str <- Aeson.parseJSON x
case digestFromHex str of
Just digest ->
pure $ ContentHash digest
Nothing ->
fail "Unable to decode ContentHash"
hash :: BS.ByteString -> ContentHash
hash = ContentHash . Hash.hash
type CacheDb = Map ModuleName CacheInfo
newtype CacheInfo = CacheInfo
{ unCacheInfo :: Map FilePath (UTCTime, ContentHash) }
deriving stock (Show)
deriving newtype (Eq, Ord, Semigroup, Monoid, Aeson.FromJSON, Aeson.ToJSON)
checkChanged
:: Monad m
=> CacheDb
-> ModuleName
-> Map FilePath (UTCTime, m ContentHash)
-> m (CacheInfo, Bool)
checkChanged cacheDb mn currentInfo = do
let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb)
(newInfo, isUpToDate) <-
fmap mconcat $
for (Map.toList (align dbInfo currentInfo)) $ \(fp, aligned) -> do
case aligned of
This _ -> do
pure (Map.empty, All False)
That (timestamp, getHash) -> do
newHash <- getHash
pure (Map.singleton fp (timestamp, newHash), All False)
These db@(dbTimestamp, _) (newTimestamp, _) | dbTimestamp == newTimestamp -> do
pure (Map.singleton fp db, mempty)
These (_, dbHash) (newTimestamp, getHash) -> do
newHash <- getHash
pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash))
pure (CacheInfo newInfo, getAll isUpToDate)
removeModules :: Set ModuleName -> CacheDb -> CacheDb
removeModules moduleNames = flip Map.withoutKeys moduleNames