{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}

-- | Work with SQLite database used for caches across a single project.
module Stack.Storage.Project
    ( initProjectStorage
    , ConfigCacheKey
    , configCacheKey
    , loadConfigCache
    , saveConfigCache
    , deactiveConfigCache
    ) where

import qualified Data.ByteString as S
import qualified Data.Set as Set
import Database.Persist.Sqlite
import Database.Persist.TH
import qualified Pantry.Internal as SQLite
import Path
import Stack.Prelude hiding (MigrationFailure)
import Stack.Storage.Util
import Stack.Types.Build
import Stack.Types.Cache
import Stack.Types.Config (HasBuildConfig, buildConfigL, bcProjectStorage, ProjectStorage (..))
import Stack.Types.GhcPkgId

share [ mkPersist sqlSettings
      , mkDeleteCascade 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"
  index Int
  value String sql="option"
  UniqueConfigCacheDirOption parent index
  deriving Show

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

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

ConfigCacheComponent
  parent ConfigCacheParentId sql="config_cache_id"
  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 :: Path Abs File -> (ProjectStorage -> RIO env a) -> RIO env a
initProjectStorage Path Abs File
fp ProjectStorage -> RIO env a
f = 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
SQLite.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 :: ReaderT SqlBackend (RIO env) a -> RIO env a
withProjectStorage ReaderT SqlBackend (RIO env) a
inner =
    (Storage -> ReaderT SqlBackend (RIO env) a -> RIO env a)
-> ReaderT SqlBackend (RIO env) a -> Storage -> RIO env a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Storage -> ReaderT SqlBackend (RIO env) a -> RIO env a
Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
SQLite.withStorage_ ReaderT SqlBackend (RIO env) a
inner (Storage -> RIO env a) -> RIO env Storage -> RIO env a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
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 -> ProjectStorage)
-> SimpleGetter BuildConfig ProjectStorage
forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> ProjectStorage
bcProjectStorage Getting Storage BuildConfig ProjectStorage
-> ((Storage -> Const Storage Storage)
    -> ProjectStorage -> Const Storage ProjectStorage)
-> (Storage -> Const Storage Storage)
-> BuildConfig
-> Const Storage BuildConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectStorage -> Storage) -> SimpleGetter ProjectStorage Storage
forall s a. (s -> a) -> SimpleGetter s a
to ProjectStorage -> Storage
unProjectStorage)

-- | 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 'ConfigCache'
readConfigCache ::
       (HasBuildConfig env, HasLogFunc env)
    => Entity ConfigCacheParent
    -> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache :: Entity ConfigCacheParent
-> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache (Entity Key ConfigCacheParent
parentId ConfigCacheParent {Bool
String
Text
ConfigCacheType
CachePkgSrc
configCacheParentHaddock :: Bool
configCacheParentPathEnvVar :: Text
configCacheParentActive :: Bool
configCacheParentPkgSrc :: CachePkgSrc
configCacheParentType :: ConfigCacheType
configCacheParentDirectory :: String
configCacheParentHaddock :: ConfigCacheParent -> Bool
configCacheParentPathEnvVar :: ConfigCacheParent -> Text
configCacheParentActive :: ConfigCacheParent -> Bool
configCacheParentPkgSrc :: ConfigCacheParent -> CachePkgSrc
configCacheParentType :: ConfigCacheParent -> ConfigCacheType
configCacheParentDirectory :: ConfigCacheParent -> String
..}) = do
    let configCachePkgSrc :: CachePkgSrc
configCachePkgSrc = CachePkgSrc
configCacheParentPkgSrc
    [String]
coDirs <-
        (Entity ConfigCacheDirOption -> String)
-> [Entity ConfigCacheDirOption] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ConfigCacheDirOption -> String
configCacheDirOptionValue (ConfigCacheDirOption -> String)
-> (Entity ConfigCacheDirOption -> ConfigCacheDirOption)
-> Entity ConfigCacheDirOption
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity ConfigCacheDirOption -> ConfigCacheDirOption
forall record. Entity record -> record
entityVal) ([Entity ConfigCacheDirOption] -> [String])
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheDirOption]
-> ReaderT SqlBackend (RIO env) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [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]
    [String]
coNoDirs <-
        (Entity ConfigCacheNoDirOption -> String)
-> [Entity ConfigCacheNoDirOption] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ConfigCacheNoDirOption -> String
configCacheNoDirOptionValue (ConfigCacheNoDirOption -> String)
-> (Entity ConfigCacheNoDirOption -> ConfigCacheNoDirOption)
-> Entity ConfigCacheNoDirOption
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity ConfigCacheNoDirOption -> ConfigCacheNoDirOption
forall record. Entity record -> record
entityVal) ([Entity ConfigCacheNoDirOption] -> [String])
-> ReaderT SqlBackend (RIO env) [Entity ConfigCacheNoDirOption]
-> ReaderT SqlBackend (RIO env) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [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 configCacheOpts :: ConfigureOpts
configCacheOpts = ConfigureOpts :: [String] -> [String] -> ConfigureOpts
ConfigureOpts {[String]
coNoDirs :: [String]
coDirs :: [String]
coNoDirs :: [String]
coDirs :: [String]
..}
    Set GhcPkgId
configCacheDeps <-
        [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 (ConfigCacheDep -> GhcPkgId
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
configCacheComponents <-
        [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 (ConfigCacheComponent -> ByteString
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 configCachePathEnvVar :: Text
configCachePathEnvVar = Text
configCacheParentPathEnvVar
    let configCacheHaddock :: Bool
configCacheHaddock = Bool
configCacheParentHaddock
    ConfigCache -> ReaderT SqlBackend (RIO env) ConfigCache
forall (m :: * -> *) a. Monad m => a -> m a
return ConfigCache :: ConfigureOpts
-> Set GhcPkgId
-> Set ByteString
-> Bool
-> CachePkgSrc
-> Text
-> ConfigCache
ConfigCache {Bool
Set ByteString
Set GhcPkgId
Text
ConfigureOpts
CachePkgSrc
configCachePathEnvVar :: Text
configCachePkgSrc :: CachePkgSrc
configCacheHaddock :: Bool
configCacheComponents :: Set ByteString
configCacheDeps :: Set GhcPkgId
configCacheOpts :: ConfigureOpts
configCacheHaddock :: Bool
configCachePathEnvVar :: Text
configCacheComponents :: Set ByteString
configCacheDeps :: Set GhcPkgId
configCacheOpts :: ConfigureOpts
configCachePkgSrc :: CachePkgSrc
..}

-- | Load 'ConfigCache' from the database.
loadConfigCache ::
       (HasBuildConfig env, HasLogFunc env)
    => ConfigCacheKey
    -> RIO env (Maybe ConfigCache)
loadConfigCache :: 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))
getBy Unique ConfigCacheParent
key
        case Maybe (Entity ConfigCacheParent)
mparent of
            Maybe (Entity ConfigCacheParent)
Nothing -> Maybe ConfigCache
-> ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConfigCache
forall a. Maybe a
Nothing
            Just parentEntity :: Entity ConfigCacheParent
parentEntity@(Entity Key ConfigCacheParent
_ ConfigCacheParent {Bool
String
Text
ConfigCacheType
CachePkgSrc
configCacheParentHaddock :: Bool
configCacheParentPathEnvVar :: Text
configCacheParentActive :: Bool
configCacheParentPkgSrc :: CachePkgSrc
configCacheParentType :: ConfigCacheType
configCacheParentDirectory :: String
configCacheParentHaddock :: ConfigCacheParent -> Bool
configCacheParentPathEnvVar :: ConfigCacheParent -> Text
configCacheParentActive :: ConfigCacheParent -> Bool
configCacheParentPkgSrc :: ConfigCacheParent -> CachePkgSrc
configCacheParentType :: ConfigCacheParent -> ConfigCacheType
configCacheParentDirectory :: ConfigCacheParent -> String
..})
                | Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe ConfigCache
forall a. Maybe a
Nothing

-- | Insert or update 'ConfigCache' to the database.
saveConfigCache ::
       (HasBuildConfig env, HasLogFunc env)
    => ConfigCacheKey
    -> ConfigCache
    -> RIO env ()
saveConfigCache :: Unique ConfigCacheParent -> ConfigCache -> RIO env ()
saveConfigCache key :: Unique ConfigCacheParent
key@(UniqueConfigCacheParent dir 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))
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) =>
record -> ReaderT backend m (Key record)
insert
                        ConfigCacheParent :: String
-> ConfigCacheType
-> CachePkgSrc
-> Bool
-> Text
-> Bool
-> ConfigCacheParent
ConfigCacheParent
                            { configCacheParentDirectory :: String
configCacheParentDirectory = String
dir
                            , configCacheParentType :: ConfigCacheType
configCacheParentType = ConfigCacheType
type_
                            , configCacheParentPkgSrc :: CachePkgSrc
configCacheParentPkgSrc = ConfigCache -> CachePkgSrc
configCachePkgSrc ConfigCache
new
                            , configCacheParentActive :: Bool
configCacheParentActive = Bool
True
                            , configCacheParentPathEnvVar :: Text
configCacheParentPathEnvVar = ConfigCache -> Text
configCachePathEnvVar ConfigCache
new
                            , configCacheParentHaddock :: Bool
configCacheParentHaddock = ConfigCache -> Bool
configCacheHaddock ConfigCache
new
                            }
                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 ()
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 -> CachePkgSrc
configCachePkgSrc ConfigCache
new
                        , 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 -> Text
configCachePathEnvVar ConfigCache
new
                        ]
                    (Key ConfigCacheParent, Maybe ConfigCache)
-> ReaderT
     SqlBackend (RIO env) (Key ConfigCacheParent, Maybe ConfigCache)
forall (m :: * -> *) a. Monad m => a -> m a
return (Key ConfigCacheParent
parentId, ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just ConfigCache
old)
        (Key ConfigCacheParent -> Int -> String -> ConfigCacheDirOption)
-> EntityField ConfigCacheDirOption (Key ConfigCacheParent)
-> Key ConfigCacheParent
-> EntityField ConfigCacheDirOption Int
-> [String]
-> [String]
-> ReaderT SqlBackend (RIO env) ()
forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, Ord value, PersistEntity record, MonadIO m,
 PersistQueryWrite backend) =>
(parentid -> Int -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record Int
-> [value]
-> [value]
-> ReaderT backend m ()
updateList
            Key ConfigCacheParent -> Int -> String -> ConfigCacheDirOption
ConfigCacheDirOption
            EntityField ConfigCacheDirOption (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheDirOption typ
ConfigCacheDirOptionParent
            Key ConfigCacheParent
parentId
            EntityField ConfigCacheDirOption Int
forall typ. (typ ~ Int) => EntityField ConfigCacheDirOption typ
ConfigCacheDirOptionIndex
            ([String]
-> (ConfigCache -> [String]) -> Maybe ConfigCache -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (ConfigureOpts -> [String]
coDirs (ConfigureOpts -> [String])
-> (ConfigCache -> ConfigureOpts) -> ConfigCache -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigCache -> ConfigureOpts
configCacheOpts) Maybe ConfigCache
mold)
            (ConfigureOpts -> [String]
coDirs (ConfigureOpts -> [String]) -> ConfigureOpts -> [String]
forall a b. (a -> b) -> a -> b
$ ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
new)
        (Key ConfigCacheParent -> Int -> String -> ConfigCacheNoDirOption)
-> EntityField ConfigCacheNoDirOption (Key ConfigCacheParent)
-> Key ConfigCacheParent
-> EntityField ConfigCacheNoDirOption Int
-> [String]
-> [String]
-> ReaderT SqlBackend (RIO env) ()
forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, Ord value, PersistEntity record, MonadIO m,
 PersistQueryWrite backend) =>
(parentid -> Int -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record Int
-> [value]
-> [value]
-> ReaderT backend m ()
updateList
            Key ConfigCacheParent -> Int -> String -> ConfigCacheNoDirOption
ConfigCacheNoDirOption
            EntityField ConfigCacheNoDirOption (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheNoDirOption typ
ConfigCacheNoDirOptionParent
            Key ConfigCacheParent
parentId
            EntityField ConfigCacheNoDirOption Int
forall typ. (typ ~ Int) => EntityField ConfigCacheNoDirOption typ
ConfigCacheNoDirOptionIndex
            ([String]
-> (ConfigCache -> [String]) -> Maybe ConfigCache -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (ConfigureOpts -> [String]
coNoDirs (ConfigureOpts -> [String])
-> (ConfigCache -> ConfigureOpts) -> ConfigCache -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigCache -> ConfigureOpts
configCacheOpts) Maybe ConfigCache
mold)
            (ConfigureOpts -> [String]
coNoDirs (ConfigureOpts -> [String]) -> ConfigureOpts -> [String]
forall a b. (a -> b) -> a -> b
$ ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
new)
        (Key ConfigCacheParent -> GhcPkgId -> ConfigCacheDep)
-> EntityField ConfigCacheDep (Key ConfigCacheParent)
-> Key ConfigCacheParent
-> EntityField ConfigCacheDep GhcPkgId
-> Set GhcPkgId
-> Set GhcPkgId
-> ReaderT SqlBackend (RIO env) ()
forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, PersistField value, Ord value,
 PersistEntity record, MonadIO m, PersistQueryWrite backend) =>
(parentid -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record value
-> Set value
-> Set value
-> ReaderT backend m ()
updateSet
            Key ConfigCacheParent -> GhcPkgId -> ConfigCacheDep
ConfigCacheDep
            EntityField ConfigCacheDep (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheDep typ
ConfigCacheDepParent
            Key ConfigCacheParent
parentId
            EntityField ConfigCacheDep GhcPkgId
forall typ. (typ ~ GhcPkgId) => EntityField ConfigCacheDep typ
ConfigCacheDepValue
            (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 ConfigCache -> Set GhcPkgId
configCacheDeps Maybe ConfigCache
mold)
            (ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
new)
        (Key ConfigCacheParent -> ByteString -> ConfigCacheComponent)
-> EntityField ConfigCacheComponent (Key ConfigCacheParent)
-> Key ConfigCacheParent
-> EntityField ConfigCacheComponent ByteString
-> Set ByteString
-> Set ByteString
-> ReaderT SqlBackend (RIO env) ()
forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, PersistField value, Ord value,
 PersistEntity record, MonadIO m, PersistQueryWrite backend) =>
(parentid -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record value
-> Set value
-> Set value
-> ReaderT backend m ()
updateSet
            Key ConfigCacheParent -> ByteString -> ConfigCacheComponent
ConfigCacheComponent
            EntityField ConfigCacheComponent (Key ConfigCacheParent)
forall typ.
(typ ~ Key ConfigCacheParent) =>
EntityField ConfigCacheComponent typ
ConfigCacheComponentParent
            Key ConfigCacheParent
parentId
            EntityField ConfigCacheComponent ByteString
forall typ.
(typ ~ ByteString) =>
EntityField ConfigCacheComponent typ
ConfigCacheComponentValue
            (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 ConfigCache -> Set ByteString
configCacheComponents Maybe ConfigCache
mold)
            (ConfigCache -> Set ByteString
configCacheComponents ConfigCache
new)

-- | Mark '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 :: Unique ConfigCacheParent -> RIO env ()
deactiveConfigCache (UniqueConfigCacheParent dir 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 ()
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]