{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE OverloadedRecordDot  #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE QuasiQuotes          #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}

{-|
Module      : Stack.Storage.Project
Description : Work with SQLite DB for caches across a project.
License     : BSD-3-Clause

Work with SQLite database used for caches across a single project.
-}

module Stack.Storage.Project
  ( initProjectStorage
  , ConfigCacheKey
  , ConfigCacheParent (..)
  , ConfigCacheParentId
  , configCacheKey
  , loadConfigCache
  , saveConfigCache
  , deactiveConfigCache
  ) where

import qualified Data.ByteString as S
import qualified Data.Set as Set
import           Database.Persist.Sqlite
                   ( Entity (..), SelectOpt (..), SqlBackend, Unique, (=.)
                   , (==.), getBy, insert, selectList, update, updateWhere
                   )
import           Database.Persist.TH
                   ( mkMigrate, mkPersist, persistLowerCase, share
                   , sqlSettings
                   )
import           Pantry.SQLite ( initStorage, withStorage_ )
import           Stack.Prelude
import           Stack.Storage.Util
                   ( handleMigrationException, listUpdateDiff, setUpdateDiff
                   , updateCollection
                   )
import           Stack.Types.Build ( CachePkgSrc, ConfigCache (..) )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.Cache ( ConfigCacheType )
import           Stack.Types.ConfigureOpts
                   ( ConfigureOpts (..), configureOptsFromDb )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Storage ( ProjectStorage (..) )

share [ mkPersist sqlSettings
      , mkMigrate "migrateAll"
      ]
      [persistLowerCase|
ConfigCacheParent sql="config_cache"
  directory FilePath default="(hex(randomblob(16)))"
  type ConfigCacheType
  pkgSrc CachePkgSrc
  active Bool
  pathEnvVar Text
  haddock Bool default=0
  UniqueConfigCacheParent directory type sql="unique_config_cache"
  deriving Show

ConfigCacheDirOption
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  index Int
  value String sql="option"
  UniqueConfigCacheDirOption parent index
  deriving Show

ConfigCacheNoDirOption
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  index Int
  value String sql="option"
  UniqueConfigCacheNoDirOption parent index
  deriving Show

ConfigCacheDep
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  value GhcPkgId sql="ghc_pkg_id"
  UniqueConfigCacheDep parent value
  deriving Show

ConfigCacheComponent
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  value S.ByteString sql="component"
  UniqueConfigCacheComponent parent value
  deriving Show
|]

-- | Initialize the database.

initProjectStorage ::
     HasLogFunc env
  => Path Abs File -- ^ storage file

  -> (ProjectStorage -> RIO env a)
  -> RIO env a
initProjectStorage :: forall env a.
HasLogFunc env =>
Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
fp ProjectStorage -> RIO env a
f = RIO env a -> RIO env a
forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$
  Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
initStorage Text
"Stack" Migration
migrateAll Path Abs File
fp ((Storage -> RIO env a) -> RIO env a)
-> (Storage -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ ProjectStorage -> RIO env a
f (ProjectStorage -> RIO env a)
-> (Storage -> ProjectStorage) -> Storage -> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Storage -> ProjectStorage
ProjectStorage

-- | Run an action in a database transaction

withProjectStorage ::
     (HasBuildConfig env, HasLogFunc env)
  => ReaderT SqlBackend (RIO env) a
  -> RIO env a
withProjectStorage :: forall env a.
(HasBuildConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withProjectStorage ReaderT SqlBackend (RIO env) a
inner = do
  Storage
storage <- Getting Storage env Storage -> RIO env Storage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((BuildConfig -> Const Storage BuildConfig)
-> env -> Const Storage env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const Storage BuildConfig)
 -> env -> Const Storage env)
-> ((Storage -> Const Storage Storage)
    -> BuildConfig -> Const Storage BuildConfig)
-> Getting Storage env Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Storage) -> SimpleGetter BuildConfig Storage
forall s a. (s -> a) -> SimpleGetter s a
to (.projectStorage.projectStorage))
  Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage_ Storage
storage ReaderT SqlBackend (RIO env) a
inner

-- | Key used to retrieve configuration or flag cache

type ConfigCacheKey = Unique ConfigCacheParent

-- | Build key used to retrieve configuration or flag cache

configCacheKey :: Path Abs Dir -> ConfigCacheType -> ConfigCacheKey
configCacheKey :: Path Abs Dir -> ConfigCacheType -> Unique ConfigCacheParent
configCacheKey Path Abs Dir
dir = String -> ConfigCacheType -> Unique ConfigCacheParent
UniqueConfigCacheParent (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
dir)

-- | Internal helper to read the t'ConfigCache'

readConfigCache ::
     (HasBuildConfig env, HasLogFunc env)
  => Entity ConfigCacheParent
  -> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache :: forall env.
(HasBuildConfig env, HasLogFunc env) =>
Entity ConfigCacheParent
-> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache (Entity Key ConfigCacheParent
parentId ConfigCacheParent
configCacheParent) = do
  let pkgSrc :: CachePkgSrc
pkgSrc = ConfigCacheParent
configCacheParent.configCacheParentPkgSrc
  [Entity ConfigCacheDirOption]
pathRelatedInfo <-
    [Filter ConfigCacheDirOption]
-> [SelectOpt ConfigCacheDirOption]
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheDirOption]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
      [EntityField ConfigCacheDirOption (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheDirOption typ
ConfigCacheDirOptionParent EntityField ConfigCacheDirOption (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheDirOption
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId]
      [EntityField ConfigCacheDirOption Int
-> SelectOpt ConfigCacheDirOption
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField ConfigCacheDirOption Int
forall typ. (typ ~ Int) => EntityField ConfigCacheDirOption typ
ConfigCacheDirOptionIndex]
  [Entity ConfigCacheNoDirOption]
nonPathRelatedInfo <-
    [Filter ConfigCacheNoDirOption]
-> [SelectOpt ConfigCacheNoDirOption]
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheNoDirOption]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
      [EntityField ConfigCacheNoDirOption (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheNoDirOption typ
ConfigCacheNoDirOptionParent EntityField ConfigCacheNoDirOption (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheNoDirOption
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId]
      [EntityField ConfigCacheNoDirOption Int
-> SelectOpt ConfigCacheNoDirOption
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField ConfigCacheNoDirOption Int
forall typ. (typ ~ Int) => EntityField ConfigCacheNoDirOption typ
ConfigCacheNoDirOptionIndex]
  let configureOpts :: ConfigureOpts
configureOpts = [Entity ConfigCacheDirOption]
-> [Entity ConfigCacheNoDirOption] -> ConfigureOpts
forall b1 b2.
(HasField "configCacheDirOptionValue" b1 String,
 HasField "configCacheNoDirOptionValue" b2 String) =>
[Entity b1] -> [Entity b2] -> ConfigureOpts
configureOptsFromDb [Entity ConfigCacheDirOption]
pathRelatedInfo [Entity ConfigCacheNoDirOption]
nonPathRelatedInfo
  Set GhcPkgId
deps <-
    [GhcPkgId] -> Set GhcPkgId
forall a. Ord a => [a] -> Set a
Set.fromList ([GhcPkgId] -> Set GhcPkgId)
-> ([Entity ConfigCacheDep] -> [GhcPkgId])
-> [Entity ConfigCacheDep]
-> Set GhcPkgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity ConfigCacheDep -> GhcPkgId)
-> [Entity ConfigCacheDep] -> [GhcPkgId]
forall a b. (a -> b) -> [a] -> [b]
map ((.configCacheDepValue) (ConfigCacheDep -> GhcPkgId)
-> (Entity ConfigCacheDep -> ConfigCacheDep)
-> Entity ConfigCacheDep
-> GhcPkgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity ConfigCacheDep -> ConfigCacheDep
forall record. Entity record -> record
entityVal) ([Entity ConfigCacheDep] -> Set GhcPkgId)
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheDep]
-> ReaderT SqlBackend (RIO env) (Set GhcPkgId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [Filter ConfigCacheDep]
-> [SelectOpt ConfigCacheDep]
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheDep]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [EntityField ConfigCacheDep (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheDep typ
ConfigCacheDepParent EntityField ConfigCacheDep (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheDep
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId] []
  Set ByteString
components <-
    [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([Entity ConfigCacheComponent] -> [ByteString])
-> [Entity ConfigCacheComponent]
-> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity ConfigCacheComponent -> ByteString)
-> [Entity ConfigCacheComponent] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((.configCacheComponentValue) (ConfigCacheComponent -> ByteString)
-> (Entity ConfigCacheComponent -> ConfigCacheComponent)
-> Entity ConfigCacheComponent
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity ConfigCacheComponent -> ConfigCacheComponent
forall record. Entity record -> record
entityVal) ([Entity ConfigCacheComponent] -> Set ByteString)
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheComponent]
-> ReaderT SqlBackend (RIO env) (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [Filter ConfigCacheComponent]
-> [SelectOpt ConfigCacheComponent]
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheComponent]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [EntityField ConfigCacheComponent (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheComponent typ
ConfigCacheComponentParent EntityField ConfigCacheComponent (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheComponent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId] []
  let pathEnvVar :: Text
pathEnvVar = ConfigCacheParent
configCacheParent.configCacheParentPathEnvVar
  let buildHaddocks :: Bool
buildHaddocks = ConfigCacheParent
configCacheParent.configCacheParentHaddock
  ConfigCache -> ReaderT SqlBackend (RIO env) ConfigCache
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigCache
    { ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts
    , Set GhcPkgId
deps :: Set GhcPkgId
deps :: Set GhcPkgId
deps
    , Set ByteString
components :: Set ByteString
components :: Set ByteString
components
    , Bool
buildHaddocks :: Bool
buildHaddocks :: Bool
buildHaddocks
    , CachePkgSrc
pkgSrc :: CachePkgSrc
pkgSrc :: CachePkgSrc
pkgSrc
    , Text
pathEnvVar :: Text
pathEnvVar :: Text
pathEnvVar
    }

-- | Load t'ConfigCache' from the database.

loadConfigCache ::
     (HasBuildConfig env, HasLogFunc env)
  => ConfigCacheKey
  -> RIO env (Maybe ConfigCache)
loadConfigCache :: forall env.
(HasBuildConfig env, HasLogFunc env) =>
Unique ConfigCacheParent -> RIO env (Maybe ConfigCache)
loadConfigCache Unique ConfigCacheParent
key =
  ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
-> RIO env (Maybe ConfigCache)
forall env a.
(HasBuildConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withProjectStorage (ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
 -> RIO env (Maybe ConfigCache))
-> ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
-> RIO env (Maybe ConfigCache)
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Entity ConfigCacheParent)
mparent <- Unique ConfigCacheParent
-> ReaderT SqlBackend (RIO env) (Maybe (Entity ConfigCacheParent))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy Unique ConfigCacheParent
key
    case Maybe (Entity ConfigCacheParent)
mparent of
      Maybe (Entity ConfigCacheParent)
Nothing -> Maybe ConfigCache
-> ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConfigCache
forall a. Maybe a
Nothing
      Just parentEntity :: Entity ConfigCacheParent
parentEntity@(Entity Key ConfigCacheParent
_ ConfigCacheParent
configCacheParent)
        |  ConfigCacheParent
configCacheParent.configCacheParentActive ->
            ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just (ConfigCache -> Maybe ConfigCache)
-> ReaderT SqlBackend (RIO env) ConfigCache
-> ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Entity ConfigCacheParent
-> ReaderT SqlBackend (RIO env) ConfigCache
forall env.
(HasBuildConfig env, HasLogFunc env) =>
Entity ConfigCacheParent
-> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache Entity ConfigCacheParent
parentEntity
        | Bool
otherwise -> Maybe ConfigCache
-> ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConfigCache
forall a. Maybe a
Nothing

-- | Insert or update t'ConfigCache' to the database.

saveConfigCache ::
     (HasBuildConfig env, HasLogFunc env)
  => ConfigCacheKey
  -> ConfigCache
  -> RIO env ()
saveConfigCache :: forall env.
(HasBuildConfig env, HasLogFunc env) =>
Unique ConfigCacheParent -> ConfigCache -> RIO env ()
saveConfigCache key :: Unique ConfigCacheParent
key@(UniqueConfigCacheParent String
dir ConfigCacheType
type_) ConfigCache
new =
  ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasBuildConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withProjectStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Entity ConfigCacheParent)
mparent <- Unique ConfigCacheParent
-> ReaderT SqlBackend (RIO env) (Maybe (Entity ConfigCacheParent))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy Unique ConfigCacheParent
key
    (Key ConfigCacheParent
parentId, Maybe ConfigCache
mold) <-
      case Maybe (Entity ConfigCacheParent)
mparent of
        Maybe (Entity ConfigCacheParent)
Nothing ->
          (, Maybe ConfigCache
forall a. Maybe a
Nothing) (Key ConfigCacheParent
 -> (Key ConfigCacheParent, Maybe ConfigCache))
-> ReaderT SqlBackend (RIO env) (Key ConfigCacheParent)
-> ReaderT
     SqlBackend (RIO env) (Key ConfigCacheParent, Maybe ConfigCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          ConfigCacheParent
-> ReaderT SqlBackend (RIO env) (Key ConfigCacheParent)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m (Key record)
insert
            ConfigCacheParent
              { configCacheParentDirectory :: String
configCacheParentDirectory = String
dir
              , configCacheParentType :: ConfigCacheType
configCacheParentType = ConfigCacheType
type_
              , configCacheParentPkgSrc :: CachePkgSrc
configCacheParentPkgSrc = ConfigCache
new.pkgSrc
              , configCacheParentActive :: Bool
configCacheParentActive = Bool
True
              , configCacheParentPathEnvVar :: Text
configCacheParentPathEnvVar = ConfigCache
new.pathEnvVar
              , configCacheParentHaddock :: Bool
configCacheParentHaddock = ConfigCache
new.buildHaddocks
              }
        Just parentEntity :: Entity ConfigCacheParent
parentEntity@(Entity Key ConfigCacheParent
parentId ConfigCacheParent
_) -> do
          ConfigCache
old <- Entity ConfigCacheParent
-> ReaderT SqlBackend (RIO env) ConfigCache
forall env.
(HasBuildConfig env, HasLogFunc env) =>
Entity ConfigCacheParent
-> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache Entity ConfigCacheParent
parentEntity
          Key ConfigCacheParent
-> [Update ConfigCacheParent] -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> [Update record] -> ReaderT SqlBackend m ()
update
            Key ConfigCacheParent
parentId
            [ EntityField ConfigCacheParent CachePkgSrc
forall typ.
(typ ~ CachePkgSrc) =>
EntityField ConfigCacheParent typ
ConfigCacheParentPkgSrc EntityField ConfigCacheParent CachePkgSrc
-> CachePkgSrc -> Update ConfigCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. ConfigCache
new.pkgSrc
            , EntityField ConfigCacheParent Bool
forall typ. (typ ~ Bool) => EntityField ConfigCacheParent typ
ConfigCacheParentActive EntityField ConfigCacheParent Bool
-> Bool -> Update ConfigCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Bool
True
            , EntityField ConfigCacheParent Text
forall typ. (typ ~ Text) => EntityField ConfigCacheParent typ
ConfigCacheParentPathEnvVar EntityField ConfigCacheParent Text
-> Text -> Update ConfigCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. ConfigCache
new.pathEnvVar
            ]
          (Key ConfigCacheParent, Maybe ConfigCache)
-> ReaderT
     SqlBackend (RIO env) (Key ConfigCacheParent, Maybe ConfigCache)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key ConfigCacheParent
parentId, ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just ConfigCache
old)
    ([String]
 -> [String] -> ([Filter ConfigCacheDirOption], [(Int, String)]))
-> ((Int, String) -> ConfigCacheDirOption)
-> [Filter ConfigCacheDirOption]
-> [String]
-> [String]
-> ReaderT SqlBackend (RIO env) ()
forall record backend (collection :: * -> *) rawValue value
       (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 Eq (collection rawValue), PersistEntity record, PersistField value,
 MonadIO m, PersistQueryWrite backend, SafeToInsert record,
 Foldable collection) =>
(collection rawValue
 -> collection rawValue -> ([Filter record], [value]))
-> (value -> record)
-> [Filter record]
-> collection rawValue
-> collection rawValue
-> ReaderT backend m ()
updateCollection
      (EntityField ConfigCacheDirOption Int
-> [String]
-> [String]
-> ([Filter ConfigCacheDirOption], [(Int, String)])
forall value record.
Ord value =>
EntityField record Int
-> [value] -> [value] -> ([Filter record], [(Int, value)])
listUpdateDiff EntityField ConfigCacheDirOption Int
forall typ. (typ ~ Int) => EntityField ConfigCacheDirOption typ
ConfigCacheDirOptionIndex)
      ((Int -> String -> ConfigCacheDirOption)
-> (Int, String) -> ConfigCacheDirOption
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> String -> ConfigCacheDirOption)
 -> (Int, String) -> ConfigCacheDirOption)
-> (Int -> String -> ConfigCacheDirOption)
-> (Int, String)
-> ConfigCacheDirOption
forall a b. (a -> b) -> a -> b
$ Key ConfigCacheParent -> Int -> String -> ConfigCacheDirOption
ConfigCacheDirOption Key ConfigCacheParent
parentId)
      [EntityField ConfigCacheDirOption (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheDirOption typ
ConfigCacheDirOptionParent EntityField ConfigCacheDirOption (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheDirOption
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId]
      ([String]
-> (ConfigCache -> [String]) -> Maybe ConfigCache -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (.configureOpts.pathRelated) Maybe ConfigCache
mold)
      ConfigCache
new.configureOpts.pathRelated
    ([String]
 -> [String] -> ([Filter ConfigCacheNoDirOption], [(Int, String)]))
-> ((Int, String) -> ConfigCacheNoDirOption)
-> [Filter ConfigCacheNoDirOption]
-> [String]
-> [String]
-> ReaderT SqlBackend (RIO env) ()
forall record backend (collection :: * -> *) rawValue value
       (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 Eq (collection rawValue), PersistEntity record, PersistField value,
 MonadIO m, PersistQueryWrite backend, SafeToInsert record,
 Foldable collection) =>
(collection rawValue
 -> collection rawValue -> ([Filter record], [value]))
-> (value -> record)
-> [Filter record]
-> collection rawValue
-> collection rawValue
-> ReaderT backend m ()
updateCollection
      (EntityField ConfigCacheNoDirOption Int
-> [String]
-> [String]
-> ([Filter ConfigCacheNoDirOption], [(Int, String)])
forall value record.
Ord value =>
EntityField record Int
-> [value] -> [value] -> ([Filter record], [(Int, value)])
listUpdateDiff EntityField ConfigCacheNoDirOption Int
forall typ. (typ ~ Int) => EntityField ConfigCacheNoDirOption typ
ConfigCacheNoDirOptionIndex)
      ((Int -> String -> ConfigCacheNoDirOption)
-> (Int, String) -> ConfigCacheNoDirOption
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> String -> ConfigCacheNoDirOption)
 -> (Int, String) -> ConfigCacheNoDirOption)
-> (Int -> String -> ConfigCacheNoDirOption)
-> (Int, String)
-> ConfigCacheNoDirOption
forall a b. (a -> b) -> a -> b
$ Key ConfigCacheParent -> Int -> String -> ConfigCacheNoDirOption
ConfigCacheNoDirOption Key ConfigCacheParent
parentId)
      [EntityField ConfigCacheNoDirOption (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheNoDirOption typ
ConfigCacheNoDirOptionParent EntityField ConfigCacheNoDirOption (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheNoDirOption
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId]
      ([String]
-> (ConfigCache -> [String]) -> Maybe ConfigCache -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (.configureOpts.nonPathRelated) Maybe ConfigCache
mold)
      ConfigCache
new.configureOpts.nonPathRelated
    (Set GhcPkgId
 -> Set GhcPkgId -> ([Filter ConfigCacheDep], [GhcPkgId]))
-> (GhcPkgId -> ConfigCacheDep)
-> [Filter ConfigCacheDep]
-> Set GhcPkgId
-> Set GhcPkgId
-> ReaderT SqlBackend (RIO env) ()
forall record backend (collection :: * -> *) rawValue value
       (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 Eq (collection rawValue), PersistEntity record, PersistField value,
 MonadIO m, PersistQueryWrite backend, SafeToInsert record,
 Foldable collection) =>
(collection rawValue
 -> collection rawValue -> ([Filter record], [value]))
-> (value -> record)
-> [Filter record]
-> collection rawValue
-> collection rawValue
-> ReaderT backend m ()
updateCollection
      (EntityField ConfigCacheDep GhcPkgId
-> Set GhcPkgId
-> Set GhcPkgId
-> ([Filter ConfigCacheDep], [GhcPkgId])
forall value record.
(Ord value, PersistField value) =>
EntityField record value
-> Set value -> Set value -> ([Filter record], [value])
setUpdateDiff EntityField ConfigCacheDep GhcPkgId
forall typ. (typ ~ GhcPkgId) => EntityField ConfigCacheDep typ
ConfigCacheDepValue)
      (Key ConfigCacheParent -> GhcPkgId -> ConfigCacheDep
ConfigCacheDep Key ConfigCacheParent
parentId)
      [EntityField ConfigCacheDep (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheDep typ
ConfigCacheDepParent EntityField ConfigCacheDep (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheDep
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId]
      (Set GhcPkgId
-> (ConfigCache -> Set GhcPkgId)
-> Maybe ConfigCache
-> Set GhcPkgId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set GhcPkgId
forall a. Set a
Set.empty (.deps) Maybe ConfigCache
mold)
      ConfigCache
new.deps
    (Set ByteString
 -> Set ByteString -> ([Filter ConfigCacheComponent], [ByteString]))
-> (ByteString -> ConfigCacheComponent)
-> [Filter ConfigCacheComponent]
-> Set ByteString
-> Set ByteString
-> ReaderT SqlBackend (RIO env) ()
forall record backend (collection :: * -> *) rawValue value
       (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 Eq (collection rawValue), PersistEntity record, PersistField value,
 MonadIO m, PersistQueryWrite backend, SafeToInsert record,
 Foldable collection) =>
(collection rawValue
 -> collection rawValue -> ([Filter record], [value]))
-> (value -> record)
-> [Filter record]
-> collection rawValue
-> collection rawValue
-> ReaderT backend m ()
updateCollection
      (EntityField ConfigCacheComponent ByteString
-> Set ByteString
-> Set ByteString
-> ([Filter ConfigCacheComponent], [ByteString])
forall value record.
(Ord value, PersistField value) =>
EntityField record value
-> Set value -> Set value -> ([Filter record], [value])
setUpdateDiff EntityField ConfigCacheComponent ByteString
forall typ.
(typ ~ ByteString) =>
EntityField ConfigCacheComponent typ
ConfigCacheComponentValue)
      (Key ConfigCacheParent -> ByteString -> ConfigCacheComponent
ConfigCacheComponent Key ConfigCacheParent
parentId)
      [EntityField ConfigCacheComponent (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheComponent typ
ConfigCacheComponentParent EntityField ConfigCacheComponent (Key ConfigCacheParent)
-> Key ConfigCacheParent -> Filter ConfigCacheComponent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key ConfigCacheParent
parentId]
      (Set ByteString
-> (ConfigCache -> Set ByteString)
-> Maybe ConfigCache
-> Set ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set ByteString
forall a. Set a
Set.empty (.components) Maybe ConfigCache
mold)
      ConfigCache
new.components

-- | Mark t'ConfigCache' as inactive in the database. We use a flag instead of

-- deleting the records since, in most cases, the same cache will be written

-- again within in a few seconds (after `cabal configure`), so this avoids

-- unnecessary database churn.

deactiveConfigCache :: HasBuildConfig env => ConfigCacheKey -> RIO env ()
deactiveConfigCache :: forall env.
HasBuildConfig env =>
Unique ConfigCacheParent -> RIO env ()
deactiveConfigCache (UniqueConfigCacheParent String
dir ConfigCacheType
type_) =
  ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasBuildConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withProjectStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [Filter ConfigCacheParent]
-> [Update ConfigCacheParent] -> ReaderT SqlBackend (RIO env) ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> [Update record] -> ReaderT backend m ()
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> [Update record] -> ReaderT SqlBackend m ()
updateWhere
      [EntityField ConfigCacheParent String
forall typ. (typ ~ String) => EntityField ConfigCacheParent typ
ConfigCacheParentDirectory EntityField ConfigCacheParent String
-> String -> Filter ConfigCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. String
dir, EntityField ConfigCacheParent ConfigCacheType
forall typ.
(typ ~ ConfigCacheType) =>
EntityField ConfigCacheParent typ
ConfigCacheParentType EntityField ConfigCacheParent ConfigCacheType
-> ConfigCacheType -> Filter ConfigCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. ConfigCacheType
type_]
      [EntityField ConfigCacheParent Bool
forall typ. (typ ~ Bool) => EntityField ConfigCacheParent typ
ConfigCacheParentActive EntityField ConfigCacheParent Bool
-> Bool -> Update ConfigCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Bool
False]