Cache.hs

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

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

-- | A CacheInfo contains all of the information we need to store about a
-- particular module in the cache database.
newtype CacheInfo = CacheInfo
  { unCacheInfo :: Map FilePath (UTCTime, ContentHash) }
  deriving stock (Show)
  deriving newtype (Eq, Ord, Semigroup, Monoid, Aeson.FromJSON, 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 cacheDb mn basePath currentInfo = do

  let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb)
  (newInfo, isUpToDate) <-
    fmap mconcat $
      for (Map.toList (align dbInfo currentInfo)) $ \(normaliseForCache basePath -> fp, aligned) -> do
        case aligned of
          This _ -> 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
            pure (Map.empty, All False)
          That (timestamp, getHash) -> do
            -- The module has a new input file; add it to the cache and
            -- note that the module needs rebuilding.
            newHash <- getHash
            pure (Map.singleton fp (timestamp, newHash), All False)
          These db@(dbTimestamp, _) (newTimestamp, _) | dbTimestamp == newTimestamp -> do
            -- This file exists both currently and in the cache database,
            -- and the timestamp is unchanged, so we skip checking the
            -- hash.
            pure (Map.singleton fp db, mempty)
          These (_, dbHash) (newTimestamp, getHash) -> do
            -- This file exists both currently and in the cache database,
            -- but the timestamp has changed, so we need to check the hash.
            newHash <- getHash
            pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash))

  pure (CacheInfo newInfo, getAll isUpToDate)

-- | Remove any modules from the given set from the cache database; used when
-- they failed to build.
removeModules :: Set ModuleName -> CacheDb -> CacheDb
removeModules = flip 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 basePath fp =
    if FilePath.isRelative fp then
      FilePath.normalise fp
    else
      let relativePath = FilePath.makeRelative basePath fp in
      if FilePath.isRelative relativePath then
        FilePath.normalise 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
        FilePath.normalise fp