{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# 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
                   ( 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, updateList, updateSet )
import           Stack.Types.Build ( CachePkgSrc, ConfigCache (..) )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.Cache ( ConfigCacheType )
import           Stack.Types.ConfigureOpts  ( ConfigureOpts (..) )
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 -> 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)
  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 '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 {Bool
String
Text
ConfigCacheType
CachePkgSrc
configCacheParentDirectory :: ConfigCacheParent -> String
configCacheParentType :: ConfigCacheParent -> ConfigCacheType
configCacheParentPkgSrc :: ConfigCacheParent -> CachePkgSrc
configCacheParentActive :: ConfigCacheParent -> Bool
configCacheParentPathEnvVar :: ConfigCacheParent -> Text
configCacheParentHaddock :: ConfigCacheParent -> Bool
configCacheParentDirectory :: String
configCacheParentType :: ConfigCacheType
configCacheParentPkgSrc :: CachePkgSrc
configCacheParentActive :: Bool
configCacheParentPathEnvVar :: Text
configCacheParentHaddock :: Bool
..}) = 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]
coDirs :: [String]
coNoDirs :: [String]
coDirs :: [String]
coNoDirs :: [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 a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigCache {Bool
Set ByteString
Set GhcPkgId
Text
ConfigureOpts
CachePkgSrc
configCachePkgSrc :: CachePkgSrc
configCacheOpts :: ConfigureOpts
configCacheDeps :: Set GhcPkgId
configCacheComponents :: Set ByteString
configCachePathEnvVar :: Text
configCacheHaddock :: Bool
configCacheOpts :: ConfigureOpts
configCacheDeps :: Set GhcPkgId
configCacheComponents :: Set ByteString
configCacheHaddock :: Bool
configCachePkgSrc :: CachePkgSrc
configCachePathEnvVar :: Text
..}

-- | Load '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 {Bool
String
Text
ConfigCacheType
CachePkgSrc
configCacheParentDirectory :: ConfigCacheParent -> String
configCacheParentType :: ConfigCacheParent -> ConfigCacheType
configCacheParentPkgSrc :: ConfigCacheParent -> CachePkgSrc
configCacheParentActive :: ConfigCacheParent -> Bool
configCacheParentPathEnvVar :: ConfigCacheParent -> Text
configCacheParentHaddock :: ConfigCacheParent -> Bool
configCacheParentDirectory :: String
configCacheParentType :: ConfigCacheType
configCacheParentPkgSrc :: CachePkgSrc
configCacheParentActive :: Bool
configCacheParentPathEnvVar :: Text
configCacheParentHaddock :: Bool
..})
        | 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 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 '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 -> 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 ()
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 -> 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 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)
    (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, SafeToInsert record) =>
(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, SafeToInsert record) =>
(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,
 SafeToInsert record) =>
(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,
 SafeToInsert record) =>
(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 :: 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]