{-# LANGUAGE NoImplicitPrelude    #-}
{-# 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 the SQLite database for a project's caches.
License     : BSD-3-Clause

Work with the SQLite database used for a project's caches.
-}

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.ConfigureOpts ( configureOptsFromDb )
import           Stack.Prelude
import           Stack.Storage.Util
                   ( handleMigrationException, listUpdateDiff, setUpdateDiff
                   , updateCollection
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.Cache
                   ( CachePkgSrc, ConfigCache (..), ConfigCacheType )
import           Stack.Types.ConfigureOpts ( ConfigureOpts (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Storage ( ProjectStorage (..) )

-- Uses the Persistent entity syntax to generate entities for five tables in a

-- SQLite database:

--

-- config_cache

-- config_cache_dir_option

-- config_cache_no_dir_option

-- config_cache_dep

-- config_cache_component

--

-- The ID column for each table is automatically generated.

--

-- The other tables have a foreign key referring to the config_cache table, via:

--

--   parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade

--

-- The tables have UNIQUE constraints on multiple columns.

--

-- Creates a function migrateAll to perform all migrations for the generated

-- entities.

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 project database for caches.

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

  -> (ProjectStorage -> RIO env a)
     -- ^ Action, given a SQL database connection to the project database for

     -- caches.

  -> 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 <- 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))
  withStorage_ storage inner

-- | Type synonym representing keys used to retrieve a record from the Cabal

-- configuration cache or the library or executable Cabal flag cache.

type ConfigCacheKey = Unique ConfigCacheParent

-- | For the given directory and type of cache, yields the key used to retrieve

-- a record from the Cabal configuration cache or the library or executable

-- Cabal flag cache.

configCacheKey ::
     Path Abs Dir
     -- ^ Directory.

  -> ConfigCacheType
     -- ^ Type of cache.

  -> 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
  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]
  nonPathRelatedInfo <-
    selectList
      [ConfigCacheNoDirOptionParent ==. parentId]
      [Asc ConfigCacheNoDirOptionIndex]
  let 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
  deps <-
    Set.fromList . map ((.configCacheDepValue) . entityVal) <$>
    selectList [ConfigCacheDepParent ==. parentId] []
  components <-
    Set.fromList . map ((.configCacheComponentValue) . entityVal) <$>
    selectList [ConfigCacheComponentParent ==. parentId] []
  let pathEnvVar = ConfigCacheParent
configCacheParent.configCacheParentPathEnvVar
  let buildHaddocks = ConfigCacheParent
configCacheParent.configCacheParentHaddock
  pure ConfigCache
    { configureOpts
    , deps
    , components
    , buildHaddocks
    , pkgSrc
    , pathEnvVar
    }

-- | Load a t'ConfigCache' value from the project database for caches.

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
$
    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 ReaderT SqlBackend (RIO env) (Maybe (Entity ConfigCacheParent))
-> (Maybe (Entity ConfigCacheParent)
    -> ReaderT SqlBackend (RIO env) (Maybe ConfigCache))
-> ReaderT SqlBackend (RIO env) (Maybe ConfigCache)
forall a b.
ReaderT SqlBackend (RIO env) a
-> (a -> ReaderT SqlBackend (RIO env) b)
-> ReaderT SqlBackend (RIO env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      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 a t'ConfigCache' value to the project database for caches.

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
    (parentId, mold) <- 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 ReaderT SqlBackend (RIO env) (Maybe (Entity ConfigCacheParent))
-> (Maybe (Entity ConfigCacheParent)
    -> ReaderT
         SqlBackend (RIO env) (Key ConfigCacheParent, Maybe ConfigCache))
-> ReaderT
     SqlBackend (RIO env) (Key ConfigCacheParent, Maybe ConfigCache)
forall a b.
ReaderT SqlBackend (RIO env) a
-> (a -> ReaderT SqlBackend (RIO env) b)
-> ReaderT SqlBackend (RIO env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        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
          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
          update
            parentId
            [ ConfigCacheParentPkgSrc =. new.pkgSrc
            , ConfigCacheParentActive =. True
            , ConfigCacheParentPathEnvVar =. new.pathEnvVar
            ]
          pure (parentId, Just old)
    updateCollection
      (listUpdateDiff ConfigCacheDirOptionIndex)
      (uncurry $ ConfigCacheDirOption parentId)
      [ConfigCacheDirOptionParent ==. parentId]
      (maybe [] (.configureOpts.pathRelated) mold)
      new.configureOpts.pathRelated
    updateCollection
      (listUpdateDiff ConfigCacheNoDirOptionIndex)
      (uncurry $ ConfigCacheNoDirOption parentId)
      [ConfigCacheNoDirOptionParent ==. parentId]
      (maybe [] (.configureOpts.nonPathRelated) mold)
      new.configureOpts.nonPathRelated
    updateCollection
      (setUpdateDiff ConfigCacheDepValue)
      (ConfigCacheDep parentId)
      [ConfigCacheDepParent ==. parentId]
      (maybe Set.empty (.deps) mold)
      new.deps
    updateCollection
      (setUpdateDiff ConfigCacheComponentValue)
      (ConfigCacheComponent parentId)
      [ConfigCacheComponentParent ==. parentId]
      (maybe Set.empty (.components) mold)
      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]