{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# 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
                   ( Entity (..), SqlBackend, Unique, (=.), (==.), (>=.), count
                   , deleteBy, getBy, insert, insert_, selectList, update
                   , upsert
                   )
import           Database.Persist.TH
                   ( mkMigrate, mkPersist, persistLowerCase, share
                   , sqlSettings
                   )
import           Distribution.Text ( simpleParse, display )
import           Foreign.C.Types ( CTime (..) )
import           Pantry.SQLite ( initStorage, withStorage_ )
import           Path ( (</>), mkRelFile, parseRelFile )
import           Path.IO ( resolveFile', resolveDir' )
import qualified RIO.FilePath as FP
import           Stack.Prelude
import           Stack.Storage.Util ( handleMigrationException, updateSet )
import           Stack.Types.Build ( PrecompiledCache (..) )
import           Stack.Types.Cache ( Action (..) )
import           Stack.Types.Compiler ( ActualCompiler, compilerVersionText )
import           Stack.Types.CompilerBuild ( CompilerBuild )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.Storage ( UserStorage (..) )
import           System.Posix.Types ( COff (..) )
import           System.PosixCompat.Files
                   ( fileSize, getFileStatus, modificationTime )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Storage.User" module.

data StorageUserException
  = CompilerFileMetadataMismatch
  | GlobalPackageCacheFileMetadataMismatch
  | GlobalDumpParseFailure
  | CompilerCacheArchitectureInvalid Text
  deriving (Int -> StorageUserException -> ShowS
[StorageUserException] -> ShowS
StorageUserException -> String
(Int -> StorageUserException -> ShowS)
-> (StorageUserException -> String)
-> ([StorageUserException] -> ShowS)
-> Show StorageUserException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StorageUserException -> ShowS
showsPrec :: Int -> StorageUserException -> ShowS
$cshow :: StorageUserException -> String
show :: StorageUserException -> String
$cshowList :: [StorageUserException] -> ShowS
showList :: [StorageUserException] -> ShowS
Show, Typeable)

instance Exception StorageUserException where
  displayException :: StorageUserException -> String
displayException StorageUserException
CompilerFileMetadataMismatch =
    String
"Error: [S-8196]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Compiler file metadata mismatch, ignoring cache."
  displayException StorageUserException
GlobalPackageCacheFileMetadataMismatch =
    String
"Error: [S-5378]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Global package cache file metadata mismatch, ignoring cache."
  displayException StorageUserException
GlobalDumpParseFailure =
    String
"Error: [S-2673]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Global dump did not parse correctly."
  displayException
    (CompilerCacheArchitectureInvalid Text
compilerCacheArch) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Error: [S-8441]\n"
      , String
"Invalid arch: "
      , Text -> String
forall a. Show a => a -> String
show Text
compilerCacheArch
      ]

share [ mkPersist 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" OnDeleteCascade
  value FilePath sql="sub_lib"
  UniquePrecompiledCacheSubLib parent value
  deriving Show

PrecompiledCacheExe
  parent PrecompiledCacheParentId sql="precompiled_cache_id" OnDeleteCaseCascade
  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 :: forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage Path Abs File
fp UserStorage -> 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
$ 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 :: forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage 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 ((Config -> Const Storage Config) -> env -> Const Storage env
forall env. HasConfig env => Lens' env Config
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 -> Storage) -> SimpleGetter Config Storage
forall s a. (s -> a) -> SimpleGetter s a
to (.userStorage.userStorage))
  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 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 =
  String
-> Text
-> Text
-> Text
-> ByteString
-> Bool
-> Unique PrecompiledCacheParent
UniquePrecompiledCacheParent
    (Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
platformGhcDir)
    (ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler)
    (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
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 :: forall env.
(HasConfig env, HasLogFunc env) =>
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))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend 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
precompiledCacheParent) -> do
    Maybe (Path Rel File)
library <-
      (String -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> Maybe String
-> 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)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM String -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile PrecompiledCacheParent
precompiledCacheParent.precompiledCacheParentLibrary
    [Path Rel File]
subLibs <-
      (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> (Entity PrecompiledCacheSubLib -> String)
-> Entity PrecompiledCacheSubLib
-> ReaderT SqlBackend (RIO env) (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.precompiledCacheSubLibValue) (PrecompiledCacheSubLib -> String)
-> (Entity PrecompiledCacheSubLib -> PrecompiledCacheSubLib)
-> Entity PrecompiledCacheSubLib
-> String
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]
exes <-
      (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> (Entity PrecompiledCacheExe -> String)
-> Entity PrecompiledCacheExe
-> ReaderT SqlBackend (RIO env) (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.precompiledCacheExeValue) (PrecompiledCacheExe -> String)
-> (Entity PrecompiledCacheExe -> PrecompiledCacheExe)
-> Entity PrecompiledCacheExe
-> String
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 a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( Key PrecompiledCacheParent
parentId
      , PrecompiledCache
          { Maybe (Path Rel File)
library :: Maybe (Path Rel File)
$sel:library:PrecompiledCache :: Maybe (Path Rel File)
library
          , [Path Rel File]
subLibs :: [Path Rel File]
$sel:subLibs:PrecompiledCache :: [Path Rel File]
subLibs
          , [Path Rel File]
exes :: [Path Rel File]
$sel:exes:PrecompiledCache :: [Path Rel File]
exes
          }
      )

-- | Load 'PrecompiledCache' from the database.

loadPrecompiledCache ::
     (HasConfig env, HasLogFunc env)
  => PrecompiledCacheKey
  -> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache :: forall env.
(HasConfig env, HasLogFunc env) =>
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 a b. (a -> b) -> Maybe a -> Maybe b
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 :: forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent -> PrecompiledCache Rel -> RIO env ()
savePrecompiledCache
  key :: Unique PrecompiledCacheParent
key@( UniquePrecompiledCacheParent
          String
precompiledCacheParentPlatformGhcDir
          Text
precompiledCacheParentCompiler
          Text
precompiledCacheParentCabalVersion
          Text
precompiledCacheParentPackageKey
          ByteString
precompiledCacheParentOptionsHash
          Bool
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 String
precompiledCacheParentLibrary = (Path Rel File -> String) -> Maybe (Path Rel File) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Rel File -> String
forall b t. Path b t -> String
toFilePath PrecompiledCache Rel
new.library
      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, 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 PrecompiledCacheParent
            { String
$sel:precompiledCacheParentPlatformGhcDir:PrecompiledCacheParent :: String
precompiledCacheParentPlatformGhcDir :: String
precompiledCacheParentPlatformGhcDir
            , Text
$sel:precompiledCacheParentCompiler:PrecompiledCacheParent :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentCompiler
            , Text
$sel:precompiledCacheParentCabalVersion:PrecompiledCacheParent :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCabalVersion
            , Text
$sel:precompiledCacheParentPackageKey:PrecompiledCacheParent :: Text
precompiledCacheParentPackageKey :: Text
precompiledCacheParentPackageKey
            , ByteString
$sel:precompiledCacheParentOptionsHash:PrecompiledCacheParent :: ByteString
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentOptionsHash
            , Bool
$sel:precompiledCacheParentHaddock:PrecompiledCacheParent :: Bool
precompiledCacheParentHaddock :: Bool
precompiledCacheParentHaddock
            , Maybe String
$sel:precompiledCacheParentLibrary:PrecompiledCacheParent :: Maybe String
precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentLibrary
            }
          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 ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> [Update record] -> ReaderT SqlBackend m ()
update
              Key PrecompiledCacheParent
parentId
              [ EntityField PrecompiledCacheParent (Maybe String)
forall typ.
(typ ~ Maybe String) =>
EntityField PrecompiledCacheParent typ
PrecompiledCacheParentLibrary EntityField PrecompiledCacheParent (Maybe String)
-> Maybe String -> Update PrecompiledCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
                Maybe String
precompiledCacheParentLibrary
              ]
            (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key PrecompiledCacheParent
parentId, PrecompiledCache Rel -> Maybe (PrecompiledCache Rel)
forall a. a -> Maybe a
Just PrecompiledCache Rel
old)
      (Key PrecompiledCacheParent -> String -> PrecompiledCacheSubLib)
-> EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent
-> EntityField PrecompiledCacheSubLib String
-> Set String
-> Set String
-> 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 PrecompiledCacheParent -> String -> PrecompiledCacheSubLib
PrecompiledCacheSubLib
        EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent
        Key PrecompiledCacheParent
parentId
        EntityField PrecompiledCacheSubLib String
forall typ.
(typ ~ String) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibValue
        (Set String
-> (PrecompiledCache Rel -> Set String)
-> Maybe (PrecompiledCache Rel)
-> Set String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set String
forall a. Set a
Set.empty ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet ([Path Rel File] -> Set String)
-> (PrecompiledCache Rel -> [Path Rel File])
-> PrecompiledCache Rel
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.subLibs)) Maybe (PrecompiledCache Rel)
mold)
        ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet PrecompiledCache Rel
new.subLibs)
      (Key PrecompiledCacheParent -> String -> PrecompiledCacheExe)
-> EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent
-> EntityField PrecompiledCacheExe String
-> Set String
-> Set String
-> 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 PrecompiledCacheParent -> String -> PrecompiledCacheExe
PrecompiledCacheExe
        EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent
        Key PrecompiledCacheParent
parentId
        EntityField PrecompiledCacheExe String
forall typ. (typ ~ String) => EntityField PrecompiledCacheExe typ
PrecompiledCacheExeValue
        (Set String
-> (PrecompiledCache Rel -> Set String)
-> Maybe (PrecompiledCache Rel)
-> Set String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set String
forall a. Set a
Set.empty ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet ([Path Rel File] -> Set String)
-> (PrecompiledCache Rel -> [Path Rel File])
-> PrecompiledCache Rel
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.exes)) Maybe (PrecompiledCache Rel)
mold)
        ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet PrecompiledCache Rel
new.exes)
 where
  toFilePathSet :: [Path b t] -> Set String
toFilePathSet = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String)
-> ([Path b t] -> [String]) -> [Path b t] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path b t -> String) -> [Path b t] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path b t -> String
forall b t. Path b t -> String
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 :: forall env.
(HasConfig env, HasLogFunc env) =>
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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((.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))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Text -> String -> UTCTime -> Unique DockerImageExeCache
DockerImageExeCacheUnique Text
imageId (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
exePath) UTCTime
exeTimestamp)

-- | Sets 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 :: forall env.
(HasConfig env, HasLogFunc env) =>
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,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 OnlyOneUniqueKey record, SafeToInsert record) =>
record -> [Update record] -> ReaderT SqlBackend m (Entity record)
upsert
      ( Text -> String -> UTCTime -> Bool -> DockerImageExeCache
DockerImageExeCache
          Text
imageId
          (Path Abs File -> String
forall b t. Path b t -> String
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 :: forall env.
HasConfig env =>
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))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend 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
$ String -> Unique CompilerCache
UniqueCompilerInfo (String -> Unique CompilerCache) -> String -> Unique CompilerCache
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
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
compilerCache) -> do
    FileStatus
compilerStatus <- IO FileStatus -> RIO env FileStatus
forall a. IO a -> RIO env a
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
$ String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
compiler
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (  CompilerCache
compilerCache.compilerCacheGhcSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=
           COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
compilerStatus)
      Bool -> Bool -> Bool
|| CompilerCache
compilerCache.compilerCacheGhcModified Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=
           CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
compilerStatus)
      )
      (StorageUserException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
CompilerFileMetadataMismatch)
    FileStatus
globalDbStatus <- IO FileStatus -> RIO env FileStatus
forall a. IO a -> RIO env a
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
$
      String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ CompilerCache
compilerCache.compilerCacheGlobalDb String -> ShowS
FP.</> String
"package.cache"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (  CompilerCache
compilerCache.compilerCacheGlobalDbCacheSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=
           COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
globalDbStatus)
      Bool -> Bool -> Bool
|| CompilerCache
compilerCache.compilerCacheGlobalDbCacheModified Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=
           CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
globalDbStatus)
      )
      (StorageUserException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
GlobalPackageCacheFileMetadataMismatch)

    -- 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

    GhcPkgExe
pkg <- Path Abs File -> GhcPkgExe
GhcPkgExe (Path Abs File -> GhcPkgExe)
-> RIO env (Path Abs File) -> RIO env GhcPkgExe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' CompilerCache
compilerCache.compilerCacheGhcPkgPath
    Path Abs File
interpreter <- String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' CompilerCache
compilerCache.compilerCacheRunghcPath
    Path Abs File
haddock <- String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' CompilerCache
compilerCache.compilerCacheHaddockPath
    Path Abs Dir
globalDB <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' CompilerCache
compilerCache.compilerCacheGlobalDb

    Version
cabalVersion <- String -> RIO env Version
forall (m :: * -> *). MonadThrow m => String -> m Version
parseVersionThrowing (String -> RIO env Version) -> String -> RIO env Version
forall a b. (a -> b) -> a -> b
$
      Text -> String
T.unpack CompilerCache
compilerCache.compilerCacheCabalVersion
    Map PackageName DumpPackage
globalDump <-
      case String -> Maybe (Map PackageName DumpPackage)
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe (Map PackageName DumpPackage))
-> String -> Maybe (Map PackageName DumpPackage)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack CompilerCache
compilerCache.compilerCacheGlobalDump of
        Maybe (Map PackageName DumpPackage)
Nothing -> StorageUserException -> RIO env (Map PackageName DumpPackage)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
GlobalDumpParseFailure
        Just Map PackageName DumpPackage
globalDump -> Map PackageName DumpPackage
-> RIO env (Map PackageName DumpPackage)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName DumpPackage
globalDump
    Arch
arch <-
      case String -> Maybe Arch
forall a. Parsec a => String -> Maybe a
simpleParse (String -> Maybe Arch) -> String -> Maybe Arch
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack CompilerCache
compilerCache.compilerCacheArch of
        Maybe Arch
Nothing -> StorageUserException -> RIO env Arch
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (StorageUserException -> RIO env Arch)
-> StorageUserException -> RIO env Arch
forall a b. (a -> b) -> a -> b
$
          Text -> StorageUserException
CompilerCacheArchitectureInvalid CompilerCache
compilerCache.compilerCacheArch
        Just Arch
arch -> Arch -> RIO env Arch
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arch
arch
    CompilerPaths -> RIO env CompilerPaths
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
      { Path Abs File
compiler :: Path Abs File
$sel:compiler:CompilerPaths :: Path Abs File
compiler
      , $sel:compilerVersion:CompilerPaths :: ActualCompiler
compilerVersion = CompilerCache
compilerCache.compilerCacheActualVersion
      , Arch
arch :: Arch
$sel:arch:CompilerPaths :: Arch
arch
      , CompilerBuild
build :: CompilerBuild
$sel:build:CompilerPaths :: CompilerBuild
build
      , GhcPkgExe
pkg :: GhcPkgExe
$sel:pkg:CompilerPaths :: GhcPkgExe
pkg
      , Path Abs File
interpreter :: Path Abs File
$sel:interpreter:CompilerPaths :: Path Abs File
interpreter
      , Path Abs File
haddock :: Path Abs File
$sel:haddock:CompilerPaths :: Path Abs File
haddock
      , Bool
sandboxed :: Bool
$sel:sandboxed:CompilerPaths :: Bool
sandboxed
      , Version
cabalVersion :: Version
$sel:cabalVersion:CompilerPaths :: Version
cabalVersion
      , Path Abs Dir
globalDB :: Path Abs Dir
$sel:globalDB:CompilerPaths :: Path Abs Dir
globalDB
      , $sel:ghcInfo:CompilerPaths :: ByteString
ghcInfo = CompilerCache
compilerCache.compilerCacheInfo
      , Map PackageName DumpPackage
globalDump :: Map PackageName DumpPackage
$sel:globalDump:CompilerPaths :: Map PackageName DumpPackage
globalDump
      }

-- | Save compiler information. May throw exceptions!

saveCompilerPaths ::
     HasConfig env
  => CompilerPaths
  -> RIO env ()
saveCompilerPaths :: forall env. HasConfig env => CompilerPaths -> RIO env ()
saveCompilerPaths CompilerPaths
cp = 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 ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m ()
deleteBy (Unique CompilerCache -> ReaderT SqlBackend (RIO env) ())
-> Unique CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ String -> Unique CompilerCache
UniqueCompilerInfo (String -> Unique CompilerCache) -> String -> Unique CompilerCache
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.compiler
  FileStatus
compilerStatus <- IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a. IO a -> ReaderT SqlBackend (RIO env) a
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
$ String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.compiler
  FileStatus
globalDbStatus <- IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a. IO a -> ReaderT SqlBackend (RIO env) a
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
$
    String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ CompilerPaths
cp.globalDB 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 = CompilerPaths
cp.pkg
  CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m ()
insert_ CompilerCache
    { $sel:compilerCacheActualVersion:CompilerCache :: ActualCompiler
compilerCacheActualVersion = CompilerPaths
cp.compilerVersion
    , $sel:compilerCacheGhcPath:CompilerCache :: String
compilerCacheGhcPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.compiler
    , $sel:compilerCacheGhcSize:CompilerCache :: Int64
compilerCacheGhcSize = COff -> Int64
sizeToInt64 (COff -> Int64) -> COff -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
compilerStatus
    , $sel:compilerCacheGhcModified:CompilerCache :: Int64
compilerCacheGhcModified = CTime -> Int64
timeToInt64 (CTime -> Int64) -> CTime -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
compilerStatus
    , $sel:compilerCacheGhcPkgPath:CompilerCache :: String
compilerCacheGhcPkgPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgexe
    , $sel:compilerCacheRunghcPath:CompilerCache :: String
compilerCacheRunghcPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.interpreter
    , $sel:compilerCacheHaddockPath:CompilerCache :: String
compilerCacheHaddockPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.haddock
    , $sel:compilerCacheCabalVersion:CompilerCache :: Text
compilerCacheCabalVersion = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString CompilerPaths
cp.cabalVersion
    , $sel:compilerCacheGlobalDb:CompilerCache :: String
compilerCacheGlobalDb = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.globalDB
    , $sel:compilerCacheGlobalDbCacheSize:CompilerCache :: Int64
compilerCacheGlobalDbCacheSize = COff -> Int64
sizeToInt64 (COff -> Int64) -> COff -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
globalDbStatus
    , $sel:compilerCacheGlobalDbCacheModified:CompilerCache :: Int64
compilerCacheGlobalDbCacheModified =
        CTime -> Int64
timeToInt64 (CTime -> Int64) -> CTime -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
globalDbStatus
    , $sel:compilerCacheInfo:CompilerCache :: ByteString
compilerCacheInfo = CompilerPaths
cp.ghcInfo
    , $sel:compilerCacheGlobalDump:CompilerCache :: Text
compilerCacheGlobalDump = Map PackageName DumpPackage -> Text
forall a. Show a => a -> Text
tshow CompilerPaths
cp.globalDump
    , $sel:compilerCacheArch:CompilerCache :: Text
compilerCacheArch = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Arch -> String
forall a. Pretty a => a -> String
Distribution.Text.display CompilerPaths
cp.arch
    }

-- | How many upgrade checks have occurred since the given timestamp?

upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince :: forall env. HasConfig env => 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
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> ReaderT SqlBackend 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 :: forall env. HasConfig env => 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,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 OnlyOneUniqueKey record, SafeToInsert record) =>
record -> [Update record] -> ReaderT SqlBackend 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]