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))

-- | Defines the hash algorithm we use for cache invalidation of input files.
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

-- | A CacheInfo contains all of the information we need to store about a
-- particular module in the cache database.
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)

-- | Given a module name, and a map containing the associated input files
-- together with current metadata i.e. timestamps and hashes, check whether the
-- input files have changed, based on comparing with the database stored in the
-- monadic state.
--
-- The CacheInfo in the return value should be stored in the cache for future
-- builds.
--
-- The Bool in the return value indicates whether it is safe to use existing
-- build artifacts for this module, at least based on the timestamps and hashes
-- of the module's input files.
--
-- If the timestamps are the same as those in the database, assume the file is
-- unchanged, and return True without checking hashes.
--
-- If any of the timestamps differ from what is in the database, check the
-- hashes of those files. In this case, update the database with any changed
-- timestamps and hashes, and return True if and only if all of the hashes are
-- unchanged.
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
            -- One of the input files listed in the cache no longer exists;
            -- remove that file from the cache and note that the module needs
            -- rebuilding
            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
            -- The module has a new input file; add it to the cache and
            -- note that the module needs rebuilding.
            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
            -- This file exists both currently and in the cache database,
            -- and the timestamp is unchanged, so we skip checking the
            -- hash.
            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
            -- This file exists both currently and in the cache database,
            -- but the timestamp has changed, so we need to check the hash.
            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)

-- | Remove any modules from the given set from the cache database; used when
-- they failed to build.
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

-- | 1. Any path that is beneath our current working directory will be
-- stored as a normalised relative path
-- 2. Any path that isn't will be stored as an absolute path
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
        -- If the path is still absolute after trying to make it
        -- relative to the base that means it is not underneath
        -- the base path
        ShowS
FilePath.normalise String
fp