haskell-nix/hnix-store
1
1
Fork 0
mirror of https://github.com/haskell-nix/hnix-store.git synced 2024-12-01 07:10:26 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #70 from sorki/wip/db+pr64

Browse Source 
Database
This commit is contained in:
Richard Marko 2023-11-19 13:51:50 +01:00 committed by GitHub
commit 9118c300f7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 1206 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
cabal.project
View File

@ -1,10 +1,14 @@
packages: packages:
./hnix-store-core/hnix-store-core.cabal ./hnix-store-core/hnix-store-core.cabal
./hnix-store-db/hnix-store-db.cabal
./hnix-store-remote/hnix-store-remote.cabal ./hnix-store-remote/hnix-store-remote.cabal
-- till https://github.com/obsidiansystems/dependent-sum/pull/80 -- till https://github.com/obsidiansystems/dependent-sum/pull/80
allow-newer: allow-newer:
dependent-sum:some dependent-sum:some
package hnix-store-db
flags: +build-readme +build-bench
package hnix-store-remote package hnix-store-remote
flags: +build-readme +io-testsuite flags: +build-readme +io-testsuite

3
cabal.project.local.ci
View File

@ -3,5 +3,8 @@ tests: True
package hnix-store-core package hnix-store-core
ghc-options: -Wunused-packages -Wall -Werror ghc-options: -Wunused-packages -Wall -Werror
package hnix-store-db
ghc-options: -Wunused-packages -Wall -Werror
package hnix-store-remote package hnix-store-remote
ghc-options: -Wunused-packages -Wall -Werror ghc-options: -Wunused-packages -Wall -Werror

1
default.nix
View File

@ -21,6 +21,7 @@ let
in { in {
inherit (haskellPackages) inherit (haskellPackages)
hnix-store-core hnix-store-core
hnix-store-db
hnix-store-remote; hnix-store-remote;
haskellPackages = lib.dontRecurseIntoAttrs haskellPackages; haskellPackages = lib.dontRecurseIntoAttrs haskellPackages;
pkgs = lib.dontRecurseIntoAttrs pkgs; pkgs = lib.dontRecurseIntoAttrs pkgs;

3
hnix-store-db/CHANGELOG.md Normal file
View File

@ -0,0 +1,3 @@
# Unreleased 202y-mm-dd
* First version.

201
hnix-store-db/LICENSE Normal file
View File

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

1
hnix-store-db/README.lhs Symbolic link
View File

@ -0,0 +1 @@
README.md

82
hnix-store-db/README.md Normal file
View File

@ -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 ()
```

6
hnix-store-db/apps/Bench.hs Normal file
View File

@ -0,0 +1,6 @@
module Main where
import qualified System.Nix.Store.DB.Run
main :: IO ()
main = System.Nix.Store.DB.Run.bench

125
hnix-store-db/hnix-store-db.cabal Normal file
View File

@ -0,0 +1,125 @@
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: Richard Marko
maintainer: srk@48.io
copyright: 2023 Richard Marko
category: Nix
build-type: Simple
extra-source-files:
CHANGELOG.md
, 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
, attoparsec
, bytestring
, bytestring
, data-default-class
, text
, time
, hnix-store-core
, 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

9
hnix-store-db/src/System/Nix/Store/DB.hs Normal file
View File

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

87
hnix-store-db/src/System/Nix/Store/DB/Instances.hs Normal file
View File

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

308
hnix-store-db/src/System/Nix/Store/DB/Query.hs Normal file
View File

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

220
hnix-store-db/src/System/Nix/Store/DB/Run.hs Normal file
View File

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

63
hnix-store-db/src/System/Nix/Store/DB/Schema.hs Normal file
View File

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

71
hnix-store-db/src/System/Nix/Store/DB/Util.hs Normal file
View File

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

11
hnix-store-db/tests/Smoke.hs Normal file
View File

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

6
overlay.nix
View File

@ -50,6 +50,12 @@ in
[ [
haskellLib.compose.buildFromSdist haskellLib.compose.buildFromSdist
]; ];
hnix-store-db =
lib.pipe
(hself.callCabal2nix "hnix-store-db" ./hnix-store-db {})
[
haskellLib.compose.buildFromSdist
];
hnix-store-remote = hnix-store-remote =
lib.pipe lib.pipe
# enable -fio-testsuite for Linux systems as # enable -fio-testsuite for Linux systems as

6
shell.nix
View File

@ -3,7 +3,11 @@ let
inherit (import ./. attrs) pkgs haskellPackages; inherit (import ./. attrs) pkgs haskellPackages;
hlib = pkgs.haskell.lib; hlib = pkgs.haskell.lib;
packages = [ "hnix-store-core" "hnix-store-remote" ]; packages = [
"hnix-store-core"
"hnix-store-db"
"hnix-store-remote"
];
extract-external-inputs = p: extract-external-inputs = p:
builtins.filter builtins.filter
(dep: !(builtins.elem dep packages)) (dep: !(builtins.elem dep packages))