{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# 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
      , 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 = 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 forall a b. (a -> b) -> a -> b
$ UserStorage -> RIO env a
f 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasConfig env => Lens' env Config
configL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Config -> UserStorage
configUserStorage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to UserStorage -> Storage
unUserStorage)
    Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
SQLite.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 =
    FilePath
-> Text
-> Text
-> Text
-> ByteString
-> Bool
-> Unique PrecompiledCacheParent
UniquePrecompiledCacheParent
        (forall b t. Path b t -> FilePath
toFilePath Path Rel Dir
platformGhcDir)
        (ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler)
        (FilePath -> Text
T.pack 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 :: 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 <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique PrecompiledCacheParent
key
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Entity PrecompiledCacheParent)
mparent forall a b. (a -> b) -> a -> b
$ \(Entity Key PrecompiledCacheParent
parentId PrecompiledCacheParent {Bool
FilePath
Maybe FilePath
Text
ByteString
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile Maybe FilePath
precompiledCacheParentLibrary
        [Path Rel File]
pcSubLibs <-
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheSubLib -> FilePath
precompiledCacheSubLibValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
        [Path Rel File]
pcExes <-
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheExe -> FilePath
precompiledCacheExeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
        forall (m :: * -> *) a. Monad m => a -> m a
return (Key PrecompiledCacheParent
parentId, 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 :: forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache Unique PrecompiledCacheParent
key = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 FilePath
precompiledCacheParentPlatformGhcDir Text
precompiledCacheParentCompiler Text
precompiledCacheParentCabalVersion Text
precompiledCacheParentPackageKey ByteString
precompiledCacheParentOptionsHash Bool
precompiledCacheParentHaddock) PrecompiledCache Rel
new =
    forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ do
        let precompiledCacheParentLibrary :: Maybe FilePath
precompiledCacheParentLibrary = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b t. Path b t -> FilePath
toFilePath (forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Rel
new)
        Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
mIdOld <- 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 -> (, forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m (Key record)
insert PrecompiledCacheParent {Bool
FilePath
Maybe FilePath
Text
ByteString
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
                    forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update
                        Key PrecompiledCacheParent
parentId
                        [ forall typ.
(typ ~ Maybe FilePath) =>
EntityField PrecompiledCacheParent typ
PrecompiledCacheParentLibrary forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
                          Maybe FilePath
precompiledCacheParentLibrary
                        ]
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Key PrecompiledCacheParent
parentId, forall a. a -> Maybe a
Just PrecompiledCache Rel
old)
        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
            forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent
            Key PrecompiledCacheParent
parentId
            forall typ.
(typ ~ FilePath) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibValue
            (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty (forall {b} {t}. [Path b t] -> Set FilePath
toFilePathSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall base. PrecompiledCache base -> [Path base File]
pcSubLibs) Maybe (PrecompiledCache Rel)
mold)
            (forall {b} {t}. [Path b t] -> Set FilePath
toFilePathSet forall a b. (a -> b) -> a -> b
$ forall base. PrecompiledCache base -> [Path base File]
pcSubLibs PrecompiledCache Rel
new)
        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
            forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent
            Key PrecompiledCacheParent
parentId
            forall typ. (typ ~ FilePath) => EntityField PrecompiledCacheExe typ
PrecompiledCacheExeValue
            (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty (forall {b} {t}. [Path b t] -> Set FilePath
toFilePathSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall base. PrecompiledCache base -> [Path base File]
pcExes) Maybe (PrecompiledCache Rel)
mold)
            (forall {b} {t}. [Path b t] -> Set FilePath
toFilePathSet forall a b. (a -> b) -> a -> b
$ forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Rel
new)
  where
    toFilePathSet :: [Path b t] -> Set FilePath
toFilePathSet = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 :: forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
loadDockerImageExeCache Text
imageId Path Abs File
exePath UTCTime
exeTimestamp =
    forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DockerImageExeCache -> Bool
dockerImageExeCacheCompatible forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    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 (forall b t. Path b t -> FilePath
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 =
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$
    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
             (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) = 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) = 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 <- forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall a b. (a -> b) -> a -> b
$ FilePath -> Unique CompilerCache
UniqueCompilerInfo forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath Path Abs File
compiler
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (Entity CompilerCache)
mres forall a b. (a -> b) -> a -> b
$ \(Entity Key CompilerCache
_ CompilerCache {Int64
FilePath
Text
ByteString
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath Path Abs File
compiler
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (Int64
compilerCacheGhcSize forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
compilerStatus) Bool -> Bool -> Bool
||
       Int64
compilerCacheGhcModified forall a. Eq a => a -> a -> Bool
/= CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
compilerStatus))
      (forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"Compiler file metadata mismatch, ignoring cache")
    FileStatus
globalDbStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ FilePath
compilerCacheGlobalDb FilePath -> ShowS
FP.</> FilePath
"package.cache"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (Int64
compilerCacheGlobalDbCacheSize forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
globalDbStatus) Bool -> Bool -> Bool
||
       Int64
compilerCacheGlobalDbCacheModified forall a. Eq a => a -> a -> Bool
/= CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
globalDbStatus))
      (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 <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
compilerCacheGhcPkgPath
    Path Abs File
runghc <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
compilerCacheRunghcPath
    Path Abs File
haddock <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' FilePath
compilerCacheHaddockPath
    Path Abs Dir
globaldb <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' FilePath
compilerCacheGlobalDb

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

    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall env. HasConfig env => CompilerPaths -> RIO env ()
saveCompilerPaths CompilerPaths {Bool
Map PackageName DumpPackage
ByteString
Version
Path Abs File
Path Abs Dir
Arch
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
..} = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ do
  forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m ()
deleteBy forall a b. (a -> b) -> a -> b
$ FilePath -> Unique CompilerCache
UniqueCompilerInfo forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpCompiler
  FileStatus
compilerStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpCompiler
  FileStatus
globalDbStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
cpGlobalDB forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelFile "package.cache")
  let GhcPkgExe Path Abs File
pkgexe = GhcPkgExe
cpPkg
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ CompilerCache
    { compilerCacheActualVersion :: ActualCompiler
compilerCacheActualVersion = ActualCompiler
cpCompilerVersion
    , compilerCacheGhcPath :: FilePath
compilerCacheGhcPath = forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpCompiler
    , compilerCacheGhcSize :: Int64
compilerCacheGhcSize = COff -> Int64
sizeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
compilerStatus
    , compilerCacheGhcModified :: Int64
compilerCacheGhcModified = CTime -> Int64
timeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
compilerStatus
    , compilerCacheGhcPkgPath :: FilePath
compilerCacheGhcPkgPath = forall b t. Path b t -> FilePath
toFilePath Path Abs File
pkgexe
    , compilerCacheRunghcPath :: FilePath
compilerCacheRunghcPath = forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpInterpreter
    , compilerCacheHaddockPath :: FilePath
compilerCacheHaddockPath = forall b t. Path b t -> FilePath
toFilePath Path Abs File
cpHaddock
    , compilerCacheCabalVersion :: Text
compilerCacheCabalVersion = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> FilePath
versionString Version
cpCabalVersion
    , compilerCacheGlobalDb :: FilePath
compilerCacheGlobalDb = forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
cpGlobalDB
    , compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDbCacheSize = COff -> Int64
sizeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
globalDbStatus
    , compilerCacheGlobalDbCacheModified :: Int64
compilerCacheGlobalDbCacheModified = CTime -> Int64
timeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
globalDbStatus
    , compilerCacheInfo :: ByteString
compilerCacheInfo = ByteString
cpGhcInfo
    , compilerCacheGlobalDump :: Text
compilerCacheGlobalDump = forall a. Show a => a -> Text
tshow Map PackageName DumpPackage
cpGlobalDump
    , compilerCacheArch :: Text
compilerCacheArch = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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 :: forall env. HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince UTCTime
since = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count
  [ forall typ. (typ ~ Action) => EntityField LastPerformed typ
LastPerformedAction forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Action
UpgradeCheck
  , forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp 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 = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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)
  [forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
time]