module System.Nix.Store.DB.Run
  ( systemConnectionInfo
  , runSystemSqlite
  , memoryConnectionInfo
  , runInMemory
  , runCustom
  , runWithLogging
  , allMigrations
  , doMigrateAll
  , memTest
  , testMigrateAll
  , test
  , bench
  ) where

import Control.Monad.Logger (LoggingT)
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.Default.Class (Default(def))
import Data.Text (Text)
import Database.Persist.Sql (SqlPersistM, SqlBackend, Migration)
import Database.Persist.Sqlite (SqliteConnectionInfo)

import System.Nix.Store.DB.Query

import qualified Control.Monad
import qualified Control.Monad.IO.Class
import qualified Control.Monad.Logger
import qualified Data.ByteString.Char8
import qualified Database.Esqueleto.Experimental
import qualified Database.Persist.Sql
import qualified Database.Persist.Sqlite
import qualified System.Log.FastLogger
import qualified System.Nix.StorePath
import qualified System.Nix.Store.DB.Schema
import qualified System.Nix.Store.DB.Util

-- | @SqliteConnectionInfo@ for accessing
-- systems database in /nix/var/nix/db/db.sqlite
-- Currently set to immutable
systemConnectionInfo :: SqliteConnectionInfo
systemConnectionInfo :: SqliteConnectionInfo
systemConnectionInfo =
  Text -> SqliteConnectionInfo
Database.Persist.Sqlite.mkSqliteConnectionInfo
    Text
"file:/nix/var/nix/db/db.sqlite?immutable=1"

-- | Run with @systemConnectionInfo@
runSystemSqlite
  :: SqlPersistM a
  -> IO a
runSystemSqlite :: forall a. SqlPersistM a -> IO a
runSystemSqlite =
  SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
Database.Persist.Sqlite.runSqliteInfo
    SqliteConnectionInfo
systemConnectionInfo

-- | @SqliteConnectionInfo@ for running in memory
memoryConnectionInfo :: SqliteConnectionInfo
memoryConnectionInfo :: SqliteConnectionInfo
memoryConnectionInfo =
  Text -> SqliteConnectionInfo
Database.Persist.Sqlite.mkSqliteConnectionInfo
    Text
":memory:"

-- | Run with @memoryConnectionInfo@
runInMemory
  :: SqlPersistM a
  -> IO a
runInMemory :: forall a. SqlPersistM a -> IO a
runInMemory =
  SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
Database.Persist.Sqlite.runSqliteInfo
    SqliteConnectionInfo
memoryConnectionInfo

-- | Run with custom connection string
runCustom
  :: Text
  -> SqlPersistM a
  -> IO a
runCustom :: forall a. Text -> SqlPersistM a -> IO a
runCustom =
  Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
Database.Persist.Sqlite.runSqlite

-- | Run with logging
runWithLogging
  :: MonadUnliftIO m
  => SqliteConnectionInfo
  -> ReaderT SqlBackend (LoggingT m) a
  -> m a
runWithLogging :: forall (m :: * -> *) a.
MonadUnliftIO m =>
SqliteConnectionInfo -> ReaderT SqlBackend (LoggingT m) a -> m a
runWithLogging SqliteConnectionInfo
connInfo ReaderT SqlBackend (LoggingT m) a
act = do
  (LoggingT m a
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
Control.Monad.Logger.runLoggingT
    (\Loc
_ Text
_ LogLevel
_ LogStr
s ->
      ByteString -> IO ()
Data.ByteString.Char8.putStrLn
      (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
System.Log.FastLogger.fromLogStr LogStr
s
    )
    (LoggingT m a -> m a) -> LoggingT m a -> m a
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo
-> (SqlBackend -> LoggingT m a) -> LoggingT m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
Database.Persist.Sqlite.withSqliteConnInfo
        SqliteConnectionInfo
connInfo
        ((SqlBackend -> LoggingT m a) -> LoggingT m a)
-> (SqlBackend -> LoggingT m a) -> LoggingT m a
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (LoggingT m) a -> SqlBackend -> LoggingT m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
Database.Persist.Sql.runSqlConn ReaderT SqlBackend (LoggingT m) a
act

-- | Test that we can create in-memory database
-- and run a dummy query, used by smoke test
memTest :: IO ()
memTest :: IO ()
memTest = SqlPersistM () -> IO ()
forall a. SqlPersistM a -> IO a
runInMemory (SqlPersistM () -> IO ()) -> SqlPersistM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  SqlPersistM ()
forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
doMigrateAll
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
_ <- ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
SqlReadT
  (NoLoggingT (ResourceT IO))
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
SqlReadT
  m ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
queryEverything
  () -> SqlPersistM ()
forall a. a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

allMigrations :: Migration
allMigrations :: Migration
allMigrations = do
  let addSafeMigration :: Text -> Migration
addSafeMigration
          -- the False means it is not unsafe to run (idempotent)
        = Bool -> Text -> Migration
Database.Persist.Sql.addMigration Bool
False

  Migration
System.Nix.Store.DB.Schema.migrateAll

  Text -> Migration
addSafeMigration
    Text
"CREATE INDEX IF NOT EXISTS IndexReferrer ON Refs(referrer)"
  Text -> Migration
addSafeMigration
    Text
"CREATE INDEX IF NOT EXISTS IndexReference ON Refs(reference)"
  Text -> Migration
addSafeMigration
    Text
"CREATE INDEX IF NOT EXISTS IndexDerivationOutputs ON DerivationOutputs(path)"
  Text -> Migration
addSafeMigration
    Text
"CREATE TRIGGER IF NOT EXISTS DeleteSelfRefs before delete on ValidPaths \
    \begin delete from Refs where referrer = old.id and reference = old.id; end;"

-- | Perform migration
doMigrateAll
  :: MonadIO m
  => ReaderT SqlBackend m ()
doMigrateAll :: forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
doMigrateAll =
  Migration -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
Database.Persist.Sql.runMigration Migration
allMigrations

-- | Perform migration on real database
testMigrateAll :: IO ()
testMigrateAll :: IO ()
testMigrateAll = do
  let connInfo :: SqliteConnectionInfo
connInfo =
        Text -> SqliteConnectionInfo
Database.Persist.Sqlite.mkSqliteConnectionInfo
          Text
"/tmp/db.sqlite"
  SqliteConnectionInfo
-> ReaderT SqlBackend (LoggingT IO) () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
SqliteConnectionInfo -> ReaderT SqlBackend (LoggingT m) a -> m a
runWithLogging
    -- We need to disable foreign key checking otherwise
    -- the migration would fail
    (SqliteConnectionInfo -> SqliteConnectionInfo
System.Nix.Store.DB.Util.disableFK SqliteConnectionInfo
connInfo)
    -- this actually returns what queries were performed
    -- during migration so we just discard it
    (ReaderT SqlBackend (LoggingT IO) () -> IO ())
-> ReaderT SqlBackend (LoggingT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (LoggingT IO) [Text]
-> ReaderT SqlBackend (LoggingT IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void
    -- use runMigrationSilent as we have logging enabled
    (ReaderT SqlBackend (LoggingT IO) [Text]
 -> ReaderT SqlBackend (LoggingT IO) ())
-> ReaderT SqlBackend (LoggingT IO) [Text]
-> ReaderT SqlBackend (LoggingT IO) ()
forall a b. (a -> b) -> a -> b
$ Migration -> ReaderT SqlBackend (LoggingT IO) [Text]
forall (m :: * -> *).
MonadUnliftIO m =>
Migration -> ReaderT SqlBackend m [Text]
Database.Persist.Sql.runMigrationSilent Migration
allMigrations

-- | Elaborate test, testing most available query
-- functionality. Same as README.md (db-readme executable)
test :: IO ()
test :: IO ()
test = do
  SqlPersistM () -> IO ()
forall a. SqlPersistM a -> IO a
runSystemSqlite (SqlPersistM () -> IO ()) -> SqlPersistM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ([Entity ValidPath]
paths, [Entity Ref]
refs, [Entity DerivationOutput]
drvOuts) <- ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
SqlReadT
  (NoLoggingT (ResourceT IO))
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
SqlReadT
  m ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
queryEverything

    IO () -> SqlPersistM ()
forall a. IO a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Control.Monad.IO.Class.liftIO (IO () -> SqlPersistM ()) -> IO () -> SqlPersistM ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Stats: "
      let stat :: String -> t a -> IO ()
stat String
name t a
v = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
v)
      String -> [Entity ValidPath] -> IO ()
forall {t :: * -> *} {a}. Foldable t => String -> t a -> IO ()
stat String
"ValidPath(s)" [Entity ValidPath]
paths
      String -> [Entity Ref] -> IO ()
forall {t :: * -> *} {a}. Foldable t => String -> t a -> IO ()
stat String
"Ref(s)" [Entity Ref]
refs
      String -> [Entity DerivationOutput] -> IO ()
forall {t :: * -> *} {a}. Foldable t => String -> t a -> IO ()
stat String
"DerivationOutput(s)" [Entity DerivationOutput]
drvOuts

    Maybe (Entity ValidPath)
maybeValidPath <- ReaderT
  SqlBackend (NoLoggingT (ResourceT IO)) (Maybe (Entity ValidPath))
SqlReadT (NoLoggingT (ResourceT IO)) (Maybe (Entity ValidPath))
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
SqlReadT m (Maybe (Entity ValidPath))
queryOneValidDerivationEntity
    case Maybe (Entity ValidPath)
maybeValidPath of
      Maybe (Entity ValidPath)
Nothing -> () -> SqlPersistM ()
forall a. a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Entity ValidPath
validPathEntity -> do
        let pth :: StorePath
pth =
              ValidPath -> StorePath
System.Nix.Store.DB.Schema.validPathPath
              (ValidPath -> StorePath) -> ValidPath -> StorePath
forall a b. (a -> b) -> a -> b
$ Entity ValidPath -> ValidPath
forall record. Entity record -> record
Database.Esqueleto.Experimental.entityVal Entity ValidPath
validPathEntity

        (Maybe ValidPath
same, Maybe StorePath
samePath, [Ref]
references, [Ref]
referrers, [(Text, StorePath)]
validDerivers, [(Text, StorePath)]
outputs) <- (,,,,,)
          (Maybe ValidPath
 -> Maybe StorePath
 -> [Ref]
 -> [Ref]
 -> [(Text, StorePath)]
 -> [(Text, StorePath)]
 -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
     [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe ValidPath)
-> ReaderT
     SqlBackend
     (NoLoggingT (ResourceT IO))
     (Maybe StorePath
      -> [Ref]
      -> [Ref]
      -> [(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StorePath -> SqlReadT (NoLoggingT (ResourceT IO)) (Maybe ValidPath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StorePath -> SqlReadT m (Maybe ValidPath)
queryPathInfo StorePath
pth
          ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  (Maybe StorePath
   -> [Ref]
   -> [Ref]
   -> [(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe StorePath)
-> ReaderT
     SqlBackend
     (NoLoggingT (ResourceT IO))
     ([Ref]
      -> [Ref]
      -> [(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (a -> b)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StoreDir
-> StorePathHashPart
-> SqlReadT (NoLoggingT (ResourceT IO)) (Maybe StorePath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StoreDir -> StorePathHashPart -> SqlReadT m (Maybe StorePath)
queryPathFromHashPart StoreDir
forall a. Default a => a
def (StorePath -> StorePathHashPart
System.Nix.StorePath.storePathHash StorePath
pth)
          ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([Ref]
   -> [Ref]
   -> [(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Ref]
-> ReaderT
     SqlBackend
     (NoLoggingT (ResourceT IO))
     ([Ref]
      -> [(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (a -> b)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Entity ValidPath -> SqlReadT (NoLoggingT (ResourceT IO)) [Ref]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
Entity ValidPath -> SqlReadT m [Ref]
queryReferences Entity ValidPath
validPathEntity
          ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([Ref]
   -> [(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Ref]
-> ReaderT
     SqlBackend
     (NoLoggingT (ResourceT IO))
     ([(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (a -> b)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StorePath -> SqlReadT (NoLoggingT (ResourceT IO)) [Ref]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StorePath -> SqlReadT m [Ref]
queryReferrers StorePath
pth
          ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT
     SqlBackend (NoLoggingT (ResourceT IO)) [(Text, StorePath)]
-> ReaderT
     SqlBackend
     (NoLoggingT (ResourceT IO))
     ([(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (a -> b)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StorePath
-> SqlReadT (NoLoggingT (ResourceT IO)) [(Text, StorePath)]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StorePath -> SqlReadT m [(Text, StorePath)]
queryValidDerivers StorePath
pth
          ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT
     SqlBackend (NoLoggingT (ResourceT IO)) [(Text, StorePath)]
-> ReaderT
     SqlBackend
     (NoLoggingT (ResourceT IO))
     (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
      [(Text, StorePath)], [(Text, StorePath)])
forall a b.
ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (a -> b)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Entity ValidPath
-> SqlReadT (NoLoggingT (ResourceT IO)) [(Text, StorePath)]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
Entity ValidPath -> SqlReadT m [(Text, StorePath)]
queryDerivationOutputs Entity ValidPath
validPathEntity

        Bool -> SqlPersistM () -> SqlPersistM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (Maybe ValidPath
same Maybe ValidPath -> Maybe ValidPath -> Bool
forall a. Eq a => a -> a -> Bool
== ValidPath -> Maybe ValidPath
forall a. a -> Maybe a
Just (Entity ValidPath -> ValidPath
forall record. Entity record -> record
Database.Esqueleto.Experimental.entityVal Entity ValidPath
validPathEntity))
          (SqlPersistM () -> SqlPersistM ())
-> SqlPersistM () -> SqlPersistM ()
forall a b. (a -> b) -> a -> b
$ String -> SqlPersistM ()
forall a. HasCallStack => String -> a
error String
"queryPathInfo failed to roundtrip"
        Bool -> SqlPersistM () -> SqlPersistM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (Maybe StorePath
samePath Maybe StorePath -> Maybe StorePath -> Bool
forall a. Eq a => a -> a -> Bool
== StorePath -> Maybe StorePath
forall a. a -> Maybe a
Just StorePath
pth)
          (SqlPersistM () -> SqlPersistM ())
-> SqlPersistM () -> SqlPersistM ()
forall a b. (a -> b) -> a -> b
$ String -> SqlPersistM ()
forall a. HasCallStack => String -> a
error String
"queryPathFromHashPart failed to roundtrip"

        IO () -> SqlPersistM ()
forall a. IO a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Control.Monad.IO.Class.liftIO (IO () -> SqlPersistM ()) -> IO () -> SqlPersistM ()
forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"References: "
          [Ref] -> IO ()
forall a. Show a => a -> IO ()
print [Ref]
references
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Referrers: "
          [Ref] -> IO ()
forall a. Show a => a -> IO ()
print [Ref]
referrers
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Valid derivers: "
          [(Text, StorePath)] -> IO ()
forall a. Show a => a -> IO ()
print [(Text, StorePath)]
validDerivers
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Derivation outputs: "
          [(Text, StorePath)] -> IO ()
forall a. Show a => a -> IO ()
print [(Text, StorePath)]
outputs

    () -> SqlPersistM ()
forall a. a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Query everything and for each valid path
-- perform detailed queries
bench :: IO ()
bench :: IO ()
bench = do
  SqlPersistM () -> IO ()
forall a. SqlPersistM a -> IO a
runSystemSqlite (SqlPersistM () -> IO ()) -> SqlPersistM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ([Entity ValidPath]
paths, [Entity Ref]
refs, [Entity DerivationOutput]
drvOuts) <- ReaderT
  SqlBackend
  (NoLoggingT (ResourceT IO))
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
SqlReadT
  (NoLoggingT (ResourceT IO))
  ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
SqlReadT
  m ([Entity ValidPath], [Entity Ref], [Entity DerivationOutput])
queryEverything
    IO () -> SqlPersistM ()
forall a. IO a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Control.Monad.IO.Class.liftIO (IO () -> SqlPersistM ()) -> IO () -> SqlPersistM ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Stats: "
      let stat :: String -> t a -> IO ()
stat String
name t a
v = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
v)
      String -> [Entity ValidPath] -> IO ()
forall {t :: * -> *} {a}. Foldable t => String -> t a -> IO ()
stat String
"ValidPath(s)" [Entity ValidPath]
paths
      String -> [Entity Ref] -> IO ()
forall {t :: * -> *} {a}. Foldable t => String -> t a -> IO ()
stat String
"Ref(s)" [Entity Ref]
refs
      String -> [Entity DerivationOutput] -> IO ()
forall {t :: * -> *} {a}. Foldable t => String -> t a -> IO ()
stat String
"DerivationOutput(s)" [Entity DerivationOutput]
drvOuts

    [Entity ValidPath]
-> (Entity ValidPath -> SqlPersistM ()) -> SqlPersistM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Control.Monad.forM_ [Entity ValidPath]
paths Entity ValidPath -> SqlPersistM ()
forall {m :: * -> *} {backend}.
(MonadIO m, MonadLogger m, BackendCompatible SqlBackend backend,
 PersistQueryRead backend, PersistUniqueRead backend) =>
Entity ValidPath -> ReaderT backend m ()
proc
  where
    proc :: Entity ValidPath -> ReaderT backend m ()
proc Entity ValidPath
validPathEntity = do
      let pth :: StorePath
pth =
            ValidPath -> StorePath
System.Nix.Store.DB.Schema.validPathPath
            (ValidPath -> StorePath) -> ValidPath -> StorePath
forall a b. (a -> b) -> a -> b
$ Entity ValidPath -> ValidPath
forall record. Entity record -> record
Database.Esqueleto.Experimental.entityVal Entity ValidPath
validPathEntity

      (Maybe ValidPath
same, Maybe StorePath
samePath, [Ref]
_references, [Ref]
_referrers, [(Text, StorePath)]
_validDerivers, [(Text, StorePath)]
_outputs) <- (,,,,,)
        (Maybe ValidPath
 -> Maybe StorePath
 -> [Ref]
 -> [Ref]
 -> [(Text, StorePath)]
 -> [(Text, StorePath)]
 -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
     [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT backend m (Maybe ValidPath)
-> ReaderT
     backend
     m
     (Maybe StorePath
      -> [Ref]
      -> [Ref]
      -> [(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StorePath -> SqlReadT m (Maybe ValidPath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StorePath -> SqlReadT m (Maybe ValidPath)
queryPathInfo StorePath
pth
        ReaderT
  backend
  m
  (Maybe StorePath
   -> [Ref]
   -> [Ref]
   -> [(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT backend m (Maybe StorePath)
-> ReaderT
     backend
     m
     ([Ref]
      -> [Ref]
      -> [(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT backend m (a -> b)
-> ReaderT backend m a -> ReaderT backend m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StoreDir -> StorePathHashPart -> SqlReadT m (Maybe StorePath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StoreDir -> StorePathHashPart -> SqlReadT m (Maybe StorePath)
queryPathFromHashPart StoreDir
forall a. Default a => a
def (StorePath -> StorePathHashPart
System.Nix.StorePath.storePathHash StorePath
pth)
        ReaderT
  backend
  m
  ([Ref]
   -> [Ref]
   -> [(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT backend m [Ref]
-> ReaderT
     backend
     m
     ([Ref]
      -> [(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT backend m (a -> b)
-> ReaderT backend m a -> ReaderT backend m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Entity ValidPath -> SqlReadT m [Ref]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
Entity ValidPath -> SqlReadT m [Ref]
queryReferences Entity ValidPath
validPathEntity
        ReaderT
  backend
  m
  ([Ref]
   -> [(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT backend m [Ref]
-> ReaderT
     backend
     m
     ([(Text, StorePath)]
      -> [(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT backend m (a -> b)
-> ReaderT backend m a -> ReaderT backend m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StorePath -> SqlReadT m [Ref]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StorePath -> SqlReadT m [Ref]
queryReferrers StorePath
pth
        ReaderT
  backend
  m
  ([(Text, StorePath)]
   -> [(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT backend m [(Text, StorePath)]
-> ReaderT
     backend
     m
     ([(Text, StorePath)]
      -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
          [(Text, StorePath)], [(Text, StorePath)]))
forall a b.
ReaderT backend m (a -> b)
-> ReaderT backend m a -> ReaderT backend m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StorePath -> SqlReadT m [(Text, StorePath)]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
StorePath -> SqlReadT m [(Text, StorePath)]
queryValidDerivers StorePath
pth
        ReaderT
  backend
  m
  ([(Text, StorePath)]
   -> (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
       [(Text, StorePath)], [(Text, StorePath)]))
-> ReaderT backend m [(Text, StorePath)]
-> ReaderT
     backend
     m
     (Maybe ValidPath, Maybe StorePath, [Ref], [Ref],
      [(Text, StorePath)], [(Text, StorePath)])
forall a b.
ReaderT backend m (a -> b)
-> ReaderT backend m a -> ReaderT backend m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Entity ValidPath -> SqlReadT m [(Text, StorePath)]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
Entity ValidPath -> SqlReadT m [(Text, StorePath)]
queryDerivationOutputs Entity ValidPath
validPathEntity

      Bool -> ReaderT backend m () -> ReaderT backend m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (Maybe ValidPath
same Maybe ValidPath -> Maybe ValidPath -> Bool
forall a. Eq a => a -> a -> Bool
== ValidPath -> Maybe ValidPath
forall a. a -> Maybe a
Just (Entity ValidPath -> ValidPath
forall record. Entity record -> record
Database.Esqueleto.Experimental.entityVal Entity ValidPath
validPathEntity))
        (ReaderT backend m () -> ReaderT backend m ())
-> ReaderT backend m () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT backend m ()
forall a. HasCallStack => String -> a
error String
"queryPathInfo failed to roundtrip"
      Bool -> ReaderT backend m () -> ReaderT backend m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless (Maybe StorePath
samePath Maybe StorePath -> Maybe StorePath -> Bool
forall a. Eq a => a -> a -> Bool
== StorePath -> Maybe StorePath
forall a. a -> Maybe a
Just StorePath
pth)
        (ReaderT backend m () -> ReaderT backend m ())
-> ReaderT backend m () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT backend m ()
forall a. HasCallStack => String -> a
error String
"queryPathFromHashPart failed to roundtrip"