hnix-store-db (empty) → 0.1.0.0
raw patch · 13 files changed
+1275/−0 lines, 13 filesdep +attoparsecdep +basedep +bytestring
Dependencies added: attoparsec, base, bytestring, data-default-class, esqueleto, fast-logger, hnix-store-core, hnix-store-db, microlens, monad-logger, persistent, persistent-sqlite, template-haskell, text, time, transformers, unliftio-core
Files
- CHANGELOG.md +9/−0
- LICENSE +201/−0
- README.lhs +82/−0
- README.md +82/−0
- apps/Bench.hs +6/−0
- hnix-store-db.cabal +126/−0
- src/System/Nix/Store/DB.hs +9/−0
- src/System/Nix/Store/DB/Instances.hs +87/−0
- src/System/Nix/Store/DB/Query.hs +308/−0
- src/System/Nix/Store/DB/Run.hs +220/−0
- src/System/Nix/Store/DB/Schema.hs +63/−0
- src/System/Nix/Store/DB/Util.hs +71/−0
- tests/Smoke.hs +11/−0
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# 0.1.0.0 2024-07-31++* Initial release++---++`hnix-store-db` uses [PVP Versioning][1].++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2018 Shea Levy.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.lhs view
@@ -0,0 +1,82 @@+# hnix-store-db++[Nix] SQLite database implementation.++Only read-only functionality provided for+database schema version `10`.++[Nix]: https://nixos.org/nix++## API++The interface is experimental and might change wildly.++[System.Nix.Store.DB.Query]: ./src/System/Nix/Store/DB/Query.hs+[System.Nix.Store.DB.Run]: ./src/System/Nix/Store/DB/Run.hs+[System.Nix.Store.DB.Schema]: ./src/System/Nix/Store/DB/Schema.hs++## Example++This example is runnable via `cabal run db-readme`.++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Data.Default.Class (Default(def))++import qualified Control.Monad+import qualified Control.Monad.IO.Class++import qualified Database.Esqueleto.Experimental++import qualified System.Nix.StorePath+import qualified System.Nix.Store.DB.Run+import qualified System.Nix.Store.DB.Schema++import System.Nix.Store.DB.Query++main :: IO ()+main = do+ System.Nix.Store.DB.Run.runSystemSqlite $ do+ (paths, refs, drvOuts) <- queryEverything++ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "Stats: "+ let stat name v = putStrLn $ "- " ++ name ++ ": " ++ show (length v)+ stat "ValidPath(s)" paths+ stat "Ref(s)" refs+ stat "DerivationOutput(s)" drvOuts++ maybeValidPath <- queryOneValidDerivationEntity+ case maybeValidPath of+ Nothing -> pure ()+ Just validPathEntity -> do+ let pth =+ System.Nix.Store.DB.Schema.validPathPath+ $ Database.Esqueleto.Experimental.entityVal validPathEntity++ (same, samePath, references, referrers, validDerivers, outputs) <- (,,,,,)+ <$> queryPathInfo pth+ <*> queryPathFromHashPart def (System.Nix.StorePath.storePathHash pth)+ <*> queryReferences validPathEntity+ <*> queryReferrers pth+ <*> queryValidDerivers pth+ <*> queryDerivationOutputs validPathEntity++ Control.Monad.unless (same == Just (Database.Esqueleto.Experimental.entityVal validPathEntity))+ $ error "queryPathInfo failed to roundtrip"+ Control.Monad.unless (samePath == Just pth)+ $ error "queryPathFromHashPart failed to roundtrip"++ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "References: "+ print references+ putStrLn $ "Referrers: "+ print referrers+ putStrLn $ "Valid derivers: "+ print validDerivers+ putStrLn $ "Derivation outputs: "+ print outputs++ pure ()+```
+ README.md view
@@ -0,0 +1,82 @@+# hnix-store-db++[Nix] SQLite database implementation.++Only read-only functionality provided for+database schema version `10`.++[Nix]: https://nixos.org/nix++## API++The interface is experimental and might change wildly.++[System.Nix.Store.DB.Query]: ./src/System/Nix/Store/DB/Query.hs+[System.Nix.Store.DB.Run]: ./src/System/Nix/Store/DB/Run.hs+[System.Nix.Store.DB.Schema]: ./src/System/Nix/Store/DB/Schema.hs++## Example++This example is runnable via `cabal run db-readme`.++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Data.Default.Class (Default(def))++import qualified Control.Monad+import qualified Control.Monad.IO.Class++import qualified Database.Esqueleto.Experimental++import qualified System.Nix.StorePath+import qualified System.Nix.Store.DB.Run+import qualified System.Nix.Store.DB.Schema++import System.Nix.Store.DB.Query++main :: IO ()+main = do+ System.Nix.Store.DB.Run.runSystemSqlite $ do+ (paths, refs, drvOuts) <- queryEverything++ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "Stats: "+ let stat name v = putStrLn $ "- " ++ name ++ ": " ++ show (length v)+ stat "ValidPath(s)" paths+ stat "Ref(s)" refs+ stat "DerivationOutput(s)" drvOuts++ maybeValidPath <- queryOneValidDerivationEntity+ case maybeValidPath of+ Nothing -> pure ()+ Just validPathEntity -> do+ let pth =+ System.Nix.Store.DB.Schema.validPathPath+ $ Database.Esqueleto.Experimental.entityVal validPathEntity++ (same, samePath, references, referrers, validDerivers, outputs) <- (,,,,,)+ <$> queryPathInfo pth+ <*> queryPathFromHashPart def (System.Nix.StorePath.storePathHash pth)+ <*> queryReferences validPathEntity+ <*> queryReferrers pth+ <*> queryValidDerivers pth+ <*> queryDerivationOutputs validPathEntity++ Control.Monad.unless (same == Just (Database.Esqueleto.Experimental.entityVal validPathEntity))+ $ error "queryPathInfo failed to roundtrip"+ Control.Monad.unless (samePath == Just pth)+ $ error "queryPathFromHashPart failed to roundtrip"++ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "References: "+ print references+ putStrLn $ "Referrers: "+ print referrers+ putStrLn $ "Valid derivers: "+ print validDerivers+ putStrLn $ "Derivation outputs: "+ print outputs++ pure ()+```
+ apps/Bench.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified System.Nix.Store.DB.Run++main :: IO ()+main = System.Nix.Store.DB.Run.bench
+ hnix-store-db.cabal view
@@ -0,0 +1,126 @@+cabal-version: 2.2+name: hnix-store-db+version: 0.1.0.0+synopsis: Nix store database support+description: Implementation of the Nix store database+homepage: https://github.com/haskell-nix/hnix-store+license: Apache-2.0+license-file: LICENSE+author: Sorki+maintainer: srk@48.io+copyright: 2023 Sorki+category: Nix+build-type: Simple+extra-doc-files:+ CHANGELOG.md+extra-source-files:+ README.md+ , README.lhs++flag build-bench+ default:+ False+ description:+ Build db-bench executable++flag build-readme+ default:+ False+ description:+ Build README.lhs example++common commons+ ghc-options: -Wall -Wunused-packages+ default-extensions:+ OverloadedStrings+ , DataKinds+ , DeriveGeneric+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , DeriveLift+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , RecordWildCards+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , TypeSynonymInstances+ , InstanceSigs+ , MultiParamTypeClasses+ , TupleSections+ , LambdaCase+ , BangPatterns+ , ViewPatterns+ default-language: Haskell2010++library+ import: commons+ hs-source-dirs: src+ exposed-modules:+ System.Nix.Store.DB+ , System.Nix.Store.DB.Query+ , System.Nix.Store.DB.Instances+ , System.Nix.Store.DB.Run+ , System.Nix.Store.DB.Schema+ , System.Nix.Store.DB.Util++ build-depends:+ base >=4.10 && <5+ , hnix-store-core >= 0.8+ , attoparsec+ , bytestring+ , bytestring+ , data-default-class+ , text+ , time+ , esqueleto >= 3.5.10 && < 3.6+ , persistent >= 2.14.5 && < 2.15+ , persistent-sqlite >= 2.13.1 && < 2.14+ , template-haskell+ , monad-logger+ , microlens+ , fast-logger+ , transformers+ , unliftio-core++executable db-readme+ if !flag(build-readme)+ buildable: False+ build-depends:+ base >=4.12 && <5+ , data-default-class+ , esqueleto+ , hnix-store-core+ , hnix-store-db+ build-tool-depends:+ markdown-unlit:markdown-unlit+ default-language: Haskell2010+ main-is: README.lhs+ ghc-options: -pgmL markdown-unlit -Wall++executable db-bench+ if !flag(build-bench)+ buildable: False+ build-depends:+ base >=4.12 && <5+ , hnix-store-db+ default-language: Haskell2010+ hs-source-dirs: apps+ main-is: Bench.hs+ ghc-options: -Wall++test-suite db+ import: commons+ type: exitcode-stdio-1.0+ main-is: Smoke.hs+ hs-source-dirs: tests+ build-depends:+ base+ , hnix-store-db
+ src/System/Nix/Store/DB.hs view
@@ -0,0 +1,9 @@+module System.Nix.Store.DB (+ module System.Nix.Store.DB.Query+ , module System.Nix.Store.DB.Run+ , module System.Nix.Store.DB.Schema+ ) where++import System.Nix.Store.DB.Query+import System.Nix.Store.DB.Run+import System.Nix.Store.DB.Schema
+ src/System/Nix/Store/DB/Instances.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module System.Nix.Store.DB.Instances where++import Database.Persist (PersistField(..), PersistValue(..), SqlType(..))+import Database.Persist.Sql (PersistFieldSql(..))++import Data.Time (UTCTime)+import Data.Default.Class (Default(def))++import System.Nix.ContentAddress (ContentAddress)+import System.Nix.StorePath (StorePath)+import System.Nix.StorePath.Metadata (StorePathTrust(..))++import qualified Data.Attoparsec.Text+import qualified Data.Bifunctor+import qualified Data.Text+import qualified Data.Time.Clock.POSIX++import qualified System.Nix.ContentAddress+import qualified System.Nix.StorePath++instance PersistField StorePath where+ toPersistValue = PersistText . System.Nix.StorePath.storePathToText def+ fromPersistValue (PersistText t) = either+ (Left . Data.Text.pack)+ Right+ $ Data.Attoparsec.Text.parseOnly+ (System.Nix.StorePath.pathParser def)+ t+ fromPersistValue wrongValue = Left+ $ "Received "+ <> (Data.Text.pack $ show wrongValue)+ <> " when a value of type PersistText was expected."++instance PersistFieldSql StorePath where+ sqlType _ = SqlString++instance PersistField StorePathTrust where+ toPersistValue BuiltLocally = PersistInt64 1+ toPersistValue BuiltElsewhere = PersistNull++ fromPersistValue (PersistInt64 1) = pure BuiltLocally+ fromPersistValue PersistNull = pure BuiltElsewhere+ fromPersistValue wrongValue = Left+ $ "Received "+ <> (Data.Text.pack $ show wrongValue)+ <> " when a value of type PersistNull"+ <> " or (PersistInt64 1) was expected."++instance PersistFieldSql StorePathTrust where+ sqlType _ = SqlInt64++newtype NixUTCTime = NixUTCTime UTCTime+ deriving (Eq, Show, Ord)++instance PersistField NixUTCTime where+ toPersistValue (NixUTCTime u) = PersistInt64+ $ round $ Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds u+ fromPersistValue (PersistInt64 i) = pure $ NixUTCTime+ $ Data.Time.Clock.POSIX.posixSecondsToUTCTime $ fromIntegral i+ fromPersistValue wrongValue = Left+ $ "Received "+ <> (Data.Text.pack $ show wrongValue)+ <> " when a value of (PersistInt64 _) was expected."++instance PersistFieldSql NixUTCTime where+ sqlType _ = SqlInt64++instance PersistField ContentAddress where+ toPersistValue =+ PersistText+ . System.Nix.ContentAddress.buildContentAddress++ fromPersistValue (PersistText t) =+ Data.Bifunctor.first (\e -> error $ show (e, t))+ $ System.Nix.ContentAddress.parseContentAddress t+ fromPersistValue wrongValue = Left+ $ "Received "+ <> (Data.Text.pack $ show wrongValue)+ <> " when a value of type PersistText was expected."++instance PersistFieldSql ContentAddress where+ sqlType _ = SqlString
+ src/System/Nix/Store/DB/Query.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE Rank2Types #-}++module System.Nix.Store.DB.Query+ ( queryPathInfoEntity+ , queryPathInfo+ , queryReferencesEntity+ , queryReferences+ , queryReferrersEntity+ , queryReferrers+ , queryValidDerivers+ , queryDerivationOutputs+ , queryPathFromHashPart+ , queryValidPathsEntity+ , queryValidPaths+ -- * Testing+ , queryAllRefsEntity+ , queryAllRefs+ , queryAllDerivationOutputsEntity+ , queryAllDerivationOutputs+ , queryOneValidDerivationEntity+ , queryOneValidDerivation+ , queryEverything+ ) where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Logger (MonadLogger)+import Data.Text (Text)+import Database.Esqueleto.Experimental+import System.Nix.StorePath (StoreDir, StorePath, StorePathHashPart)+import System.Nix.Store.DB.Schema++import qualified Data.ByteString.Char8+import qualified Data.Maybe+import qualified Data.Text+import qualified System.Nix.StorePath+import qualified System.Nix.StorePath.Metadata++-- * Queries++-- | Query @Entity ValidPath@ for @StorePath@ if it exists.+queryPathInfoEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => StorePath+ -> SqlReadT m (Maybe (Entity ValidPath))+queryPathInfoEntity path = do+ res <- select $ do+ validPaths <- from $ table @ValidPath+ where_ (validPaths ^. ValidPathPath ==. val path)+ pure validPaths+ pure $ Data.Maybe.listToMaybe res++-- | Query @ValidPath@ for @StorePath@ if it exists.+queryPathInfo+ :: ( MonadIO m+ , MonadLogger m+ )+ => StorePath+ -> SqlReadT m (Maybe ValidPath)+queryPathInfo sp =+ -- this is expanded from >>= pure $ (fmap . fmap) entityVal+ -- to make older GHCs (like 9.0.2) happy+ queryPathInfoEntity sp >>= \case+ Nothing -> pure Nothing+ Just evp -> pure $ Just (entityVal evp)++-- | Query references as a list of @Entity Ref@s for @ValidPath@+-- using id of @Entity ValidPath@+queryReferencesEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => Entity ValidPath+ -> SqlReadT m [Entity Ref]+queryReferencesEntity referrer =+ select $ do+ (refs :& _validPaths) <-+ from $ table @Ref+ `innerJoin` table @ValidPath+ `on` (\(refs :& validPaths) ->+ refs ^. RefReference ==. validPaths ^. ValidPathId)+ where_ (refs ^. RefReferrer ==. val (entityKey referrer))+ pure refs++-- | Query references as a list of @Ref@s for @ValidPath@+-- by id of @Entity ValidPath@+queryReferences+ :: ( MonadIO m+ , MonadLogger m+ )+ => Entity ValidPath+ -> SqlReadT m [Ref]+queryReferences evp = do+ queryReferencesEntity evp >>= pure . fmap entityVal++-- | Query referrers as a list of @Entity Ref@s for @StorePath@+queryReferrersEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => StorePath+ -> SqlReadT m [Entity Ref]+queryReferrersEntity path = do+ select $ do+ (refs :& _validPaths) <-+ from $ table @Ref+ `innerJoin` table @ValidPath+ `on` (\(refs :& validPaths) ->+ (refs ^. RefReference ==. validPaths ^. ValidPathId))+ where_+ (+ refs ^. RefReference+ `in_`+ (subList_select $ do+ validPaths <- from $ table @ValidPath+ where_ (validPaths ^. ValidPathPath ==. val path)+ pure $ validPaths ^. ValidPathId+ )+ )+ pure refs++-- | Query referrers as a list of @Ref@s for @StorePath@+queryReferrers+ :: ( MonadIO m+ , MonadLogger m+ )+ => StorePath+ -> SqlReadT m [Ref]+queryReferrers sp =+ queryReferrersEntity sp+ >>= pure . (fmap entityVal)++-- | Query valid derivers as a list of @(Text, StorePath)@s+-- for some @StorePath@+queryValidDerivers+ :: ( MonadIO m+ , MonadLogger m+ )+ => StorePath+ -> SqlReadT m [(Text, StorePath)]+queryValidDerivers path = do+ res <- select $ do+ (drvOuts :& _validPaths) <-+ from $ table @DerivationOutput+ `innerJoin` table @ValidPath+ `on` (\(drvOuts :& validPaths) ->+ (drvOuts ^. DerivationOutputDrv ==. validPaths ^. ValidPathId))+ where_ (drvOuts ^. DerivationOutputPath ==. val path)+ pure (drvOuts ^. DerivationOutputName, drvOuts ^. DerivationOutputPath)++ pure $ unValue2 <$> res++-- | Query derivation outputs as a list of @(Text, StorePath)@s+-- for some @ValidPath@ by its id+queryDerivationOutputs+ :: ( MonadIO m+ , MonadLogger m+ )+ => Entity ValidPath+ -> SqlReadT m [(Text, StorePath)]+queryDerivationOutputs drv = do+ res <- select $ do+ drvOuts <- from $ table @DerivationOutput+ where_ (drvOuts ^. DerivationOutputDrv ==. val (entityKey drv))+ pure (drvOuts ^. DerivationOutputName, drvOuts ^. DerivationOutputPath)++ pure $ unValue2 <$> res++-- | Query @StorePath@ from its hash part+queryPathFromHashPart+ :: ( MonadIO m+ , MonadLogger m+ )+ => StoreDir+ -> StorePathHashPart+ -> SqlReadT m (Maybe StorePath)+queryPathFromHashPart storeDir hp =+ let hashPart =+ ( Data.Text.pack+ . Data.ByteString.Char8.unpack+ $ System.Nix.StorePath.unStoreDir storeDir+ )+ <> "/"+ <> System.Nix.StorePath.storePathHashPartToText hp+ in do+ -- We use rawSql here+ -- as otherwise, we would have to construct a @StorePath@+ -- to match the type of ValidPath.path, but the @StorePath@+ -- always includes name, so we would have to change+ -- the type of ValidPath.path to @Either StorePathHashPart StorePath@+ -- which isn't worth for a single query+ raw <- rawSql+ "select ?? from ValidPaths where path >= ? limit 1"+ [PersistText hashPart]+ pure+ $ Data.Maybe.listToMaybe+ $ validPathPath . entityVal+ <$> raw++-- | Query all valid paths as a list of @Entity ValidPath@s+queryValidPathsEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m [Entity ValidPath]+queryValidPathsEntity =+ select $ from $ table @ValidPath++-- | Query all valid paths as a list of @ValidPath@s+queryValidPaths+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m [ValidPath]+queryValidPaths =+ queryValidPathsEntity+ >>= pure . fmap entityVal++-- * For testing++-- | Query all references as a list of @Entity Ref@s+queryAllRefsEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m [Entity Ref]+queryAllRefsEntity =+ select $ from $ table @Ref++-- | Query all references as a list of @Ref@s+queryAllRefs+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m [Ref]+queryAllRefs =+ queryAllRefsEntity+ >>= pure . fmap entityVal++-- | Query all derivation outputs as a list of @Entity DerivationOutput@s+queryAllDerivationOutputsEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m [Entity DerivationOutput]+queryAllDerivationOutputsEntity =+ select $ from $ table @DerivationOutput++-- | Query all derivation outputs as a list of @DerivationOutput@s+queryAllDerivationOutputs+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m [DerivationOutput]+queryAllDerivationOutputs =+ queryAllDerivationOutputsEntity+ >>= pure . fmap entityVal++-- | Query one random derivation as an @Entity ValidPath@+queryOneValidDerivationEntity+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m (Maybe (Entity ValidPath))+queryOneValidDerivationEntity = do+ res <- select $ do+ validPath <- from $ table @ValidPath -- \validPath -> do+ where_+ (+ validPath ^. ValidPathUltimate+ ==. (val $ Just System.Nix.StorePath.Metadata.BuiltLocally)+ )+ offset 100+ limit 1+ pure validPath++ pure $ Data.Maybe.listToMaybe res++-- | Query one random derivation as a @ValidPath@+queryOneValidDerivation+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m (Maybe ValidPath)+queryOneValidDerivation =+ queryOneValidDerivationEntity+ >>= pure . fmap entityVal++-- | Query everything+queryEverything+ :: ( MonadIO m+ , MonadLogger m+ )+ => SqlReadT m+ ( [Entity ValidPath]+ , [Entity Ref]+ , [Entity DerivationOutput]+ )+queryEverything = (,,)+ <$> queryValidPathsEntity+ <*> queryAllRefsEntity+ <*> queryAllDerivationOutputsEntity++-- * Utility++unValue2 :: (Value a, Value b) -> (a, b)+unValue2 (a, b) = (unValue a, unValue b)
+ src/System/Nix/Store/DB/Run.hs view
@@ -0,0 +1,220 @@+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 =+ Database.Persist.Sqlite.mkSqliteConnectionInfo+ "file:/nix/var/nix/db/db.sqlite?immutable=1"++-- | Run with @systemConnectionInfo@+runSystemSqlite+ :: SqlPersistM a+ -> IO a+runSystemSqlite =+ Database.Persist.Sqlite.runSqliteInfo+ systemConnectionInfo++-- | @SqliteConnectionInfo@ for running in memory+memoryConnectionInfo :: SqliteConnectionInfo+memoryConnectionInfo =+ Database.Persist.Sqlite.mkSqliteConnectionInfo+ ":memory:"++-- | Run with @memoryConnectionInfo@+runInMemory+ :: SqlPersistM a+ -> IO a+runInMemory =+ Database.Persist.Sqlite.runSqliteInfo+ memoryConnectionInfo++-- | Run with custom connection string+runCustom+ :: Text+ -> SqlPersistM a+ -> IO a+runCustom =+ Database.Persist.Sqlite.runSqlite++-- | Run with logging+runWithLogging+ :: MonadUnliftIO m+ => SqliteConnectionInfo+ -> ReaderT SqlBackend (LoggingT m) a+ -> m a+runWithLogging connInfo act = do+ flip Control.Monad.Logger.runLoggingT+ (\_ _ _ s ->+ Data.ByteString.Char8.putStrLn+ $ System.Log.FastLogger.fromLogStr s+ )+ $ Database.Persist.Sqlite.withSqliteConnInfo+ connInfo+ $ Database.Persist.Sql.runSqlConn act++-- | Test that we can create in-memory database+-- and run a dummy query, used by smoke test+memTest :: IO ()+memTest = runInMemory $ do+ doMigrateAll+ _ <- queryEverything+ pure ()++allMigrations :: Migration+allMigrations = do+ let addSafeMigration+ -- the False means it is not unsafe to run (idempotent)+ = Database.Persist.Sql.addMigration False++ System.Nix.Store.DB.Schema.migrateAll++ addSafeMigration+ "CREATE INDEX IF NOT EXISTS IndexReferrer ON Refs(referrer)"+ addSafeMigration+ "CREATE INDEX IF NOT EXISTS IndexReference ON Refs(reference)"+ addSafeMigration+ "CREATE INDEX IF NOT EXISTS IndexDerivationOutputs ON DerivationOutputs(path)"+ addSafeMigration+ "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 =+ Database.Persist.Sql.runMigration allMigrations++-- | Perform migration on real database+testMigrateAll :: IO ()+testMigrateAll = do+ let connInfo =+ Database.Persist.Sqlite.mkSqliteConnectionInfo+ "/tmp/db.sqlite"+ runWithLogging+ -- We need to disable foreign key checking otherwise+ -- the migration would fail+ (System.Nix.Store.DB.Util.disableFK connInfo)+ -- this actually returns what queries were performed+ -- during migration so we just discard it+ $ Control.Monad.void+ -- use runMigrationSilent as we have logging enabled+ $ Database.Persist.Sql.runMigrationSilent allMigrations++-- | Elaborate test, testing most available query+-- functionality. Same as README.md (db-readme executable)+test :: IO ()+test = do+ runSystemSqlite $ do+ (paths, refs, drvOuts) <- queryEverything++ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "Stats: "+ let stat name v = putStrLn $ "- " ++ name ++ ": " ++ show (length v)+ stat "ValidPath(s)" paths+ stat "Ref(s)" refs+ stat "DerivationOutput(s)" drvOuts++ maybeValidPath <- queryOneValidDerivationEntity+ case maybeValidPath of+ Nothing -> pure ()+ Just validPathEntity -> do+ let pth =+ System.Nix.Store.DB.Schema.validPathPath+ $ Database.Esqueleto.Experimental.entityVal validPathEntity++ (same, samePath, references, referrers, validDerivers, outputs) <- (,,,,,)+ <$> queryPathInfo pth+ <*> queryPathFromHashPart def (System.Nix.StorePath.storePathHash pth)+ <*> queryReferences validPathEntity+ <*> queryReferrers pth+ <*> queryValidDerivers pth+ <*> queryDerivationOutputs validPathEntity++ Control.Monad.unless (same == Just (Database.Esqueleto.Experimental.entityVal validPathEntity))+ $ error "queryPathInfo failed to roundtrip"+ Control.Monad.unless (samePath == Just pth)+ $ error "queryPathFromHashPart failed to roundtrip"++ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "References: "+ print references+ putStrLn $ "Referrers: "+ print referrers+ putStrLn $ "Valid derivers: "+ print validDerivers+ putStrLn $ "Derivation outputs: "+ print outputs++ pure ()++-- | Query everything and for each valid path+-- perform detailed queries+bench :: IO ()+bench = do+ runSystemSqlite $ do+ (paths, refs, drvOuts) <- queryEverything+ Control.Monad.IO.Class.liftIO $ do+ putStrLn $ "Stats: "+ let stat name v = putStrLn $ "- " ++ name ++ ": " ++ show (length v)+ stat "ValidPath(s)" paths+ stat "Ref(s)" refs+ stat "DerivationOutput(s)" drvOuts++ Control.Monad.forM_ paths proc+ where+ proc validPathEntity = do+ let pth =+ System.Nix.Store.DB.Schema.validPathPath+ $ Database.Esqueleto.Experimental.entityVal validPathEntity++ (same, samePath, _references, _referrers, _validDerivers, _outputs) <- (,,,,,)+ <$> queryPathInfo pth+ <*> queryPathFromHashPart def (System.Nix.StorePath.storePathHash pth)+ <*> queryReferences validPathEntity+ <*> queryReferrers pth+ <*> queryValidDerivers pth+ <*> queryDerivationOutputs validPathEntity++ Control.Monad.unless (same == Just (Database.Esqueleto.Experimental.entityVal validPathEntity))+ $ error "queryPathInfo failed to roundtrip"+ Control.Monad.unless (samePath == Just pth)+ $ error "queryPathFromHashPart failed to roundtrip"
+ src/System/Nix/Store/DB/Schema.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module System.Nix.Store.DB.Schema where++import Data.Text (Text)+import Data.Word (Word64)++import Database.Persist.TH ( mkMigrate+ , mkPersist+ , share+ , sqlSettings+ )++import System.Nix.ContentAddress (ContentAddress)+import System.Nix.StorePath (StorePath)+import System.Nix.StorePath.Metadata (StorePathTrust(..))++import System.Nix.Store.DB.Instances (NixUTCTime)+import System.Nix.Store.DB.Util (persistLikeNix)++-- shcema version 10+-- cat /nix/var/nix/db/schema+-- 10++share [ mkPersist sqlSettings+ , mkMigrate "migrateAll" ] [persistLikeNix|+ ValidPath+ path StorePath+ hash Text+ regTime NixUTCTime sql=registrationTime+ deriver StorePath Maybe+ narBytes Word64 sql=narSize+ ultimate StorePathTrust Maybe+ -- ^ null is BuiltElsewhere, 1 is BuiltLocally+ sigs Text Maybe+ -- ^ space separated+ ca ContentAddress Maybe+ -- ^ if not null, an assertion that the path is content-addressed+ deriving Eq Show Ord++ Ref+ referrer ValidPathId+ reference ValidPathId++ Primary referrer reference++ Foreign ValidPath OnDeleteCascade fk_referrer referrer+ Foreign ValidPath OnDeleteRestrict fk_reference reference+ deriving Eq Show Ord++ DerivationOutput+ drv ValidPathId+ name Text sql=id+ -- ^ symbolic output id, usually "out"+ path StorePath++ Primary drv name++ Foreign ValidPath OnDeleteCascade fk_drv drv+ deriving Eq Show Ord+|]
+ src/System/Nix/Store/DB/Util.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Nix.Store.DB.Util+ ( persistLikeNix+ , setWAL+ , enableWAL+ , disableWAL+ , setFK+ , enableFK+ , disableFK+ ) where++import Language.Haskell.TH.Quote+import Database.Persist.Quasi+import Database.Persist.Sqlite (SqliteConnectionInfo)+import Database.Persist.TH (persistWith)++import qualified Database.Persist.Sqlite+import qualified Lens.Micro++-- | Coerce table names to their plural names+-- i.e. ValidPath -> ValidPaths+persistLikeNix :: QuasiQuoter+persistLikeNix = persistWith $+ setPsToDBName+ (coerce . (getPsToDBName upperCaseSettings))+ upperCaseSettings+ where+ coerce x | x `elem` ["ValidPath", "Ref", "DerivationOutput"] = plural x+ coerce x = x++ plural x = x <> "s"++-- * WAL and FK++-- | Configure WAL (write ahead log)+setWAL+ :: Bool+ -> SqliteConnectionInfo+ -> SqliteConnectionInfo+setWAL v = Lens.Micro.over Database.Persist.Sqlite.walEnabled (const v)++-- | Enable WAL (write ahead log)+enableWAL+ :: SqliteConnectionInfo+ -> SqliteConnectionInfo+enableWAL = setWAL True++-- | Disable WAL (write ahead log)+disableWAL+ :: SqliteConnectionInfo+ -> SqliteConnectionInfo+disableWAL = setWAL False++-- | Configure FK (foreign key constraints)+setFK+ :: Bool+ -> SqliteConnectionInfo+ -> SqliteConnectionInfo+setFK v = Lens.Micro.over Database.Persist.Sqlite.walEnabled (const v)++-- | Enable foreign key constraint checking+enableFK+ :: SqliteConnectionInfo+ -> SqliteConnectionInfo+enableFK = setFK True++-- | Disable foreign key constraint checking+disableFK+ :: SqliteConnectionInfo+ -> SqliteConnectionInfo+disableFK = setFK False
+ tests/Smoke.hs view
@@ -0,0 +1,11 @@+module Main where++import qualified System.Nix.Store.DB.Run++-- This only tests that database can be created+-- in-memory using migrateAll and that queryEverything+-- runs (with no data)+--+-- For better test, we would need a populated nix-store+main :: IO ()+main = System.Nix.Store.DB.Run.memTest