module Language.PureScript.Make.Cache
( ContentHash
, hash
, CacheDb
, CacheInfo(..)
, checkChanged
, removeModules
, normaliseForCache
) where
import Prelude
import Control.Category ((>>>))
import Control.Monad ((>=>))
import Crypto.Hash (HashAlgorithm, Digest, SHA512)
import Crypto.Hash qualified as Hash
import Data.Aeson qualified as Aeson
import Data.Align (align)
import Data.ByteArray.Encoding (Base(Base16), convertToBase, convertFromBase)
import Data.ByteString qualified as BS
import Data.Map (Map)
import Data.Map qualified 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 System.FilePath qualified as FilePath
import Language.PureScript.Names (ModuleName)
digestToHex :: Digest a -> Text
digestToHex :: forall a. Digest a -> Text
digestToHex = ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16
digestFromHex :: forall a. HashAlgorithm a => Text -> Maybe (Digest a)
digestFromHex :: forall a. HashAlgorithm a => Text -> Maybe (Digest a)
digestFromHex =
Text -> ByteString
encodeUtf8
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base16
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Hash.digestFromByteString :: BS.ByteString -> Maybe (Digest a))
newtype ContentHash = ContentHash
{ ContentHash -> Digest SHA512
unContentHash :: Digest SHA512 }
deriving (Int -> ContentHash -> ShowS
[ContentHash] -> ShowS
ContentHash -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentHash] -> ShowS
$cshowList :: [ContentHash] -> ShowS
show :: ContentHash -> String
$cshow :: ContentHash -> String
showsPrec :: Int -> ContentHash -> ShowS
$cshowsPrec :: Int -> ContentHash -> ShowS
Show, ContentHash -> ContentHash -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentHash -> ContentHash -> Bool
$c/= :: ContentHash -> ContentHash -> Bool
== :: ContentHash -> ContentHash -> Bool
$c== :: ContentHash -> ContentHash -> Bool
Eq, Eq ContentHash
ContentHash -> ContentHash -> Bool
ContentHash -> ContentHash -> Ordering
ContentHash -> ContentHash -> ContentHash
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 :: ContentHash -> ContentHash -> ContentHash
$cmin :: ContentHash -> ContentHash -> ContentHash
max :: ContentHash -> ContentHash -> ContentHash
$cmax :: ContentHash -> ContentHash -> ContentHash
>= :: ContentHash -> ContentHash -> Bool
$c>= :: ContentHash -> ContentHash -> Bool
> :: ContentHash -> ContentHash -> Bool
$c> :: ContentHash -> ContentHash -> Bool
<= :: ContentHash -> ContentHash -> Bool
$c<= :: ContentHash -> ContentHash -> Bool
< :: ContentHash -> ContentHash -> Bool
$c< :: ContentHash -> ContentHash -> Bool
compare :: ContentHash -> ContentHash -> Ordering
$ccompare :: ContentHash -> ContentHash -> Ordering
Ord)
instance Aeson.ToJSON ContentHash where
toJSON :: ContentHash -> Value
toJSON = forall a. ToJSON a => a -> Value
Aeson.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Digest a -> Text
digestToHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentHash -> Digest SHA512
unContentHash
instance Aeson.FromJSON ContentHash where
parseJSON :: Value -> Parser ContentHash
parseJSON Value
x = do
Text
str <- forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
x
case forall a. HashAlgorithm a => Text -> Maybe (Digest a)
digestFromHex Text
str of
Just Digest SHA512
digest ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Digest SHA512 -> ContentHash
ContentHash Digest SHA512
digest
Maybe (Digest SHA512)
Nothing ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to decode ContentHash"
hash :: BS.ByteString -> ContentHash
hash :: ByteString -> ContentHash
hash = Digest SHA512 -> ContentHash
ContentHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash
type CacheDb = Map ModuleName CacheInfo
newtype CacheInfo = CacheInfo
{ CacheInfo -> Map String (UTCTime, ContentHash)
unCacheInfo :: Map FilePath (UTCTime, ContentHash) }
deriving stock (Int -> CacheInfo -> ShowS
[CacheInfo] -> ShowS
CacheInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheInfo] -> ShowS
$cshowList :: [CacheInfo] -> ShowS
show :: CacheInfo -> String
$cshow :: CacheInfo -> String
showsPrec :: Int -> CacheInfo -> ShowS
$cshowsPrec :: Int -> CacheInfo -> ShowS
Show)
deriving newtype (CacheInfo -> CacheInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheInfo -> CacheInfo -> Bool
$c/= :: CacheInfo -> CacheInfo -> Bool
== :: CacheInfo -> CacheInfo -> Bool
$c== :: CacheInfo -> CacheInfo -> Bool
Eq, Eq CacheInfo
CacheInfo -> CacheInfo -> Bool
CacheInfo -> CacheInfo -> Ordering
CacheInfo -> CacheInfo -> CacheInfo
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 :: CacheInfo -> CacheInfo -> CacheInfo
$cmin :: CacheInfo -> CacheInfo -> CacheInfo
max :: CacheInfo -> CacheInfo -> CacheInfo
$cmax :: CacheInfo -> CacheInfo -> CacheInfo
>= :: CacheInfo -> CacheInfo -> Bool
$c>= :: CacheInfo -> CacheInfo -> Bool
> :: CacheInfo -> CacheInfo -> Bool
$c> :: CacheInfo -> CacheInfo -> Bool
<= :: CacheInfo -> CacheInfo -> Bool
$c<= :: CacheInfo -> CacheInfo -> Bool
< :: CacheInfo -> CacheInfo -> Bool
$c< :: CacheInfo -> CacheInfo -> Bool
compare :: CacheInfo -> CacheInfo -> Ordering
$ccompare :: CacheInfo -> CacheInfo -> Ordering
Ord, NonEmpty CacheInfo -> CacheInfo
CacheInfo -> CacheInfo -> CacheInfo
forall b. Integral b => b -> CacheInfo -> CacheInfo
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> CacheInfo -> CacheInfo
$cstimes :: forall b. Integral b => b -> CacheInfo -> CacheInfo
sconcat :: NonEmpty CacheInfo -> CacheInfo
$csconcat :: NonEmpty CacheInfo -> CacheInfo
<> :: CacheInfo -> CacheInfo -> CacheInfo
$c<> :: CacheInfo -> CacheInfo -> CacheInfo
Semigroup, Semigroup CacheInfo
CacheInfo
[CacheInfo] -> CacheInfo
CacheInfo -> CacheInfo -> CacheInfo
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CacheInfo] -> CacheInfo
$cmconcat :: [CacheInfo] -> CacheInfo
mappend :: CacheInfo -> CacheInfo -> CacheInfo
$cmappend :: CacheInfo -> CacheInfo -> CacheInfo
mempty :: CacheInfo
$cmempty :: CacheInfo
Monoid, Value -> Parser [CacheInfo]
Value -> Parser CacheInfo
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CacheInfo]
$cparseJSONList :: Value -> Parser [CacheInfo]
parseJSON :: Value -> Parser CacheInfo
$cparseJSON :: Value -> Parser CacheInfo
Aeson.FromJSON, [CacheInfo] -> Encoding
[CacheInfo] -> Value
CacheInfo -> Encoding
CacheInfo -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CacheInfo] -> Encoding
$ctoEncodingList :: [CacheInfo] -> Encoding
toJSONList :: [CacheInfo] -> Value
$ctoJSONList :: [CacheInfo] -> Value
toEncoding :: CacheInfo -> Encoding
$ctoEncoding :: CacheInfo -> Encoding
toJSON :: CacheInfo -> Value
$ctoJSON :: CacheInfo -> Value
Aeson.ToJSON)
checkChanged
:: Monad m
=> CacheDb
-> ModuleName
-> FilePath
-> Map FilePath (UTCTime, m ContentHash)
-> m (CacheInfo, Bool)
checkChanged :: forall (m :: * -> *).
Monad m =>
CacheDb
-> ModuleName
-> String
-> Map String (UTCTime, m ContentHash)
-> m (CacheInfo, Bool)
checkChanged CacheDb
cacheDb ModuleName
mn String
basePath Map String (UTCTime, m ContentHash)
currentInfo = do
let dbInfo :: Map String (UTCTime, ContentHash)
dbInfo = CacheInfo -> Map String (UTCTime, ContentHash)
unCacheInfo forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mn CacheDb
cacheDb)
(Map String (UTCTime, ContentHash)
newInfo, All
isUpToDate) <-
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall k a. Map k a -> [(k, a)]
Map.toList (forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align Map String (UTCTime, ContentHash)
dbInfo Map String (UTCTime, m ContentHash)
currentInfo)) forall a b. (a -> b) -> a -> b
$ \(String -> ShowS
normaliseForCache String
basePath -> String
fp, These (UTCTime, ContentHash) (UTCTime, m ContentHash)
aligned) -> do
case These (UTCTime, ContentHash) (UTCTime, m ContentHash)
aligned of
This (UTCTime, ContentHash)
_ -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Map k a
Map.empty, Bool -> All
All Bool
False)
That (UTCTime
timestamp, m ContentHash
getHash) -> do
ContentHash
newHash <- m ContentHash
getHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. k -> a -> Map k a
Map.singleton String
fp (UTCTime
timestamp, ContentHash
newHash), Bool -> All
All Bool
False)
These db :: (UTCTime, ContentHash)
db@(UTCTime
dbTimestamp, ContentHash
_) (UTCTime
newTimestamp, m ContentHash
_) | UTCTime
dbTimestamp forall a. Eq a => a -> a -> Bool
== UTCTime
newTimestamp -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. k -> a -> Map k a
Map.singleton String
fp (UTCTime, ContentHash)
db, forall a. Monoid a => a
mempty)
These (UTCTime
_, ContentHash
dbHash) (UTCTime
newTimestamp, m ContentHash
getHash) -> do
ContentHash
newHash <- m ContentHash
getHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. k -> a -> Map k a
Map.singleton String
fp (UTCTime
newTimestamp, ContentHash
newHash), Bool -> All
All (ContentHash
dbHash forall a. Eq a => a -> a -> Bool
== ContentHash
newHash))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String (UTCTime, ContentHash) -> CacheInfo
CacheInfo Map String (UTCTime, ContentHash)
newInfo, All -> Bool
getAll All
isUpToDate)
removeModules :: Set ModuleName -> CacheDb -> CacheDb
removeModules :: Set ModuleName -> CacheDb -> CacheDb
removeModules = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys
normaliseForCache :: FilePath -> FilePath -> FilePath
normaliseForCache :: String -> ShowS
normaliseForCache String
basePath String
fp =
if String -> Bool
FilePath.isRelative String
fp then
ShowS
FilePath.normalise String
fp
else
let relativePath :: String
relativePath = String -> ShowS
FilePath.makeRelative String
basePath String
fp in
if String -> Bool
FilePath.isRelative String
relativePath then
ShowS
FilePath.normalise String
relativePath
else
ShowS
FilePath.normalise String
fp