{-# 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 an entire user account.
module Stack.Storage.User
    ( initUserStorage
    , PrecompiledCacheKey
    , precompiledCacheKey
    , loadPrecompiledCache
    , savePrecompiledCache
    , loadDockerImageExeCache
    , saveDockerImageExeCache
    , loadCompilerPaths
    , saveCompilerPaths
    , upgradeChecksSince
    , logUpgradeCheck
    ) where

import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Database.Persist.Sqlite
import Database.Persist.TH
import Distribution.Text (simpleParse, display)
import Foreign.C.Types (CTime (..))
import qualified Pantry.Internal as SQLite
import Path
import Path.IO (resolveFile', resolveDir')
import qualified RIO.FilePath as FP
import Stack.Prelude hiding (MigrationFailure)
import Stack.Storage.Util
import Stack.Types.Build
import Stack.Types.Cache
import Stack.Types.Compiler
import Stack.Types.CompilerBuild (CompilerBuild)
import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..))
import System.Posix.Types (COff (..))
import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)

share [ mkPersist sqlSettings
      , mkDeleteCascade sqlSettings
      , mkMigrate "migrateAll"
    ]
    [persistLowerCase|
PrecompiledCacheParent sql="precompiled_cache"
  platformGhcDir FilePath "default=(hex(randomblob(16)))"
  compiler Text
  cabalVersion Text
  packageKey Text
  optionsHash ByteString
  haddock Bool default=0
  library FilePath Maybe
  UniquePrecompiledCacheParent platformGhcDir compiler cabalVersion packageKey optionsHash haddock sql="unique_precompiled_cache"
  deriving Show

PrecompiledCacheSubLib
  parent PrecompiledCacheParentId sql="precompiled_cache_id"
  value FilePath sql="sub_lib"
  UniquePrecompiledCacheSubLib parent value
  deriving Show

PrecompiledCacheExe
  parent PrecompiledCacheParentId sql="precompiled_cache_id"
  value FilePath sql="exe"
  UniquePrecompiledCacheExe parent value
  deriving Show

DockerImageExeCache
  imageHash Text
  exePath FilePath
  exeTimestamp UTCTime
  compatible Bool
  DockerImageExeCacheUnique imageHash exePath exeTimestamp
  deriving Show

CompilerCache
  actualVersion ActualCompiler
  arch Text

  -- Include ghc executable size and modified time for sanity checking entries
  ghcPath FilePath
  ghcSize Int64
  ghcModified Int64

  ghcPkgPath FilePath
  runghcPath FilePath
  haddockPath FilePath

  cabalVersion Text
  globalDb FilePath
  globalDbCacheSize Int64
  globalDbCacheModified Int64
  info ByteString

  -- This is the ugliest part of this table, simply storing a Show/Read version of the
  -- data. We could do a better job with normalized data and proper table structure.
  -- However, recomputing this value in the future if the data representation changes
  -- is very cheap, so we'll take the easy way out for now.
  globalDump Text

  UniqueCompilerInfo ghcPath

-- Last time certain actions were performed
LastPerformed
  action Action
  timestamp UTCTime
  UniqueAction action
|]

-- | Initialize the database.
initUserStorage ::
       HasLogFunc env
    => Path Abs File -- ^ storage file
    -> (UserStorage -> RIO env a)
    -> RIO env a
initUserStorage :: Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage Path Abs File
fp UserStorage -> 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
$ UserStorage -> RIO env a
f (UserStorage -> RIO env a)
-> (Storage -> UserStorage) -> Storage -> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Storage -> UserStorage
UserStorage

-- | Run an action in a database transaction
withUserStorage ::
       (HasConfig env, HasLogFunc env)
    => ReaderT SqlBackend (RIO env) a
    -> RIO env a
withUserStorage :: ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage 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 ((Config -> Const Storage Config) -> env -> Const Storage env
forall env. HasConfig env => Lens' env Config
configL ((Config -> Const Storage Config) -> env -> Const Storage env)
-> ((Storage -> Const Storage Storage)
    -> Config -> Const Storage Config)
-> Getting Storage env Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> UserStorage) -> SimpleGetter Config UserStorage
forall s a. (s -> a) -> SimpleGetter s a
to Config -> UserStorage
configUserStorage Getting Storage Config UserStorage
-> ((Storage -> Const Storage Storage)
    -> UserStorage -> Const Storage UserStorage)
-> (Storage -> Const Storage Storage)
-> Config
-> Const Storage Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserStorage -> Storage) -> SimpleGetter UserStorage Storage
forall s a. (s -> a) -> SimpleGetter s a
to UserStorage -> Storage
unUserStorage)

-- | Key used to retrieve the precompiled cache
type PrecompiledCacheKey = Unique PrecompiledCacheParent

-- | Build key used to retrieve the precompiled cache
precompiledCacheKey ::
       Path Rel Dir
    -> ActualCompiler
    -> Version
    -> Text
    -> ByteString
    -> Bool
    -> PrecompiledCacheKey
precompiledCacheKey :: Path Rel Dir
-> ActualCompiler
-> Version
-> Text
-> ByteString
-> Bool
-> Unique PrecompiledCacheParent
precompiledCacheKey Path Rel Dir
platformGhcDir ActualCompiler
compiler Version
cabalVersion =
    FilePath
-> Text
-> Text
-> Text
-> ByteString
-> Bool
-> Unique PrecompiledCacheParent
UniquePrecompiledCacheParent
        (Path Rel Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel Dir
platformGhcDir)
        (ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler)
        (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Version -> FilePath
versionString Version
cabalVersion)

-- | Internal helper to read the 'PrecompiledCache' from the database
readPrecompiledCache ::
       (HasConfig env, HasLogFunc env)
    => PrecompiledCacheKey
    -> ReaderT SqlBackend (RIO env) (Maybe ( PrecompiledCacheParentId
                                           , PrecompiledCache Rel))
readPrecompiledCache :: Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
readPrecompiledCache Unique PrecompiledCacheParent
key = do
    Maybe (Entity PrecompiledCacheParent)
mparent <- Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend (RIO env) (Maybe (Entity PrecompiledCacheParent))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique PrecompiledCacheParent
key
    Maybe (Entity PrecompiledCacheParent)
-> (Entity PrecompiledCacheParent
    -> ReaderT
         SqlBackend
         (RIO env)
         (Key PrecompiledCacheParent, PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Entity PrecompiledCacheParent)
mparent ((Entity PrecompiledCacheParent
  -> ReaderT
       SqlBackend
       (RIO env)
       (Key PrecompiledCacheParent, PrecompiledCache Rel))
 -> ReaderT
      SqlBackend
      (RIO env)
      (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)))
-> (Entity PrecompiledCacheParent
    -> ReaderT
         SqlBackend
         (RIO env)
         (Key PrecompiledCacheParent, PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall a b. (a -> b) -> a -> b
$ \(Entity Key PrecompiledCacheParent
parentId PrecompiledCacheParent {Bool
FilePath
Maybe FilePath
ByteString
Text
precompiledCacheParentLibrary :: Maybe FilePath
precompiledCacheParentHaddock :: Bool
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentPackageKey :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentPlatformGhcDir :: FilePath
precompiledCacheParentLibrary :: PrecompiledCacheParent -> Maybe FilePath
precompiledCacheParentHaddock :: PrecompiledCacheParent -> Bool
precompiledCacheParentOptionsHash :: PrecompiledCacheParent -> ByteString
precompiledCacheParentPackageKey :: PrecompiledCacheParent -> Text
precompiledCacheParentCabalVersion :: PrecompiledCacheParent -> Text
precompiledCacheParentCompiler :: PrecompiledCacheParent -> Text
precompiledCacheParentPlatformGhcDir :: PrecompiledCacheParent -> FilePath
..}) -> do
        Maybe (Path Rel File)
pcLibrary <- (FilePath -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> Maybe FilePath
-> ReaderT SqlBackend (RIO env) (Maybe (Path Rel File))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile Maybe FilePath
precompiledCacheParentLibrary
        [Path Rel File]
pcSubLibs <-
            (Entity PrecompiledCacheSubLib
 -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> [Entity PrecompiledCacheSubLib]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile (FilePath -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> (Entity PrecompiledCacheSubLib -> FilePath)
-> Entity PrecompiledCacheSubLib
-> ReaderT SqlBackend (RIO env) (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheSubLib -> FilePath
precompiledCacheSubLibValue (PrecompiledCacheSubLib -> FilePath)
-> (Entity PrecompiledCacheSubLib -> PrecompiledCacheSubLib)
-> Entity PrecompiledCacheSubLib
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PrecompiledCacheSubLib -> PrecompiledCacheSubLib
forall record. Entity record -> record
entityVal) ([Entity PrecompiledCacheSubLib]
 -> ReaderT SqlBackend (RIO env) [Path Rel File])
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheSubLib]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            [Filter PrecompiledCacheSubLib]
-> [SelectOpt PrecompiledCacheSubLib]
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheSubLib]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent -> Filter PrecompiledCacheSubLib
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
        [Path Rel File]
pcExes <-
            (Entity PrecompiledCacheExe
 -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> [Entity PrecompiledCacheExe]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile (FilePath -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> (Entity PrecompiledCacheExe -> FilePath)
-> Entity PrecompiledCacheExe
-> ReaderT SqlBackend (RIO env) (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheExe -> FilePath
precompiledCacheExeValue (PrecompiledCacheExe -> FilePath)
-> (Entity PrecompiledCacheExe -> PrecompiledCacheExe)
-> Entity PrecompiledCacheExe
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PrecompiledCacheExe -> PrecompiledCacheExe
forall record. Entity record -> record
entityVal) ([Entity PrecompiledCacheExe]
 -> ReaderT SqlBackend (RIO env) [Path Rel File])
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheExe]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            [Filter PrecompiledCacheExe]
-> [SelectOpt PrecompiledCacheExe]
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheExe]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent -> Filter PrecompiledCacheExe
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
        (Key PrecompiledCacheParent, PrecompiledCache Rel)
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, PrecompiledCache Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return (Key PrecompiledCacheParent
parentId, PrecompiledCache :: forall base.
Maybe (Path base File)
-> [Path base File] -> [Path base File] -> PrecompiledCache base
PrecompiledCache {[Path Rel File]
Maybe (Path Rel File)
pcExes :: [Path Rel File]
pcSubLibs :: [Path Rel File]
pcLibrary :: Maybe (Path Rel File)
pcExes :: [Path Rel File]
pcSubLibs :: [Path Rel File]
pcLibrary :: Maybe (Path Rel File)
..})

-- | Load 'PrecompiledCache' from the database.
loadPrecompiledCache ::
       (HasConfig env, HasLogFunc env)
    => PrecompiledCacheKey
    -> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache :: Unique PrecompiledCacheParent
-> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache Unique PrecompiledCacheParent
key = ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
-> RIO env (Maybe (PrecompiledCache Rel))
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
 -> RIO env (Maybe (PrecompiledCache Rel)))
-> ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
-> RIO env (Maybe (PrecompiledCache Rel))
forall a b. (a -> b) -> a -> b
$ ((Key PrecompiledCacheParent, PrecompiledCache Rel)
 -> PrecompiledCache Rel)
-> Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
-> Maybe (PrecompiledCache Rel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key PrecompiledCacheParent, PrecompiledCache Rel)
-> PrecompiledCache Rel
forall a b. (a, b) -> b
snd (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
 -> Maybe (PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
-> ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
readPrecompiledCache Unique PrecompiledCacheParent
key

-- | Insert or update 'PrecompiledCache' to the database.
savePrecompiledCache ::
       (HasConfig env, HasLogFunc env)
    => PrecompiledCacheKey
    -> PrecompiledCache Rel
    -> RIO env ()
savePrecompiledCache :: Unique PrecompiledCacheParent -> PrecompiledCache Rel -> RIO env ()
savePrecompiledCache key :: Unique PrecompiledCacheParent
key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) PrecompiledCache Rel
new =
    ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        let precompiledCacheParentLibrary :: Maybe FilePath
precompiledCacheParentLibrary = (Path Rel File -> FilePath)
-> Maybe (Path Rel File) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (PrecompiledCache Rel -> Maybe (Path Rel File)
forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Rel
new)
        Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
mIdOld <- Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
readPrecompiledCache Unique PrecompiledCacheParent
key
        (Key PrecompiledCacheParent
parentId, Maybe (PrecompiledCache Rel)
mold) <-
            case Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
mIdOld of
                Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
Nothing -> (, Maybe (PrecompiledCache Rel)
forall a. Maybe a
Nothing) (Key PrecompiledCacheParent
 -> (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel)))
-> ReaderT SqlBackend (RIO env) (Key PrecompiledCacheParent)
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrecompiledCacheParent
-> ReaderT SqlBackend (RIO env) (Key PrecompiledCacheParent)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m (Key record)
insert PrecompiledCacheParent :: FilePath
-> Text
-> Text
-> Text
-> ByteString
-> Bool
-> Maybe FilePath
-> PrecompiledCacheParent
PrecompiledCacheParent {Bool
FilePath
Maybe FilePath
ByteString
Text
precompiledCacheParentLibrary :: Maybe FilePath
precompiledCacheParentHaddock :: Bool
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentPackageKey :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentPlatformGhcDir :: FilePath
precompiledCacheParentLibrary :: Maybe FilePath
precompiledCacheParentHaddock :: Bool
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentPackageKey :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentPlatformGhcDir :: FilePath
..}
                Just (Key PrecompiledCacheParent
parentId, PrecompiledCache Rel
old) -> do
                    Key PrecompiledCacheParent
-> [Update PrecompiledCacheParent]
-> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update
                        Key PrecompiledCacheParent
parentId
                        [ EntityField PrecompiledCacheParent (Maybe FilePath)
forall typ.
(typ ~ Maybe FilePath) =>
EntityField PrecompiledCacheParent typ
PrecompiledCacheParentLibrary EntityField PrecompiledCacheParent (Maybe FilePath)
-> Maybe FilePath -> Update PrecompiledCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
                          Maybe FilePath
precompiledCacheParentLibrary
                        ]
                    (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
forall (m :: * -> *) a. Monad m => a -> m a
return (Key PrecompiledCacheParent
parentId, PrecompiledCache Rel -> Maybe (PrecompiledCache Rel)
forall a. a -> Maybe a
Just PrecompiledCache Rel
old)
        (Key PrecompiledCacheParent -> FilePath -> PrecompiledCacheSubLib)
-> EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent
-> EntityField PrecompiledCacheSubLib FilePath
-> Set FilePath
-> Set FilePath
-> 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 PrecompiledCacheParent -> FilePath -> PrecompiledCacheSubLib
PrecompiledCacheSubLib
            EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent
            Key PrecompiledCacheParent
parentId
            EntityField PrecompiledCacheSubLib FilePath
forall typ.
(typ ~ FilePath) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibValue
            (Set FilePath
-> (PrecompiledCache Rel -> Set FilePath)
-> Maybe (PrecompiledCache Rel)
-> Set FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set FilePath
forall a. Set a
Set.empty ([Path Rel File] -> Set FilePath
forall b t. [Path b t] -> Set FilePath
toFilePathSet ([Path Rel File] -> Set FilePath)
-> (PrecompiledCache Rel -> [Path Rel File])
-> PrecompiledCache Rel
-> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcSubLibs) Maybe (PrecompiledCache Rel)
mold)
            ([Path Rel File] -> Set FilePath
forall b t. [Path b t] -> Set FilePath
toFilePathSet ([Path Rel File] -> Set FilePath)
-> [Path Rel File] -> Set FilePath
forall a b. (a -> b) -> a -> b
$ PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcSubLibs PrecompiledCache Rel
new)
        (Key PrecompiledCacheParent -> FilePath -> PrecompiledCacheExe)
-> EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent
-> EntityField PrecompiledCacheExe FilePath
-> Set FilePath
-> Set FilePath
-> 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 PrecompiledCacheParent -> FilePath -> PrecompiledCacheExe
PrecompiledCacheExe
            EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent
            Key PrecompiledCacheParent
parentId
            EntityField PrecompiledCacheExe FilePath
forall typ. (typ ~ FilePath) => EntityField PrecompiledCacheExe typ
PrecompiledCacheExeValue
            (Set FilePath
-> (PrecompiledCache Rel -> Set FilePath)
-> Maybe (PrecompiledCache Rel)
-> Set FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set FilePath
forall a. Set a
Set.empty ([Path Rel File] -> Set FilePath
forall b t. [Path b t] -> Set FilePath
toFilePathSet ([Path Rel File] -> Set FilePath)
-> (PrecompiledCache Rel -> [Path Rel File])
-> PrecompiledCache Rel
-> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcExes) Maybe (PrecompiledCache Rel)
mold)
            ([Path Rel File] -> Set FilePath
forall b t. [Path b t] -> Set FilePath
toFilePathSet ([Path Rel File] -> Set FilePath)
-> [Path Rel File] -> Set FilePath
forall a b. (a -> b) -> a -> b
$ PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Rel
new)
  where
    toFilePathSet :: [Path b t] -> Set FilePath
toFilePathSet = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ([FilePath] -> Set FilePath)
-> ([Path b t] -> [FilePath]) -> [Path b t] -> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path b t -> FilePath) -> [Path b t] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath

-- | Get the record of whether an executable is compatible with a Docker image
loadDockerImageExeCache ::
       (HasConfig env, HasLogFunc env)
    => Text
    -> Path Abs File
    -> UTCTime
    -> RIO env (Maybe Bool)
loadDockerImageExeCache :: Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
loadDockerImageExeCache Text
imageId Path Abs File
exePath UTCTime
exeTimestamp =
    ReaderT SqlBackend (RIO env) (Maybe Bool) -> RIO env (Maybe Bool)
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Maybe Bool) -> RIO env (Maybe Bool))
-> ReaderT SqlBackend (RIO env) (Maybe Bool)
-> RIO env (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
    (Entity DockerImageExeCache -> Bool)
-> Maybe (Entity DockerImageExeCache) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DockerImageExeCache -> Bool
dockerImageExeCacheCompatible (DockerImageExeCache -> Bool)
-> (Entity DockerImageExeCache -> DockerImageExeCache)
-> Entity DockerImageExeCache
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity DockerImageExeCache -> DockerImageExeCache
forall record. Entity record -> record
entityVal) (Maybe (Entity DockerImageExeCache) -> Maybe Bool)
-> ReaderT
     SqlBackend (RIO env) (Maybe (Entity DockerImageExeCache))
-> ReaderT SqlBackend (RIO env) (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Unique DockerImageExeCache
-> ReaderT
     SqlBackend (RIO env) (Maybe (Entity DockerImageExeCache))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Text -> FilePath -> UTCTime -> Unique DockerImageExeCache
DockerImageExeCacheUnique Text
imageId (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
exePath) UTCTime
exeTimestamp)

-- | Sest the record of whether an executable is compatible with a Docker image
saveDockerImageExeCache ::
       (HasConfig env, HasLogFunc env)
    => Text
    -> Path Abs File
    -> UTCTime
    -> Bool
    -> RIO env ()
saveDockerImageExeCache :: Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
saveDockerImageExeCache Text
imageId Path Abs File
exePath UTCTime
exeTimestamp Bool
compatible =
    RIO env (Entity DockerImageExeCache) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (Entity DockerImageExeCache) -> RIO env ())
-> RIO env (Entity DockerImageExeCache) -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
-> RIO env (Entity DockerImageExeCache)
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
 -> RIO env (Entity DockerImageExeCache))
-> ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
-> RIO env (Entity DockerImageExeCache)
forall a b. (a -> b) -> a -> b
$
    DockerImageExeCache
-> [Update DockerImageExeCache]
-> ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
upsert
        (Text -> FilePath -> UTCTime -> Bool -> DockerImageExeCache
DockerImageExeCache
             Text
imageId
             (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
exePath)
             UTCTime
exeTimestamp
             Bool
compatible)
        []

-- | Type-restricted version of 'fromIntegral' to ensure we're making
-- the value bigger, not smaller.
sizeToInt64 :: COff -> Int64
sizeToInt64 :: COff -> Int64
sizeToInt64 (COff Int64
i) = Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i -- fromIntegral added for 32-bit systems

-- | Type-restricted version of 'fromIntegral' to ensure we're making
-- the value bigger, not smaller.
timeToInt64 :: CTime -> Int64
timeToInt64 :: CTime -> Int64
timeToInt64 (CTime Int64
i) = Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i -- fromIntegral added for 32-bit systems

-- | Load compiler information, if available, and confirm that the
-- referenced files are unchanged. May throw exceptions!
loadCompilerPaths
  :: HasConfig env
  => Path Abs File -- ^ compiler executable
  -> CompilerBuild
  -> Bool -- ^ sandboxed?
  -> RIO env (Maybe CompilerPaths)
loadCompilerPaths :: Path Abs File
-> CompilerBuild -> Bool -> RIO env (Maybe CompilerPaths)
loadCompilerPaths Path Abs File
compiler CompilerBuild
build Bool
sandboxed = do
  Maybe (Entity CompilerCache)
mres <- ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
-> RIO env (Maybe (Entity CompilerCache))
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
 -> RIO env (Maybe (Entity CompilerCache)))
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
-> RIO env (Maybe (Entity CompilerCache))
forall a b. (a -> b) -> a -> b
$ Unique CompilerCache
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Unique CompilerCache
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache)))
-> Unique CompilerCache
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
forall a b. (a -> b) -> a -> b
$ FilePath -> Unique CompilerCache
UniqueCompilerInfo (FilePath -> Unique CompilerCache)
-> FilePath -> Unique CompilerCache
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
compiler
  Maybe (Entity CompilerCache)
-> (Entity CompilerCache -> RIO env CompilerPaths)
-> RIO env (Maybe CompilerPaths)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (Entity CompilerCache)
mres ((Entity CompilerCache -> RIO env CompilerPaths)
 -> RIO env (Maybe CompilerPaths))
-> (Entity CompilerCache -> RIO env CompilerPaths)
-> RIO env (Maybe CompilerPaths)
forall a b. (a -> b) -> a -> b
$ \(Entity Key CompilerCache
_ CompilerCache {Int64
FilePath
ByteString
Text
ActualCompiler
compilerCacheGlobalDump :: Text
compilerCacheInfo :: ByteString
compilerCacheGlobalDbCacheModified :: Int64
compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDb :: FilePath
compilerCacheCabalVersion :: Text
compilerCacheHaddockPath :: FilePath
compilerCacheRunghcPath :: FilePath
compilerCacheGhcPkgPath :: FilePath
compilerCacheGhcModified :: Int64
compilerCacheGhcSize :: Int64
compilerCacheGhcPath :: FilePath
compilerCacheArch :: Text
compilerCacheActualVersion :: ActualCompiler
compilerCacheGlobalDump :: CompilerCache -> Text
compilerCacheInfo :: CompilerCache -> ByteString
compilerCacheGlobalDbCacheModified :: CompilerCache -> Int64
compilerCacheGlobalDbCacheSize :: CompilerCache -> Int64
compilerCacheGlobalDb :: CompilerCache -> FilePath
compilerCacheCabalVersion :: CompilerCache -> Text
compilerCacheHaddockPath :: CompilerCache -> FilePath
compilerCacheRunghcPath :: CompilerCache -> FilePath
compilerCacheGhcPkgPath :: CompilerCache -> FilePath
compilerCacheGhcModified :: CompilerCache -> Int64
compilerCacheGhcSize :: CompilerCache -> Int64
compilerCacheGhcPath :: CompilerCache -> FilePath
compilerCacheArch :: CompilerCache -> Text
compilerCacheActualVersion :: CompilerCache -> ActualCompiler
..}) -> do
    FileStatus
compilerStatus <- IO FileStatus -> RIO env FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> RIO env FileStatus)
-> IO FileStatus -> RIO env FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus (FilePath -> IO FileStatus) -> FilePath -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
compiler
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (Int64
compilerCacheGhcSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
compilerStatus) Bool -> Bool -> Bool
||
       Int64
compilerCacheGhcModified Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
compilerStatus))
      (FilePath -> RIO env ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Compiler file metadata mismatch, ignoring cache")
    FileStatus
globalDbStatus <- IO FileStatus -> RIO env FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> RIO env FileStatus)
-> IO FileStatus -> RIO env FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus (FilePath -> IO FileStatus) -> FilePath -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath
compilerCacheGlobalDb FilePath -> ShowS
FP.</> FilePath
"package.cache"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (Int64
compilerCacheGlobalDbCacheSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
globalDbStatus) Bool -> Bool -> Bool
||
       Int64
compilerCacheGlobalDbCacheModified Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
globalDbStatus))
      (FilePath -> RIO env ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Global package cache file metadata mismatch, ignoring cache")

    -- We could use parseAbsFile instead of resolveFile' below to
    -- bypass some system calls, at the cost of some really wonky
    -- error messages in case someone screws up their GHC installation
    Path Abs File
pkgexe <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
compilerCacheGhcPkgPath
    Path Abs File
runghc <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
compilerCacheRunghcPath
    Path Abs File
haddock <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
compilerCacheHaddockPath
    Path Abs Dir
globaldb <- FilePath -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' FilePath
compilerCacheGlobalDb

    Version
cabalVersion <- FilePath -> RIO env Version
forall (m :: * -> *). MonadThrow m => FilePath -> m Version
parseVersionThrowing (FilePath -> RIO env Version) -> FilePath -> RIO env Version
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
compilerCacheCabalVersion
    Map PackageName DumpPackage
globalDump <-
      case FilePath -> Maybe (Map PackageName DumpPackage)
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe (Map PackageName DumpPackage))
-> FilePath -> Maybe (Map PackageName DumpPackage)
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
compilerCacheGlobalDump of
        Maybe (Map PackageName DumpPackage)
Nothing -> FilePath -> RIO env (Map PackageName DumpPackage)
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Global dump did not parse correctly"
        Just Map PackageName DumpPackage
globalDump -> Map PackageName DumpPackage
-> RIO env (Map PackageName DumpPackage)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName DumpPackage
globalDump
    Arch
arch <-
      case FilePath -> Maybe Arch
forall a. Parsec a => FilePath -> Maybe a
simpleParse (FilePath -> Maybe Arch) -> FilePath -> Maybe Arch
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
compilerCacheArch of
        Maybe Arch
Nothing -> FilePath -> RIO env Arch
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString (FilePath -> RIO env Arch) -> FilePath -> RIO env Arch
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid arch: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
compilerCacheArch
        Just Arch
arch -> Arch -> RIO env Arch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arch
arch

    CompilerPaths -> RIO env CompilerPaths
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths :: ActualCompiler
-> Arch
-> CompilerBuild
-> Path Abs File
-> GhcPkgExe
-> Path Abs File
-> Path Abs File
-> Bool
-> Version
-> Path Abs Dir
-> ByteString
-> Map PackageName DumpPackage
-> CompilerPaths
CompilerPaths
      { cpCompiler :: Path Abs File
cpCompiler = Path Abs File
compiler
      , cpCompilerVersion :: ActualCompiler
cpCompilerVersion = ActualCompiler
compilerCacheActualVersion
      , cpArch :: Arch
cpArch = Arch
arch
      , cpBuild :: CompilerBuild
cpBuild = CompilerBuild
build
      , cpPkg :: GhcPkgExe
cpPkg = Path Abs File -> GhcPkgExe
GhcPkgExe Path Abs File
pkgexe
      , cpInterpreter :: Path Abs File
cpInterpreter = Path Abs File
runghc
      , cpHaddock :: Path Abs File
cpHaddock = Path Abs File
haddock
      , cpSandboxed :: Bool
cpSandboxed = Bool
sandboxed
      , cpCabalVersion :: Version
cpCabalVersion = Version
cabalVersion
      , cpGlobalDB :: Path Abs Dir
cpGlobalDB = Path Abs Dir
globaldb
      , cpGhcInfo :: ByteString
cpGhcInfo = ByteString
compilerCacheInfo
      , cpGlobalDump :: Map PackageName DumpPackage
cpGlobalDump = Map PackageName DumpPackage
globalDump
      }

-- | Save compiler information. May throw exceptions!
saveCompilerPaths
  :: HasConfig env
  => CompilerPaths
  -> RIO env ()
saveCompilerPaths :: CompilerPaths -> RIO env ()
saveCompilerPaths CompilerPaths {Bool
ByteString
Arch
Version
Map PackageName DumpPackage
Path Abs File
Path Abs Dir
CompilerBuild
ActualCompiler
GhcPkgExe
cpGlobalDump :: Map PackageName DumpPackage
cpGhcInfo :: ByteString
cpGlobalDB :: Path Abs Dir
cpCabalVersion :: Version
cpSandboxed :: Bool
cpHaddock :: Path Abs File
cpInterpreter :: Path Abs File
cpPkg :: GhcPkgExe
cpCompiler :: Path Abs File
cpBuild :: CompilerBuild
cpArch :: Arch
cpCompilerVersion :: ActualCompiler
cpGlobalDump :: CompilerPaths -> Map PackageName DumpPackage
cpGhcInfo :: CompilerPaths -> ByteString
cpGlobalDB :: CompilerPaths -> Path Abs Dir
cpCabalVersion :: CompilerPaths -> Version
cpSandboxed :: CompilerPaths -> Bool
cpHaddock :: CompilerPaths -> Path Abs File
cpInterpreter :: CompilerPaths -> Path Abs File
cpPkg :: CompilerPaths -> GhcPkgExe
cpBuild :: CompilerPaths -> CompilerBuild
cpArch :: CompilerPaths -> Arch
cpCompilerVersion :: CompilerPaths -> ActualCompiler
cpCompiler :: CompilerPaths -> Path Abs File
..} = ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
  Unique CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m ()
deleteBy (Unique CompilerCache -> ReaderT SqlBackend (RIO env) ())
-> Unique CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Unique CompilerCache
UniqueCompilerInfo (FilePath -> Unique CompilerCache)
-> FilePath -> Unique CompilerCache
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpCompiler
  FileStatus
compilerStatus <- IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus)
-> IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus (FilePath -> IO FileStatus) -> FilePath -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpCompiler
  FileStatus
globalDbStatus <- IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus)
-> IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus (FilePath -> IO FileStatus) -> FilePath -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
cpGlobalDB Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelFile "package.cache")
  let GhcPkgExe Path Abs File
pkgexe = GhcPkgExe
cpPkg
  CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ CompilerCache :: ActualCompiler
-> Text
-> FilePath
-> Int64
-> Int64
-> FilePath
-> FilePath
-> FilePath
-> Text
-> FilePath
-> Int64
-> Int64
-> ByteString
-> Text
-> CompilerCache
CompilerCache
    { compilerCacheActualVersion :: ActualCompiler
compilerCacheActualVersion = ActualCompiler
cpCompilerVersion
    , compilerCacheGhcPath :: FilePath
compilerCacheGhcPath = Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpCompiler
    , compilerCacheGhcSize :: Int64
compilerCacheGhcSize = COff -> Int64
sizeToInt64 (COff -> Int64) -> COff -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
compilerStatus
    , compilerCacheGhcModified :: Int64
compilerCacheGhcModified = CTime -> Int64
timeToInt64 (CTime -> Int64) -> CTime -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
compilerStatus
    , compilerCacheGhcPkgPath :: FilePath
compilerCacheGhcPkgPath = Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
pkgexe
    , compilerCacheRunghcPath :: FilePath
compilerCacheRunghcPath = Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpInterpreter
    , compilerCacheHaddockPath :: FilePath
compilerCacheHaddockPath = Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpHaddock
    , compilerCacheCabalVersion :: Text
compilerCacheCabalVersion = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Version -> FilePath
versionString Version
cpCabalVersion
    , compilerCacheGlobalDb :: FilePath
compilerCacheGlobalDb = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
cpGlobalDB
    , compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDbCacheSize = COff -> Int64
sizeToInt64 (COff -> Int64) -> COff -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
globalDbStatus
    , compilerCacheGlobalDbCacheModified :: Int64
compilerCacheGlobalDbCacheModified = CTime -> Int64
timeToInt64 (CTime -> Int64) -> CTime -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
globalDbStatus
    , compilerCacheInfo :: ByteString
compilerCacheInfo = ByteString
cpGhcInfo
    , compilerCacheGlobalDump :: Text
compilerCacheGlobalDump = Map PackageName DumpPackage -> Text
forall a. Show a => a -> Text
tshow Map PackageName DumpPackage
cpGlobalDump
    , compilerCacheArch :: Text
compilerCacheArch = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Arch -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display Arch
cpArch
    }

-- | How many upgrade checks have occurred since the given timestamp?
upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince :: UTCTime -> RIO env Int
upgradeChecksSince UTCTime
since = ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) Int -> RIO env Int)
-> ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ [Filter LastPerformed] -> ReaderT SqlBackend (RIO env) Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count
  [ EntityField LastPerformed Action
forall typ. (typ ~ Action) => EntityField LastPerformed typ
LastPerformedAction EntityField LastPerformed Action -> Action -> Filter LastPerformed
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Action
UpgradeCheck
  , EntityField LastPerformed UTCTime
forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp EntityField LastPerformed UTCTime
-> UTCTime -> Filter LastPerformed
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. UTCTime
since
  ]

-- | Log in the database that an upgrade check occurred at the given time.
logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck :: UTCTime -> RIO env ()
logUpgradeCheck UTCTime
time = ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) (Entity LastPerformed)
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend (RIO env) (Entity LastPerformed)
 -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) (Entity LastPerformed)
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ LastPerformed
-> [Update LastPerformed]
-> ReaderT SqlBackend (RIO env) (Entity LastPerformed)
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
upsert
  (Action -> UTCTime -> LastPerformed
LastPerformed Action
UpgradeCheck UTCTime
time)
  [EntityField LastPerformed UTCTime
forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp EntityField LastPerformed UTCTime
-> UTCTime -> Update LastPerformed
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
time]