├── .gitignore
├── LICENSE
├── README.md
├── default.nix
├── project.nix
├── shell.nix
├── src
    ├── Data
    │   └── KVMap.hs
    └── Nix
    │   ├── Bin.hs
    │   ├── Cache
    │       ├── API.hs
    │       ├── Client.hs
    │       ├── Client
    │       │   ├── Main.hs
    │       │   └── Misc.hs
    │       ├── Common.hs
    │       ├── Logger.hs
    │       └── Types.hs
    │   ├── Derivation.hs
    │   ├── Derivation
    │       ├── Parser.hs
    │       └── Types.hs
    │   ├── FileHash.hs
    │   ├── Nar.hs
    │   ├── Nar
    │       ├── Serialization.hs
    │       ├── Subprocess.hs
    │       └── Types.hs
    │   ├── NarExport.hs
    │   ├── NarInfo.hs
    │   ├── ReferenceCache.hs
    │   └── StorePath.hs
└── tests
    ├── Data
        └── KVMap
        │   └── Tests.hs
    ├── Nix
        ├── Cache
        │   └── Types
        │   │   └── Tests.hs
        ├── Derivation
        │   └── Tests.hs
        └── NarExport
        │   └── Tests.hs
    └── Unit.hs


/.gitignore:
--------------------------------------------------------------------------------
1 | .nix-shell-pids
2 | dist
3 | *.hi
4 | .bin
5 | .ghci
6 | nix-binary-cache.cabal
7 | nix-binary-cache.cabal
8 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | The MIT License (MIT)
 2 | 
 3 | Copyright (c) 2016 Allen Nelson
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in
13 | all copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21 | THE SOFTWARE.


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # `nix-binary-cache`
 2 | 
 3 | This is a Haskell implementation of a nix binary cache server (a.k.a.
 4 | nix repo) and a client which can perform uploads and fetches against
 5 | this server.
 6 | 
 7 | The server is modeled after the python implementation
 8 | [servenix](https://github.com/adnelson/servenix), but is intended to
 9 | support more features and have better performance. See that project's
10 | readme for more information on the server itself until this project
11 | becomes more mature.
12 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | {
 2 |   pkgs ? import <nixpkgs> {config.allowUnfree = true;},
 3 |   compiler ? "ghc802"
 4 | }:
 5 | 
 6 | let
 7 |   haskellPackages = pkgs.haskell.packages."${compiler}";
 8 | in
 9 | 
10 | import ./project.nix {
11 |   inherit pkgs haskellPackages;
12 | }
13 | 


--------------------------------------------------------------------------------
/project.nix:
--------------------------------------------------------------------------------
  1 | { pkgs, haskellPackages, }:
  2 | 
  3 | let
  4 |   pname = "nix-binary-cache";
  5 | 
  6 |   binaryLibrary = if builtins.getEnv "USE_CEREAL" != ""
  7 |                   then "cereal" else "binary";
  8 | 
  9 |   version = "0.0.1";
 10 |   # Haskell packages the library depends on (in addition to above). We
 11 |   # use names here because for some reason some of these are null in
 12 |   # the haskell package set, but still work as dependencies...
 13 |   dependencies = [
 14 |     "aeson"
 15 |     "attoparsec"
 16 |     "base"
 17 |     binaryLibrary
 18 |     "bytestring"
 19 |     "bytestring-conversion"
 20 |     "base64-bytestring"
 21 |     "classy-prelude"
 22 |     "directory"
 23 |     "filepath"
 24 |     "http-client"
 25 |     "http-client-openssl"
 26 |     "http-client-tls"
 27 |     "http-media"
 28 |     "http-types"
 29 |     "lifted-async"
 30 |     "lifted-base"
 31 |     "lzma"
 32 |     "lucid"
 33 |     "mtl"
 34 |     "parsec"
 35 |     "pcre-heavy"
 36 |     "process"
 37 |     "process-extras"
 38 |     "servant-client"
 39 |     "servant-lucid"
 40 |     "servant-server"
 41 |     "servant"
 42 |     "sqlite-simple"
 43 |     "text"
 44 |     "transformers"
 45 |     "unordered-containers"
 46 |     "vector"
 47 |     "wai"
 48 |     "wai-extra"
 49 |     "warp"
 50 |     "zlib"
 51 |   ];
 52 | 
 53 |   # Haskell packages the tests depend on (in addition to above).
 54 |   testDependencies = [
 55 |     "QuickCheck"
 56 |     "hspec"
 57 |     "microtimer"
 58 |     "random-strings"
 59 |   ];
 60 | 
 61 |   # Names of extensions that the library uses.
 62 |   extensions = [
 63 |     "ConstraintKinds"
 64 |     "CPP"
 65 |     "DataKinds"
 66 |     "DeriveGeneric"
 67 |     "FlexibleContexts"
 68 |     "FlexibleInstances"
 69 |     "GADTs"
 70 |     "GeneralizedNewtypeDeriving"
 71 |     "LambdaCase"
 72 |     "MultiParamTypeClasses"
 73 |     "NoImplicitPrelude"
 74 |     "OverloadedStrings"
 75 |     "QuasiQuotes"
 76 |     "RecordWildCards"
 77 |     "ScopedTypeVariables"
 78 |     "TypeFamilies"
 79 |     "TypeOperators"
 80 |     "TypeSynonymInstances"
 81 |     "ViewPatterns"
 82 |   ];
 83 | 
 84 |   # Derivations needed to use in the nix shell.
 85 |   shellRequires = with pkgs; [
 86 |     curl
 87 |     nix.out
 88 |     less
 89 |     nmap
 90 |     silver-searcher
 91 |     which
 92 |   ];
 93 | 
 94 |   # Given a list of strings, look all of them up in the haskell package set.
 95 |   toHaskellPkgs = map (pname: haskellPackages."${pname}");
 96 | 
 97 |   inherit (builtins) compareVersions;
 98 |   inherit (pkgs.lib) filter concatStringsSep isDerivation optional;
 99 |   joinLines = builtins.concatStringsSep "\n";
100 |   joinCommas = builtins.concatStringsSep ", ";
101 |   joinSpaces = builtins.concatStringsSep " ";
102 | 
103 |   # Options for ghc when both testing and building the library.
104 |   ghc-options = [
105 |     # Warn on everything, including tabs.
106 |     "-Wall" "-fwarn-tabs"
107 |     # Don't warn on unused do-binding.
108 |     "-fno-warn-unused-do-bind"
109 |     # Don't warn on name shadowing. This is why lexical scoping exists...
110 |     "-fno-warn-name-shadowing"
111 |     # Enable threading.
112 |     "-threaded" "-rtsopts" "-with-rtsopts=-N"
113 |   ];
114 | 
115 |   # Options for ghc when just building the library.
116 |   ghc-build-options = ghc-options ++ [
117 |     # Enable optimization
118 |     "-O3"
119 |     # Turn warnings into errors.
120 |     # "-Werror"
121 |   ];
122 | 
123 |   # Options for ghc when just testing.
124 |   ghc-test-options = ghc-options ++ [
125 |     "-fno-warn-orphans"
126 |   ];
127 | 
128 |   # Inspect the servant derivation to see if it's an old version; if
129 |   # so define a cpp flag.
130 |   cpp-options = optional
131 |     (compareVersions haskellPackages.servant.version "0.7" < 0)
132 |     "-DOLD_SERVANT" ++
133 |     optional (binaryLibrary == "cereal") "-DUSE_CEREAL";
134 | 
135 |   # .ghci file text.
136 |   dotGhci = pkgs.writeText "${pname}.ghci" (joinLines (
137 |     map (ext: ":set -X${ext}") extensions ++
138 |     [
139 |       ":set prompt \"λ> \""
140 |       "import Data.Text (Text)"
141 |       "import qualified Servant"
142 |       "import qualified Data.Text as T"
143 |       "import qualified Data.Text.Encoding as T"
144 |       "import qualified Data.HashMap.Strict as H"
145 |       "import ClassyPrelude"
146 |       "import Control.Concurrent.Async.Lifted"
147 |       ""
148 |     ]
149 |   ));
150 | 
151 |   # Cabal file text.
152 |   cabalFile = pkgs.writeText "${pname}.cabal" ''
153 |     -- This cabal file is generated by a nix expression (see project.nix).
154 |     -- It is not meant to be modified by hand.
155 |     name:                ${pname}
156 |     version:             ${version}
157 |     license:             MIT
158 |     license-file:        LICENSE
159 |     author:              Allen Nelson
160 |     maintainer:          ithinkican@gmail.com
161 |     build-type:          Simple
162 |     cabal-version:       >=1.10
163 |     data-files:            sql/tables.sql
164 | 
165 |     -- Define the executable
166 |     executable nix-client
167 |       main-is:             Nix/Cache/Client/Main.hs
168 |       build-depends:       ${joinCommas dependencies}
169 |       hs-source-dirs:      src
170 |       default-language:    Haskell2010
171 |       default-extensions:  ${joinCommas extensions}
172 |       ghc-options:         -O3 ${joinSpaces ghc-build-options}
173 |       cpp-options:         ${joinSpaces cpp-options}
174 | 
175 |     ${if false then "" else ''
176 |     executable ref-cache
177 |       main-is:             Nix/ReferenceCache.hs
178 |       build-depends:       ${joinCommas dependencies}
179 |       hs-source-dirs:      src
180 |       default-language:    Haskell2010
181 |       default-extensions:  ${joinCommas extensions}
182 |       ghc-options:         -O3 ${joinSpaces ghc-build-options}
183 |       cpp-options:         ${joinSpaces cpp-options}
184 |     ''}
185 | 
186 |     ${if true then "" else ''
187 |     executable nix-server
188 |       main-is:             Server.hs
189 |       build-depends:       ${joinCommas dependencies}
190 |       hs-source-dirs:      src
191 |       default-language:    Haskell2010
192 |       default-extensions:  ${joinCommas extensions}
193 |       ghc-options:         -O3 ${joinSpaces ghc-build-options}
194 |     ''}
195 | 
196 |     -- Define a unit test suite
197 |     test-suite unit-tests
198 |       type:                exitcode-stdio-1.0
199 |       hs-source-dirs:      src, tests
200 |       main-is:             Unit.hs
201 |       build-depends:       ${joinCommas (dependencies ++ testDependencies)}
202 |       ghc-options:         ${joinSpaces ghc-test-options}
203 |       cpp-options:         -DUNIT_TESTS ${joinSpaces cpp-options}
204 |       default-language:    Haskell2010
205 |       default-extensions:  ${joinCommas extensions}
206 |   '';
207 | in
208 | 
209 | haskellPackages.mkDerivation rec {
210 |   inherit pname version;
211 |   src = let
212 |     inherit (builtins) filterSource all match;
213 |     # It'd be nice to make this a whitelist, but filterSource is kind
214 |     # of terrible.
215 |     blacklist = map (r: "^${r}$") [
216 |       "${pname}\\.cabal" "init_db\\.sh" ".*\\.nix" "dist"
217 |       "\\.git" "#.*" "\\.#.*" ".*~" "\\.ghci" "\\.gitignore"
218 |     ];
219 |     check = path: _:
220 |       all (regex: match regex (baseNameOf path) == null) blacklist;
221 |   in filterSource check ./.;
222 |   isExecutable = true;
223 |   buildTools = [haskellPackages.cabal-install];
224 |   testHaskellDepends = toHaskellPkgs testDependencies;
225 |   testDepends = shellRequires;
226 |   checkPhase = ''
227 |     export HOME=$TMPDIR USER=$(whoami)
228 |     dist/build/unit-tests/unit-tests
229 |   '';
230 |   libraryHaskellDepends = toHaskellPkgs dependencies;
231 |   executableHaskellDepends = toHaskellPkgs dependencies;
232 |   preConfigure = ''
233 |     cp -f ${cabalFile} ${pname}.cabal
234 |   '';
235 |   shellHook = ''
236 |     export CURL_CA_BUNDLE=${pkgs.cacert}/etc/ssl/certs/ca-bundle.crt
237 |     # Make sure we're in the project directory, and do initialization.
238 |     if [[ -e project.nix ]] && grep -q ${pname} project.nix; then
239 |       PROJECT_DIR=$PWD
240 |       # Alias for entering REPL for unit tests.
241 |       alias testr='(cd $PROJECT_DIR && cabal repl unit-tests)'
242 | 
243 |       # Define a function which uses ghci to run unit tests.
244 |       runtests() ( cd $PROJECT_DIR && echo ':main' | cabal repl unit-tests; )
245 | 
246 |       cp -f ${dotGhci} .ghci
247 |       eval "${preConfigure}"
248 |       cabal clean
249 |       cabal configure --enable-tests
250 |     fi
251 |   '';
252 |   description = "A web server";
253 |   license = pkgs.lib.licenses.unfree;
254 | }
255 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
1 | {
2 |   pkgs ? import <nixpkgs> {config.allowUnfree = true;},
3 |   compiler ? "ghc802"
4 | }:
5 | (import ./default.nix { inherit pkgs compiler; }).env
6 | 


--------------------------------------------------------------------------------
/src/Data/KVMap.hs:
--------------------------------------------------------------------------------
 1 | -- | Defining a `KVMap` data structure, which is a string -> string
 2 | -- mapping that is text encoded in a simple format.
 3 | module Data.KVMap where
 4 | 
 5 | import ClassyPrelude
 6 | import qualified Data.Text as T
 7 | import qualified Data.HashMap.Strict as H
 8 | import Data.Attoparsec.ByteString.Lazy (Parser)
 9 | import Data.Attoparsec.ByteString.Char8 (char, notChar, space, endOfLine,
10 |                                          many1)
11 | 
12 | -- | Some nix cache information comes in a line-separated "Key: Value"
13 | -- format. Here we represent that as a map.
14 | newtype KVMap = KVMap (HashMap Text Text)
15 |   deriving (Show, Eq, Generic)
16 | 
17 | -- | Class for things which can be represented in KVMaps.
18 | class FromKVMap t where
19 |   fromKVMap :: KVMap -> Either String t
20 | 
21 | -- | KVMaps can be parsed from text.
22 | parseKVMap :: Parser KVMap
23 | parseKVMap = do
24 |   many $ endOfLine <|> (space >> return ())
25 |   keysVals <- many $ do
26 |     key <- many1 $ notChar ':'
27 |     char ':' >> many space
28 |     val <- many1 $ notChar '\n'
29 |     many $ endOfLine <|> (space >> return ())
30 |     return (T.pack key, T.pack val)
31 |   return $ KVMap $ H.fromList keysVals
32 | 


--------------------------------------------------------------------------------
/src/Nix/Bin.hs:
--------------------------------------------------------------------------------
 1 | -- | Execute a nix command.
 2 | module Nix.Bin where
 3 | 
 4 | import ClassyPrelude
 5 | import System.Environment (setEnv, lookupEnv)
 6 | import System.Exit (ExitCode(..))
 7 | import qualified System.Process.ByteString as PB
 8 | import qualified System.Process.ByteString.Lazy as PBL
 9 | import qualified System.Process.Text as PT
10 | import System.FilePath (takeDirectory)
11 | import System.Directory (doesFileExist)
12 | import System.Process (readCreateProcess, shell)
13 | import qualified Data.ByteString.Char8 as B8
14 | import qualified Data.ByteString.Lazy.Char8 as BL8
15 | import qualified Data.Text as T
16 | 
17 | -- | Path to the directory containing nix binaries.
18 | newtype NixBinDir = NixBinDir {unpackNixBinDir::FilePath}
19 |   deriving (Show, Eq, IsString)
20 | 
21 | -- | Get the nix binary directory path, e.g. where `nix-store` lives.
22 | getNixBinDir :: IO NixBinDir
23 | getNixBinDir = lookupEnv "NIX_BIN_DIR" >>= \case
24 |   Just dir -> doesFileExist (dir </> "nix-store") >>= \case
25 |     True -> pure $ NixBinDir dir
26 |     False -> findit
27 |   Nothing -> findit
28 |   where
29 |     cmd = shell "which nix-store"
30 |     findit = do
31 |       dir <- takeDirectory <$> readCreateProcess cmd ""
32 |       setEnv "NIX_BIN_DIR" dir
33 |       pure $ NixBinDir dir
34 | 
35 | -- | Class for things which can be returned from nix commands.
36 | class NixCmdReturn t where
37 |   nixCmd :: NixBinDir -> String -> [String] -> BL8.ByteString -> IO t
38 | 
39 | -- | Run a nix command, using the `getNixBinDir` function
40 | nixCmd' :: NixCmdReturn t => String -> [String] -> BL8.ByteString -> IO t
41 | nixCmd' cmd args input = getNixBinDir >>= \d -> nixCmd d cmd args input
42 | 
43 | instance NixCmdReturn ByteString where
44 |   nixCmd (NixBinDir nixBin) cmd args input = do
45 |     let executable = (nixBin </> ("nix-" <> cmd))
46 |     PB.readProcessWithExitCode executable args (toStrict input) >>= \case
47 |       (ExitSuccess, stdout, _) -> pure stdout
48 |       (ExitFailure code, _, stderr) -> error $ unlines $ [
49 |           cmd' <> " failed with status " <> show code
50 |           , "STDERR:", B8.unpack stderr]
51 |         where cmd' = "nix-" <> cmd <> " " <> intercalate " " args
52 | 
53 | instance NixCmdReturn BL8.ByteString where
54 |   nixCmd (NixBinDir nixBin) cmd args input = do
55 |     let executable = (nixBin </> ("nix-" <> cmd))
56 |     PBL.readProcessWithExitCode executable args input >>= \case
57 |       (ExitSuccess, stdout, _) -> pure stdout
58 |       (ExitFailure code, _, stderr) -> error $ unlines $ [
59 |           cmd' <> " failed with status " <> show code
60 |           , "STDERR:", BL8.unpack stderr]
61 |         where cmd' = "nix-" <> cmd <> " " <> intercalate " " args
62 | 
63 | instance NixCmdReturn Text where
64 |   nixCmd (NixBinDir nixBin) cmd args input = do
65 |     let executable = (nixBin </> ("nix-" <> cmd))
66 |     PB.readProcessWithExitCode executable args (toStrict input) >>= \case
67 |       (ExitSuccess, stdout, _) -> pure (decodeUtf8 stdout)
68 |       (ExitFailure code, _, stderr) -> error $ unlines $ [
69 |           cmd' <> " failed with status " <> show code
70 |           , "STDERR:", B8.unpack stderr]
71 |         where cmd' = "nix-" <> cmd <> " " <> intercalate " " args
72 | 
73 | instance NixCmdReturn () where
74 |   nixCmd nixBin cmd args input =
75 |     (nixCmd nixBin cmd args input :: IO Text) >> pure ()
76 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/API.hs:
--------------------------------------------------------------------------------
 1 | module Nix.Cache.API where
 2 | 
 3 | import ClassyPrelude (Vector, FilePath, HashMap, Bool)
 4 | import Servant
 5 | import Servant.HTML.Lucid (HTML)
 6 | 
 7 | import Nix.Nar (Nar, NarExport)
 8 | import Nix.StorePath (StorePath)
 9 | import Nix.Cache.Types (GZipped, NixCacheInfo)
10 | import Nix.NarInfo (NarInfo, NarRequest, NarInfoReq)
11 | 
12 | -- | The nix cache API type.
13 | type NixCacheAPI = "nix-cache-info" :> Get '[OctetStream] NixCacheInfo
14 |               :<|> Capture "narinfo" NarInfoReq :> Get '[OctetStream] NarInfo
15 |               :<|> "nar" :> Capture "nar" NarRequest :> Get '[OctetStream] Nar
16 |               :<|> "query-paths" :> ReqBody '[JSON] (Vector FilePath)
17 |                                  :> Get '[JSON] (HashMap FilePath Bool)
18 |               :<|> "import-path" :> ReqBody '[GZipped] NarExport
19 |                                  :> Post '[HTML, OctetStream] StorePath
20 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/Client.hs:
--------------------------------------------------------------------------------
  1 | module Nix.Cache.Client where
  2 | 
  3 | import Control.Concurrent.Async.Lifted (wait)
  4 | import Control.Exception.Base (PatternMatchFail)
  5 | import Control.Monad.State.Strict (execStateT, modify)
  6 | import GHC.Conc (getNumProcessors)
  7 | import Network.HTTP.Client (Manager, Request(..), ManagerSettings(..))
  8 | import Network.HTTP.Client (newManager, defaultManagerSettings, responseHeaders)
  9 | import Network.HTTP.Client.TLS (tlsManagerSettings)
 10 | import Servant ((:<|>)(..), Proxy(Proxy))
 11 | import Servant.Client (BaseUrl(..), ClientM, ClientEnv(ClientEnv), Scheme(..))
 12 | import Servant.Client (runClientM, client, ServantError, responseBody)
 13 | import Servant.Common.BaseUrl (parseBaseUrl)
 14 | import System.Directory (getTemporaryDirectory)
 15 | import System.Environment (lookupEnv)
 16 | import System.IO (openBinaryTempFileWithDefaultPermissions)
 17 | import System.IO (stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
 18 | import qualified Data.ByteString.Base64 as B64
 19 | import qualified Data.ByteString.Lazy as BL
 20 | import qualified Data.ByteString.Lazy.Char8 as BL8
 21 | import qualified Data.HashMap.Strict as H
 22 | import qualified Data.HashSet as HS
 23 | import qualified Data.Text as T
 24 | import qualified Data.Text.Encoding as T
 25 | import qualified Data.Vector as V
 26 | import qualified Prelude as P
 27 | 
 28 | import Nix.Cache.Common
 29 | import Nix.Bin (NixBinDir, getNixBinDir, nixCmd)
 30 | import Nix.Cache.API (NixCacheAPI)
 31 | import Nix.Cache.Client.Misc (getNixStorePaths)
 32 | import Nix.Cache.Logger
 33 | import Nix.Cache.Types (NixCacheInfo(storeDir))
 34 | import Nix.Derivation -- (Derivation(..), parseDeriv
 35 | import Nix.Nar (Nar, NarExport(..), NarMetadata(..), Signature(..))
 36 | import Nix.Nar (getNarExport, importNarExport)
 37 | import Nix.NarInfo (NarInfo(references, narReq), NarInfoReq(..), NarRequest)
 38 | import qualified Nix.NarInfo as NarInfo
 39 | import Nix.ReferenceCache (ReferenceCache, getDeriver)
 40 | import Nix.ReferenceCache (computeClosure, recordReferences, getReferences)
 41 | import Nix.ReferenceCache (newReferenceCache, initializeReferenceCache)
 42 | import Nix.ReferenceCache (recordSignature, getSignature)
 43 | import Nix.StorePath (NixStoreDir, StorePath(spPrefix), PathSet)
 44 | import Nix.StorePath (getNixStoreDir, abbrevSP)
 45 | import Nix.StorePath (ioParseFullStorePath, ioParseStorePath, spToFull)
 46 | 
 47 | -------------------------------------------------------------------------------
 48 | -- * Servant client
 49 | -------------------------------------------------------------------------------
 50 | 
 51 | -- | Define the client by pattern matching.
 52 | fetchNixCacheInfo :: ClientM NixCacheInfo
 53 | fetchNarInfo :: NarInfoReq -> ClientM NarInfo
 54 | fetchNar :: NarRequest -> ClientM Nar
 55 | queryPaths :: Vector FilePath -> ClientM (HashMap FilePath Bool)
 56 | sendNarExport :: NarExport -> ClientM StorePath
 57 | fetchNixCacheInfo
 58 |   :<|> fetchNarInfo
 59 |   :<|> fetchNar
 60 |   :<|> queryPaths
 61 |   :<|> sendNarExport = client (Proxy :: Proxy NixCacheAPI)
 62 | 
 63 | -- | Base URL of the nixos cache.
 64 | nixosCacheUrl :: BaseUrl
 65 | nixosCacheUrl = BaseUrl {
 66 |   baseUrlScheme = Https,
 67 |   baseUrlHost = "cache.nixos.org",
 68 |   baseUrlPort = 443,
 69 |   baseUrlPath = ""
 70 |   }
 71 | 
 72 | -- | Nix cache auth.
 73 | data NixCacheAuth = NixCacheAuth Text Text
 74 |   deriving (Show, Eq, Generic)
 75 | 
 76 | -- | Read auth from the environment.
 77 | authFromEnv :: IO (Maybe NixCacheAuth)
 78 | authFromEnv = do
 79 |   username <- map T.pack <$> lookupEnv "NIX_BINARY_CACHE_USERNAME"
 80 |   password <- map T.pack <$> lookupEnv "NIX_BINARY_CACHE_PASSWORD"
 81 |   case (username, password) of
 82 |     (Just "", Just _) -> pure Nothing
 83 |     (Just user, Just pass) -> pure $ Just $ NixCacheAuth user pass
 84 |     _ -> pure Nothing
 85 | 
 86 | -- | Read nix cache url from the environment.
 87 | nixCacheUrlFromEnv :: IO BaseUrl
 88 | nixCacheUrlFromEnv = do
 89 |   base <- lookupEnv "NIX_REPO_HTTP" >>= \case
 90 |     Nothing -> pure "https://cache.nixos.org"
 91 |     Just url -> pure url
 92 |   parseBaseUrl base
 93 | 
 94 | -------------------------------------------------------------------------------
 95 | -- * Nix client monad
 96 | -------------------------------------------------------------------------------
 97 | 
 98 | data NixClientError
 99 |   -- | If we got an HTTP error when uploading a path.
100 |   = PathFailedToSend StorePath ServantError
101 |   -- | If we got an HTTP error when downloading a path.
102 |   | PathFailedToFetch StorePath ServantError
103 |   -- | If we got an HTTP error when requesting path NAR info.
104 |   | PathFailedToGetNarInfo StorePath ServantError
105 |   -- | If we expected the server to have a NARInfo but it doesn't.
106 |   | PathNotOnServer StorePath
107 |   -- | If we expected the client to have a store path but it doesn't.
108 |   | PathNotOnClient StorePath
109 |   -- | If we got an HTTP error when requesting nix cache info.
110 |   | FailedToReadNixCacheInfo ServantError
111 |   -- | If the remote nix store directory is not the same as the local.
112 |   | StoreDirectoryMismatch { remoteStoreDir :: NixStoreDir,
113 |                              localStoreDir :: NixStoreDir }
114 |   deriving (Show, Eq, Generic)
115 | 
116 | instance Exception NixClientError
117 | 
118 | -- | Configuration of the nix client.
119 | data NixClientConfig = NixClientConfig {
120 |   -- | Location of the nix store.
121 |   nccStoreDir :: NixStoreDir,
122 |   -- | Location of nix binaries.
123 |   nccBinDir :: NixBinDir,
124 |   -- | Base url of the nix binary cache.
125 |   nccCacheUrl :: BaseUrl,
126 |   -- | Optional auth for the nix cache, if using HTTPS.
127 |   nccCacheAuth :: Maybe NixCacheAuth,
128 |   -- | Max number of concurrent tasks
129 |   nccMaxWorkers :: Int,
130 |   -- | Minimum level of logging messages to show.
131 |   nccLogLevel :: LogLevel,
132 |   -- | Number of retries for sends.
133 |   nccSendRetry :: Int,
134 |   -- | Number of retries for fetches.
135 |   nccFetchRetry :: Int
136 |   } deriving (Show, Generic)
137 | 
138 | -- | Create a particular kind of async action for sending a path
139 | newtype AsyncSend = AsyncSend (Async ())
140 | 
141 | -- | Create a particular kind of async action for fetching a path
142 | newtype AsyncFetch = AsyncFetch (Async ())
143 | 
144 | -- | State for the nix client monad.
145 | data NixClientState = NixClientState {
146 |   -- | Mapping of store paths to asynchronous actions which send those paths.
147 |   ncsSentPaths :: MVar (HashMap StorePath AsyncSend),
148 |   -- | Mapping of store paths to asynchronous actions which fetch those paths.
149 |   ncsFetchedPaths :: MVar (HashMap StorePath AsyncFetch),
150 |   -- | Starts out as Nothing and becomes Just Nothing if valid, and
151 |   -- Just (Just err) if there's an error.
152 |   ncsValidatedStoreDirectory :: MVar (Maybe (Maybe NixClientError))
153 |   } deriving (Generic)
154 | 
155 | -- | Object read by the nix client reader.
156 | data NixClientObj = NixClientObj {
157 |   -- | Static configuration of the client.
158 |   ncoConfig :: NixClientConfig,
159 |   -- | Mutable state of the client.
160 |   ncoState :: NixClientState,
161 |   -- | HTTP connection manager client uses to connect.
162 |   ncoManager :: Manager,
163 |   -- | Database connection for the local cache. Syncronized in MVar to
164 |   -- allow lastrowid to be deterministic
165 |   ncoReferenceCache :: ReferenceCache,
166 |   -- | Client logger.
167 |   ncoLogger :: Logger,
168 |   -- | Limits the number of concurrent client operations.
169 |   ncoSemaphore :: QSem
170 |   }
171 | 
172 | -- | Nix client monad.
173 | type NixClient = ReaderT NixClientObj IO
174 | 
175 | loadClientConfig :: IO NixClientConfig
176 | loadClientConfig = do
177 |   nccStoreDir <- getNixStoreDir
178 |   nccCacheUrl <- nixCacheUrlFromEnv
179 |   nccCacheAuth <- authFromEnv
180 |   nccMaxWorkers <- (>>= readMay) <$> lookupEnv "MAX_WORKERS" >>= \case
181 |     Just n | n > 0 -> return n
182 |     _ -> getNumProcessors
183 |   nccLogLevel <- (>>= readMay) <$> lookupEnv "LOG_LEVEL" >>= \case
184 |     Just level -> pure level
185 |     _ -> return LOG_INFO
186 |   -- TODO make configurable
187 |   nccSendRetry <- pure 3
188 |   nccFetchRetry <- pure 3
189 |   nccBinDir <- getNixBinDir
190 |   putStrLn $ "Nix bin dir: " <> tshow nccBinDir
191 |   pure NixClientConfig {..}
192 | 
193 | -- | Run the nix client monad, given a configuration.
194 | runNixClientWithConfig :: NixClientConfig -> NixClient a -> IO a
195 | runNixClientWithConfig cfg action = do
196 |   semaphore <- newQSem (nccMaxWorkers cfg)
197 |   -- TODO don't only log to stdout
198 |   withLogger stdout (nccLogLevel cfg) $ \logger -> do
199 |     manager <- mkManager cfg logger
200 |     state <- NixClientState <$> newMVar mempty <*> newMVar mempty
201 |                             <*> newMVar Nothing
202 |     cache <- newReferenceCache
203 |     initializeReferenceCache cache
204 |     let obj = NixClientObj cfg state manager cache logger semaphore
205 |     -- Perform the action and then update the cache.
206 |     result <- runReaderT (action) obj
207 |     pure result
208 | 
209 | -- | Run the nix client monad.
210 | runNixClient :: NixClient a -> IO a
211 | runNixClient action = do
212 |   cfg <- loadClientConfig
213 |   runNixClientWithConfig cfg action
214 | 
215 | -------------------------------------------------------------------------------
216 | -- * Nix client logging
217 | -------------------------------------------------------------------------------
218 | 
219 | -- | Logger. Writes to stdout and checks level to see if it should
220 | -- print. Writes are mutexed so that it's threadsafe.
221 | ncLog :: LogLevel -> Text -> NixClient ()
222 | ncLog level message = liftIO . logAtLevel level message =<< ncoLogger <$> ask
223 | 
224 | ncLowDebug :: Text -> NixClient ()
225 | ncLowDebug = ncLog LOG_LOWLEVEL_DEBUG
226 | 
227 | ncDebug :: Text -> NixClient ()
228 | ncDebug = ncLog LOG_DEBUG
229 | 
230 | ncInfo :: Text -> NixClient ()
231 | ncInfo = ncLog LOG_INFO
232 | 
233 | ncWarn :: Text -> NixClient ()
234 | ncWarn = ncLog LOG_WARN
235 | 
236 | ncFatal :: Text -> NixClient ()
237 | ncFatal = ncLog LOG_FATAL
238 | 
239 | -------------------------------------------------------------------------------
240 | -- * Nix client HTTP configuration and interaction
241 | -------------------------------------------------------------------------------
242 | 
243 | -- | Given some configuration, create the request manager.
244 | mkManager :: NixClientConfig -> Logger -> IO Manager
245 | mkManager config logger = do
246 |   let baseUrl = nccCacheUrl config
247 |       mauth = nccCacheAuth config
248 |       managerSettings = case baseUrlScheme baseUrl of
249 |         Https -> tlsManagerSettings
250 |         _ -> defaultManagerSettings
251 |       -- A request modifier function, which adds the username/password
252 |       -- to the Authorization header. It also logs the request path.
253 |       modifyReq req = do
254 |         let msg = "Request: " <> tshow (method req) <> " " <> tshow (path req)
255 |         logAtLevel LOG_DEBUG msg logger
256 |         pure $ case mauth of
257 |           Nothing -> req
258 |           Just (NixCacheAuth username password) -> do
259 |             -- Encode the username:password in base64.
260 |             let auth = username <> ":" <> password
261 |             let authB64 = B64.encode $ T.encodeUtf8 auth
262 |             req {
263 |               requestHeaders = requestHeaders req `snoc`
264 |                 ("Authorization", "Basic " <> authB64)
265 |             }
266 |       modifyResponse resp = do
267 |         let headers = H.fromList $ responseHeaders resp
268 |             fixContentType = \case
269 |               "binary/octet-stream" -> "application/octet-stream"
270 |               "text/x-nix-narinfo" -> "application/octet-stream"
271 |               "application/x-nix-nar" -> "application/octet-stream"
272 |               ctype -> ctype
273 |             headers' = case lookup "content-type" headers of
274 |               Just t -> H.insert "content-type" (fixContentType t) headers
275 |               Nothing -> headers
276 |         pure resp {responseHeaders = H.toList headers'}
277 |   newManager managerSettings {
278 |     managerModifyRequest = modifyReq,
279 |     managerModifyResponse = modifyResponse
280 |     }
281 | 
282 | -- | Perform a request with the servant client in the NixClient monad.
283 | -- Throws error responses as exceptions.
284 | clientRequest :: ClientM a -> NixClient a
285 | clientRequest req = clientRequestEither req >>= \case
286 |   Left err -> throw err
287 |   Right result -> pure result
288 | 
289 | -- | Perform a request with the servant client in the NixClient monad.
290 | clientRequestEither :: ClientM a -> NixClient (Either ServantError a)
291 | clientRequestEither req = validateStoreDirectory >> do
292 |   config <- ncoConfig <$> ask
293 |   manager <- ncoManager <$> ask
294 |   let env = ClientEnv manager (nccCacheUrl config)
295 |   liftIO $ runClientM req env
296 | 
297 | -- | Validate that the remote cache has the same store directory as
298 | -- the client. This is only performed once, and it's lazy: it only
299 | -- happens if we need to communicate with the remote server (which isn't
300 | -- always the case)
301 | validateStoreDirectory :: NixClient ()
302 | validateStoreDirectory = do
303 |   mv <- ncsValidatedStoreDirectory <$> ncoState <$> ask
304 |   readMVar mv >>= \case
305 |     -- Already been validated, just return
306 |     Just Nothing -> pure ()
307 |     -- Encountered an error before, throw that error
308 |     Just (Just err) -> throw err
309 |     -- Hasn't been done yet, validate and fill the mvar
310 |     Nothing -> do
311 |       modifyMVar_ mv $ \_ -> do
312 |         config <- ncoConfig <$> ask
313 |         manager <- ncoManager <$> ask
314 |         let url = nccCacheUrl config
315 |         ncDebug ("Validating nix store directory on cache " <> tshow url)
316 |         let env = ClientEnv manager url
317 |         liftIO (runClientM fetchNixCacheInfo env) >>= \case
318 |           Left err -> pure (Just $ Just $ FailedToReadNixCacheInfo err)
319 |           Right info -> do
320 |             let remoteStoreDir = storeDir info
321 |             localStoreDir <- nccStoreDir . ncoConfig <$> ask
322 |             case remoteStoreDir == localStoreDir of
323 |               True -> do
324 |                 ncDebug $ "Validated: " <> tshow localStoreDir
325 |                 pure (Just Nothing)
326 |               False -> pure (Just $ Just StoreDirectoryMismatch {..})
327 |       -- Now that we checked, rerun the validate command
328 |       validateStoreDirectory
329 | 
330 | -------------------------------------------------------------------------------
331 | -- * Nix client actions
332 | -------------------------------------------------------------------------------
333 | 
334 | -- | Do a nix client action inside of the semaphore
335 | inSemaphore :: NixClient a -> NixClient a
336 | inSemaphore action = bracket getSem releaseSem (\_ -> action) where
337 |   -- Acquire a resource from our semaphore.
338 |   getSem = do
339 |     ncLowDebug "Waiting for semaphore"
340 |     waitQSem =<< asks ncoSemaphore
341 |   -- Release the resource to the semaphore.
342 |   releaseSem () = do
343 |     ncLowDebug "Releasing semaphore"
344 |     signalQSem =<< asks ncoSemaphore
345 | 
346 | -- | Get the NAR info for a store path by requesting to the server.
347 | getNarInfo :: StorePath -> NixClient (Maybe NarInfo)
348 | getNarInfo path = inSemaphore $ do
349 |   ncDebug $ "Requesting narinfo for " <> tshow path
350 |   clientRequestEither (fetchNarInfo $ NarInfoReq (spPrefix path)) >>= \case
351 |     Right info -> do
352 |       forM_ (NarInfo.sig info) $ \sig -> do
353 |         cache <- ncoReferenceCache <$> ask
354 |         liftIO $ recordSignature cache path sig
355 |       pure $ Just info
356 |     Left err -> case errorIs404 err of
357 |       True -> pure Nothing
358 |       False -> throw $ PathFailedToGetNarInfo path err
359 | 
360 | -- | If the server in question doesn't support the /query-paths route,
361 | -- instead the NarInfo of each path can be requested from the server as a
362 | -- way to determine if it's on the server.
363 | getPathsOnServerWithNarInfo :: [StorePath] -> NixClient (HashMap StorePath Bool)
364 | getPathsOnServerWithNarInfo paths = do
365 |   asyncs <- forM paths $ \path -> do
366 |     async $ getNarInfo path >>= \case
367 |       Nothing -> pure (path, False)
368 |       Just _ -> pure (path, True)
369 |   H.fromList <$> mapM wait asyncs
370 | 
371 | -- | Given some store paths to send, find their closure and see which
372 | -- of those paths do not already exist on the server.
373 | queryStorePaths :: [StorePath]
374 |                 -- ^ Top-level store paths to send.
375 |                 -> NixClient (PathSet, PathSet)
376 |                 -- ^ Set of paths on the server, and not on the server.
377 | queryStorePaths paths = do
378 |   let count paths = len <> " path" <> if len == "1" then "" else "s"
379 |         where len = tshow $ length paths
380 |   ncDebug $ "Computing full closure of " <> count paths <> "."
381 |   cache <- ncoReferenceCache <$> ask
382 |   pathsToSend <- map concat $ forM paths $ \path -> do
383 |     liftIO $ computeClosure cache path
384 |   ncDebug $ "Full closure contains " <> count pathsToSend <> "."
385 |   storeDir <- nccStoreDir . ncoConfig <$> ask
386 |   -- Convert the path list to full paths and convert that to a vector.
387 |   let paths = HS.toList pathsToSend
388 |       pathsV = V.fromList $ map (spToFull storeDir) paths
389 |   -- Now that we have the full list built up, send it to the
390 |   -- server to see which paths are already there.
391 |   ncDebug "Querying repo to see what paths it has"
392 |   pathResults <- clientRequestEither (queryPaths $ pathsV) >>= \case
393 |     Right r -> map H.fromList $ forM (H.toList r) $ \(pathStr, onServer) -> do
394 |       spath <- snd <$> ioParseFullStorePath (pack pathStr)
395 |       pure (spath, onServer)
396 |     Left err -> case errorIs404 err of
397 |       True -> getPathsOnServerWithNarInfo paths
398 |       False -> throw err
399 |   -- Split the dictionary into two lists.
400 |   result <- flip execStateT (mempty, mempty) $ do
401 |     forM_ (H.toList pathResults) $ \(spath, isInRepo) -> do
402 |       modify $ \(inrepo, notinrepo) -> case isInRepo of
403 |         True -> (HS.insert spath inrepo, notinrepo)
404 |         False -> (inrepo, HS.insert spath notinrepo)
405 |   ncInfo $ count (fst result) <> " are already on the repo, and "
406 |         <> count (snd result) <> " are not."
407 |   pure result
408 | 
409 | -- | Get the references of a path, using the server as a
410 | -- fallback. This is necessary when fetching a path, because might not
411 | -- know ahead of time what that path's references will be.
412 | -- If the server has the path's information, cache it the same way we
413 | -- cache normal references. Otherwise, it's an error.
414 | getReferencesFallBackToServer :: StorePath -> NixClient PathSet
415 | getReferencesFallBackToServer spath = do
416 |   ncLowDebug $ "Getting references for " <> abbrevSP spath
417 |   cache <- ncoReferenceCache <$> ask
418 |   liftIO (getReferences cache spath) >>= \case
419 |     Just refs -> pure refs
420 |     Nothing -> getNarInfo spath >>= \case
421 |       Just info -> do
422 |         let refs = references info
423 |         refPaths <- map HS.fromList $ forM refs $ \path -> do
424 |           ioParseStorePath (pack path)
425 |         liftIO $ recordReferences cache spath refPaths
426 |         pure refPaths
427 |       Nothing -> throw $ PathNotOnServer spath
428 | 
429 | -- | Get the references of a store path, using only local information.
430 | getReferencesLocally :: StorePath -> NixClient PathSet
431 | getReferencesLocally spath = do
432 |   ncLowDebug $ "Getting references for " <> abbrevSP spath <> " (local)"
433 |   cache <- ncoReferenceCache <$> ask
434 |   liftIO (getReferences cache spath) >>= \case
435 |     Nothing -> throw $ PathNotOnClient spath
436 |     Just refs -> pure refs
437 | 
438 | -- | Fetch the closure of a store path from the remote. This assumes
439 | -- that the path (and its dependencies of course) is already on the
440 | -- remote server.
441 | fetchPath :: StorePath -> NixClient AsyncFetch
442 | fetchPath spath = do
443 |   state <- asks ncoState
444 |   modifyMVar (ncsFetchedPaths state) $ \s -> do
445 |     -- See if we've already created a thread for this fetch.
446 |     case H.lookup spath s of
447 |       -- If one exists just return that.
448 |       Just action -> return (s, action)
449 |       Nothing -> do
450 |         action <- map AsyncFetch $ async $ do
451 |           ncDebug $ "Started process to fetch " <> abbrevSP spath
452 |           refs <- getReferencesFallBackToServer spath
453 |           -- Concurrently fetch parent paths.
454 |           refActions <- forM (HS.toList refs) $ \ref -> do
455 |             (,) ref <$> fetchPath ref
456 |           forM_ refActions $ \(ref, AsyncFetch rAction) -> do
457 |             ncLowDebug $ concat [abbrevSP spath, " is waiting for ",
458 |                                  abbrevSP ref, " to finish fetching (",
459 |                                  tshow $ asyncThreadId rAction, ")"]
460 |             wait rAction
461 |             ncLowDebug $ abbrevSP ref <> " finished"
462 |           ncLowDebug $ "Parent paths have finished fetching, now fetching "
463 |                     <> abbrevSP spath <> " itself..."
464 |           -- Once parents are fetched, fetch the path itself.
465 |           fetchSinglePath spath
466 |         return (H.insert spath action s, action)
467 | 
468 | -- | Given a derivation and optionally a subset of outputs needed from
469 | -- that derivation, fetch all of the paths (and their dependencies)
470 | -- from the repo. This will fetch zero or more paths -- if a path
471 | -- isn't on the repo, it's not an error; it simply won't be fetched
472 | -- (unless the repo reports the path as being on the server when it
473 | -- really isn't).
474 | fetchDerivation :: DerivationAndOutputs -> NixClient ()
475 | fetchDerivation (DerivationAndOutputs deriv outs) = do
476 |   paths <- case outs of
477 |     Nothing -> pure $ fst <$> H.elems (derivOutputs deriv)
478 |     Just outNames -> forM outNames $ \(name::OutputName) -> do
479 |       case lookupOutput deriv name of
480 |         Right (path :: StorePath) -> pure path
481 |         Left err -> throw err
482 |   fetchPaths paths
483 | 
484 | -- | Fetch paths and their dependencies, after first checking for ones
485 | -- already present.
486 | fetchPaths :: [StorePath] -> NixClient ()
487 | fetchPaths spaths = do
488 |   state <- ncoState <$> ask
489 |   modifyMVar_ (ncsFetchedPaths state) $ \fetched -> do
490 |     -- Get a set of store paths the repo already has.
491 |     inRepo <- pure mempty -- fst <$> queryStorePaths spaths
492 |     -- Create no-op actions for all of these.
493 |     noopActions <- map H.fromList $ forM (HS.toList inRepo) $ \path -> do
494 |       noopAction <- map AsyncFetch $ async $ do
495 |         ncLowDebug $ abbrevSP path <> " was already in the repo."
496 |       pure (path, noopAction)
497 |     -- Update the state, inserting no-op actions for any paths which
498 |     -- have already been sent.
499 |     pure (fetched <> noopActions)
500 |   -- For the unsent paths, asynchronously fetch each one, and then
501 |   -- wait for the result.
502 |   fetches <- mapM fetchPath spaths
503 |   forM_ fetches $ \(AsyncFetch action) -> wait action
504 | 
505 | -- | Send paths and their dependencies, after first checking for ones
506 | -- already sent.
507 | sendPaths :: [StorePath] -> NixClient ()
508 | sendPaths spaths = do
509 |   state <- ncoState <$> ask
510 |   modifyMVar_ (ncsSentPaths state) $ \sent -> do
511 |     -- Get a set of store paths the repo already has.
512 |     inRepo <- fst <$> queryStorePaths spaths
513 |     -- Create no-op actions for all of these.
514 |     noopActions <- map H.fromList $ forM (HS.toList inRepo) $ \path -> do
515 |       noopAction <- map AsyncSend $ async $ do
516 |         ncLowDebug $ abbrevSP path <> " was already in the repo."
517 |       pure (path, noopAction)
518 |     -- Update the state, inserting no-op actions for any paths which
519 |     -- have already been sent.
520 |     pure (sent <> noopActions)
521 |   -- For the unsent paths, asynchronously fetch each one, and then
522 |   -- wait for the result.
523 |   sends <- mapM sendPath spaths
524 |   forM_ sends $ \(AsyncSend action) -> wait action
525 | 
526 | -- | Send a path and its full dependency set to a binary cache.
527 | sendPath :: StorePath -> NixClient AsyncSend
528 | sendPath spath = do
529 |   state <- asks ncoState
530 |   modifyMVar (ncsSentPaths state) $ \s -> do
531 |     -- See if we've already created a thread for this send.
532 |     case H.lookup spath s of
533 |       -- If one exists just return that.
534 |       Just action -> return (s, action)
535 |       Nothing -> do
536 |         action <- map AsyncSend $ async $ do
537 |           ncDebug $ "Started process to send " <> abbrevSP spath
538 |           refs <- getReferencesLocally spath
539 |           -- Concurrently send parent paths.
540 |           refActions <- forM (HS.toList refs) $ \ref -> do
541 |             (,) ref <$> sendPath ref
542 |           forM_ refActions $ \(ref, AsyncSend rAction) -> do
543 |             ncLowDebug $ concat [abbrevSP spath, " is waiting for ",
544 |                                  abbrevSP ref, " to finish sending (",
545 |                                  tshow $ asyncThreadId rAction, ")"]
546 |             wait rAction
547 |             ncLowDebug $ abbrevSP ref <> " finished"
548 |           ncLowDebug $ "Parent paths have finished sending, now sending "
549 |                     <> abbrevSP spath <> " itself..."
550 |           -- Once parents are sent, send the path itself.
551 |           sendSinglePath spath
552 |         return (H.insert spath action s, action)
553 | 
554 | -- | Send a single path to a nix repo. This doesn't automatically
555 | -- include parent paths, so it generally shouldn't be used externally to
556 | -- this module (use sendPath instead)
557 | sendSinglePath :: StorePath -> NixClient ()
558 | sendSinglePath spath = go =<< nccSendRetry <$> ncoConfig <$> ask where
559 |   go retries = inSemaphore $ do
560 |     ncDebug $ "Getting nar data for " <> abbrevSP spath <> "..."
561 |     storeDir <- nccStoreDir . ncoConfig <$> ask
562 |     binDir <- nccBinDir . ncoConfig <$> ask
563 |     export <- liftIO $ getNarExport binDir storeDir spath
564 |     ncInfo $ "Sending " <> abbrevSP spath
565 |     clientRequestEither (sendNarExport export) >>= \case
566 |       Right _ -> ncDebug $ "Finished sending " <> abbrevSP spath
567 |       Left err | retries <= 0 -> throw $ PathFailedToSend spath err
568 |                | otherwise -> do
569 |                    ncLowDebug $ "Encountered error: " <> tshow err
570 |                    ncLowDebug $ "Retrying (" <> tshow retries <> ") remaining"
571 |                    go (retries - 1)
572 | 
573 | getSignatureNC :: StorePath -> NixClient (Maybe Signature)
574 | getSignatureNC spath = do
575 |   cache <- ncoReferenceCache <$> ask
576 |   -- TODO make this general
577 |   liftIO (getSignature cache spath "cache.nixos.org-1") >>= \case
578 |     Just sig -> pure $ Just sig
579 |     Nothing -> do
580 |       getNarInfo spath
581 |       liftIO (getSignature cache spath "cache.nixos.org-1")
582 | 
583 | -- | Get the NAR metadata for a store path.
584 | getMetadata :: StorePath -> NixClient NarMetadata
585 | getMetadata path = do
586 |   cache <- ncoReferenceCache <$> ask
587 |   nmStoreDirectory <- nccStoreDir . ncoConfig <$> ask
588 |   nmDeriver <- join <$> liftIO (getDeriver cache path)
589 |   nmReferences <- getReferencesLocally path
590 |   nmSignature <- getSignatureNC path
591 |   putStrLn $ "Signature: " <> tshow nmSignature
592 | 
593 |   pure NarMetadata {nmStorePath = path, ..}
594 | 
595 | -- | Given a Nar and the path it corresponds to, build an export.
596 | makeNarExport :: StorePath -> Nar -> NixClient NarExport
597 | makeNarExport spath nar = NarExport nar <$> getMetadata spath
598 | 
599 | -- | Replace a long response body with a redacted message, and write
600 | -- the body to a temporary file instead.
601 | redactResponse :: ServantError -> IO ServantError
602 | redactResponse err = redact `catch` \(_::PatternMatchFail) -> pure err where
603 |   redact = do
604 |     let body = responseBody err
605 |     case length body > 500 of
606 |       False -> pure err
607 |       True -> do
608 |         dir <- getTemporaryDirectory
609 |         body' <- bracket
610 |           (openBinaryTempFileWithDefaultPermissions dir "redacted-response-")
611 |           (\(_, handle) -> hClose handle)
612 |           (\(path, handle) -> do
613 |             BL.hPut handle body
614 |             pure $ "(Wrote long response body to " <> BL8.pack path <> ")")
615 |         pure err { responseBody = body' }
616 | 
617 | 
618 | -- | Fetch a single path from a nix repo. This doesn't automatically
619 | -- include parent paths, so it generally shouldn't be used externally to
620 | -- this module (use fetchPath instead)
621 | fetchSinglePath :: StorePath -> NixClient ()
622 | fetchSinglePath p = go =<< nccSendRetry <$> ncoConfig <$> ask where
623 |   go retries = inSemaphore $ do
624 |     ncLowDebug $ "Getting nar request URL for " <> abbrevSP p <> "..."
625 |     req <- getNarInfo p >>= \case
626 |       Nothing -> throw $ PathNotOnServer p
627 |       Just info -> pure $ narReq info
628 |     -- Use this request to fetch the store path.
629 |     clientRequestEither (fetchNar req) >>= \case
630 |       Left err | retries <= 0 -> do
631 |                    err' <- liftIO $ redactResponse err
632 |                    throw $ PathFailedToFetch p err'
633 |                | otherwise -> do
634 |                    ncLowDebug $ "Encountered error: " <> tshow err
635 |                    ncLowDebug $ "Retrying (" <> tshow retries <> ") remaining"
636 |                    go (retries - 1)
637 |       Right nar -> do
638 |         export <- makeNarExport p nar
639 |         binDir <- nccBinDir . ncoConfig <$> ask
640 |         ncInfo $ "Importing " <> abbrevSP p
641 |         liftIO $ importNarExport binDir export
642 |         ncDebug  $ "Finished fetching " <> abbrevSP p
643 | 
644 | mytest :: IO ()
645 | mytest = do
646 |   -- Make line-buffered, so we can use putStrLn in multithreaded code.
647 |   hSetBuffering stdout LineBuffering
648 |   hSetBuffering stderr LineBuffering
649 | 
650 |   cfg' <- loadClientConfig
651 |   let cfg = cfg' { --nccCacheUrl = BaseUrl Https "green-slashnix-repo.n-s.us" 443 "",
652 |                   nccLogLevel = LOG_DEBUG
653 |                  }
654 |   derivAndOuts <- nixCmd (nccBinDir cfg') "instantiate" [
655 |     "/home/anelson/nixpkgs", "-A", "sqlite"
656 |     ] ""
657 | 
658 |   runNixClientWithConfig cfg (fetchDerivation derivAndOuts *> ncInfo "finished")
659 |   -- _ <- (P.!! 5) <$> getNixStorePaths 10
660 |   -- paths <- getNixStorePaths 10
661 |   -- runNixClientWithConfig cfg (sendPaths paths *> ncInfo "finished")
662 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/Client/Main.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import Prelude
 4 | import System.IO (IO, stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
 5 | import Nix.Cache.Client
 6 | 
 7 | main :: IO ()
 8 | main = do
 9 |   -- Make line-buffered, so we can use putStrLn in multithreaded code.
10 |   hSetBuffering stdout LineBuffering
11 |   hSetBuffering stderr LineBuffering
12 | 
13 |   _ <- loadClientConfig
14 | 
15 |   putStrLn "Hello world!"
16 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/Client/Misc.hs:
--------------------------------------------------------------------------------
 1 | -- | Miscellaneous utility and/or tester functions
 2 | module Nix.Cache.Client.Misc where
 3 | 
 4 | import Nix.Cache.Common
 5 | import Nix.StorePath (NixStoreDir(..), StorePath)
 6 | import Nix.StorePath (getNixStoreDir, parseStorePath)
 7 | 
 8 | 
 9 | getNixStorePaths :: Int -> IO [StorePath]
10 | getNixStorePaths count = do
11 |   NixStoreDir d <- getNixStoreDir
12 |   list <- listDirectory d
13 |   pure $ take count $ catMaybes $ flip map list $ \txt -> do
14 |     case parseStorePath (pack txt) of
15 |       Left _ -> Nothing
16 |       Right sp -> Just sp
17 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/Common.hs:
--------------------------------------------------------------------------------
 1 | -- | Provides basic utilites to the cache libraries.
 2 | module Nix.Cache.Common (
 3 |   module ClassyPrelude,
 4 |   listDirectory, splitWS, errorIs404
 5 |   ) where
 6 | 
 7 | import ClassyPrelude
 8 | import qualified Data.Text as T
 9 | import System.Directory (getDirectoryContents)
10 | import Network.HTTP.Types.Status (Status(..))
11 | import Servant.Client (ServantError(..))
12 | 
13 | -- | Split a text on whitespace. Derp.
14 | splitWS :: Text -> [Text]
15 | splitWS = filter (/= "") . T.split (flip elem [' ', '\t', '\n', '\r'])
16 | 
17 | -- | This function is not in all versions of the directory package, so
18 | -- we copy/paste the definition here.
19 | listDirectory :: FilePath -> IO [FilePath]
20 | listDirectory path = filter f <$> getDirectoryContents path
21 |   where f filename = filename /= "." && filename /= ".."
22 | 
23 | -- | Return true if a servant error is a 404.
24 | errorIs404 :: ServantError -> Bool
25 | #if MIN_VERSION_servant_client(0,11,0)
26 | errorIs404 (FailureResponse _ (Status 404 _) _ _) = True
27 | #else
28 | errorIs404 (FailureResponse (Status 404 _) _ _) = True
29 | #endif
30 | errorIs404 _ = False
31 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/Logger.hs:
--------------------------------------------------------------------------------
 1 | -- | A simple concurrent logger
 2 | module Nix.Cache.Logger (
 3 |   Logger, -- abstract
 4 |   LogLevel(..),
 5 |   withLogger,
 6 |   logAtLevel
 7 |   ) where
 8 | 
 9 | import System.IO (hSetBuffering, BufferMode(LineBuffering))
10 | import Control.Concurrent (forkIO)
11 | import qualified Data.Text.IO as T
12 | 
13 | import Nix.Cache.Common
14 | 
15 | -- | Four levels of logging.
16 | data LogLevel
17 |   = LOG_LOWLEVEL_DEBUG | LOG_DEBUG | LOG_INFO | LOG_WARN | LOG_FATAL
18 |   deriving (Show, Read, Eq, Ord)
19 | 
20 | type MessageChannel = Chan (LogLevel, ThreadId, Text)
21 | 
22 | data Logger = Logger {
23 |   -- | File handle to write messages to.
24 |   handle :: Handle,
25 |   -- | Minimum level to log (if it's below this, don't write to the handle).
26 |   minLevel :: LogLevel,
27 |   -- | Channel for messages
28 |   messagesChannel :: MessageChannel,
29 |   -- | Thread consuming messages
30 |   messageConsumeThreadId :: ThreadId
31 |   } deriving (Eq, Generic)
32 | 
33 | watchMessages :: Handle -> LogLevel -> MessageChannel -> IO ()
34 | watchMessages handle minLevel messageChannel = forever $ do
35 |   (level, threadId, message) <- readChan messageChannel
36 |   when (level >= minLevel) $ do
37 |     case level <= LOG_DEBUG of
38 |       True -> do
39 |         T.hPutStrLn handle $ tshow threadId <> ": " <> message
40 |       False -> do
41 |         T.hPutStrLn handle message
42 | 
43 | newLogger :: Handle -> LogLevel -> IO Logger
44 | newLogger handle minLevel = do
45 |   hSetBuffering handle LineBuffering
46 |   messagesChannel <- newChan
47 |   messageConsumeThreadId <- forkIO $
48 |     watchMessages handle minLevel messagesChannel
49 |   pure Logger {..}
50 | 
51 | stopLogger :: Logger -> IO ()
52 | stopLogger logger = killThread (messageConsumeThreadId logger)
53 | 
54 | withLogger :: Handle -> LogLevel -> (Logger -> IO a) -> IO a
55 | withLogger handle minLevel = bracket (newLogger handle minLevel) stopLogger
56 | 
57 | logAtLevel :: LogLevel -> Text -> Logger -> IO ()
58 | logAtLevel level message logger = do
59 |   tid <- myThreadId
60 |   writeChan (messagesChannel logger) (level, tid, message)
61 | 


--------------------------------------------------------------------------------
/src/Nix/Cache/Types.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE UndecidableInstances #-}
 2 | -- | Types relating to a nix binary cache.
 3 | module Nix.Cache.Types where
 4 | 
 5 | import qualified Data.Text as T
 6 | import Data.Attoparsec.ByteString.Lazy (Result(..), parse)
 7 | import Data.Aeson (ToJSON, FromJSON)
 8 | import Servant (MimeUnrender(..), OctetStream, Accept(..),
 9 |                 Proxy(..), MimeRender(..))
10 | import Network.HTTP.Media ((//))
11 | import Codec.Compression.GZip (compress, decompress)
12 | 
13 | import Data.KVMap
14 | import Nix.Cache.Common
15 | import Nix.StorePath (NixStoreDir(NixStoreDir))
16 | 
17 | -- | Represents binary data compressed with gzip.
18 | data GZipped
19 | 
20 | -- | Content type for gzipped data.
21 | instance Accept GZipped where
22 |   contentType _ = "application" // "x-gzip"
23 | 
24 | -- | Anything which can be put in an octet stream can be put in gzip.
25 | instance MimeUnrender OctetStream t => MimeUnrender GZipped t where
26 |   mimeUnrender _ = mimeUnrender (Proxy :: Proxy OctetStream) . decompress
27 | 
28 | instance MimeRender OctetStream t => MimeRender GZipped t where
29 |   mimeRender _ obj = compress $ mimeRender (Proxy :: Proxy OctetStream) obj
30 | 
31 | -- | Information about a nix binary cache. This information is served
32 | -- on the /nix-cache-info route.
33 | data NixCacheInfo = NixCacheInfo {
34 |   storeDir :: NixStoreDir,
35 |   -- ^ On-disk location of the nix store.
36 |   wantMassQuery :: Bool,
37 |   -- ^ Not sure what this does.
38 |   priority :: Maybe Int
39 |   -- ^ Also not sure what this means.
40 |   } deriving (Show, Eq, Generic)
41 | 
42 | instance ToJSON NixCacheInfo
43 | instance FromJSON NixCacheInfo
44 | 
45 | instance FromKVMap NixCacheInfo where
46 |   fromKVMap (KVMap kvm) = case lookup "StoreDir" kvm of
47 |     Nothing -> Left "No StoreDir key defined."
48 |     Just sdir -> return $ NixCacheInfo {
49 |       storeDir = NixStoreDir $ T.unpack sdir,
50 |       wantMassQuery = lookup "WantMassQuery" kvm == Just "1",
51 |       priority = lookup "Priority" kvm >>= readMay
52 |       }
53 | 
54 | -- | To parse something from an octet stream, first parse the
55 | -- stream as a KVMap and then attempt to translate it.
56 | instance MimeUnrender OctetStream NixCacheInfo where
57 |   mimeUnrender _ bstring = case parse parseKVMap bstring of
58 |     Done _ kvmap -> fromKVMap kvmap
59 |     Fail _ _ message -> Left message
60 | 


--------------------------------------------------------------------------------
/src/Nix/Derivation.hs:
--------------------------------------------------------------------------------
 1 | -- | Nix derivations.
 2 | module Nix.Derivation (
 3 |   module Nix.Derivation.Types,
 4 |   parseDerivFromPath,
 5 |   parseDerivFromPath',
 6 |   parseDerivFromPrefix,
 7 |   derivInputs, derivGetEnv, derivGetOut
 8 |   ) where
 9 | 
10 | import ClassyPrelude
11 | import qualified Data.HashMap.Strict as H
12 | import qualified Data.HashSet as HS
13 | 
14 | import Nix.Derivation.Types
15 | import Nix.Derivation.Parser
16 | import Nix.StorePath
17 | import Nix.FileHash
18 | 
19 | -- | Given a derivation, retrieve all of the derivation paths it
20 | -- requires to build. Note this is not the full closure, because it
21 | -- does not recur on other derivations. Also note that this does not
22 | -- include fixturized filesystem paths; it only returns input paths
23 | -- which are derivations. This is because any filesystem path which
24 | -- appears in a derivation is known to already exist in the nix store.
25 | derivInputs :: NixStoreDir -> Derivation -> IO PathSet
26 | derivInputs storeDir Derivation{..} = HS.fromList . concat <$> do
27 |   forM (H.toList derivInputDerivations) $ \(dpath, outNames) -> do
28 |     deriv <- parseDerivFromPath storeDir dpath
29 |     pure $ catMaybes $ flip map outNames $ \name -> do
30 |       case lookupOutput deriv name of
31 |         Left _ -> Nothing
32 |         Right path -> Just path
33 | 
34 | derivGetEnv :: Text -> Derivation -> Maybe Text
35 | derivGetEnv key = H.lookup key . derivEnv
36 | 
37 | derivGetOut :: OutputName -> Derivation -> Maybe (StorePath, Maybe FileHash)
38 | derivGetOut outName = H.lookup outName . derivOutputs
39 | 


--------------------------------------------------------------------------------
/src/Nix/Derivation/Parser.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  2 | -- | Functions for parsing a nix derivation.
  3 | module Nix.Derivation.Parser where
  4 | 
  5 | import ClassyPrelude hiding (try, readFile)
  6 | import Prelude (readFile)
  7 | import Text.Parsec
  8 | import qualified Data.HashMap.Strict as H
  9 | import qualified Data.Text as T
 10 | 
 11 | import Nix.StorePath
 12 | import Nix.FileHash
 13 | import Nix.Derivation.Types
 14 | import Nix.Bin (NixCmdReturn(nixCmd))
 15 | 
 16 | -- | Parsec parser type.
 17 | type Parser a = Parsec [Char] () a
 18 | 
 19 | -- | Parses a string constant. Allows syntax for certain escape
 20 | -- sequences (\n, \t, etc), and otherwise anything after a '\'
 21 | -- will appear as-is (which allows " and \ to be escaped).
 22 | text :: Parser Text
 23 | text = char '"' >> loop [] where
 24 |   loop acc = do
 25 |     let continue c = loop (c:acc)
 26 |     anyChar >>= \case
 27 |       '"' -> return $ pack $ reverse acc
 28 |       '\\' -> anyChar >>= \case
 29 |         'n' -> continue '\n'
 30 |         'r' -> continue '\r'
 31 |         't' -> continue '\t'
 32 |         'b' -> continue '\b'
 33 |         c -> continue c
 34 |       c -> continue c
 35 | 
 36 | -- | Execute a parser surrounded by two characters.
 37 | surround :: Char -> Char -> Parser a -> Parser a
 38 | surround start stop p = char start *> p <* char stop
 39 | 
 40 | -- | Parse a store path surrounded by quotes.
 41 | quotedStorePath :: Parser StorePath
 42 | quotedStorePath = try $ do
 43 |   fullPath <- text
 44 |   case snd <$> parseFullStorePath fullPath of
 45 |     Left err -> fail err
 46 |     Right sp -> return sp
 47 | 
 48 | -- | Parse a derivation in the Parser monad.
 49 | derivationParser :: Parser Derivation
 50 | derivationParser = do
 51 |   let parens = surround '(' ')'
 52 |       brackets = surround '[' ']'
 53 |       sepCommas = flip sepBy (char ',')
 54 |       sepCommas1 = flip sepBy1 (char ',')
 55 |       textList = brackets $ sepCommas text
 56 |   -- All derivations start with this string.
 57 |   string "Derive"
 58 |   parens $ do
 59 |     -- Grab the output list. This is a comma-separated list of
 60 |     -- 4-tuples, like so:
 61 |     -- [("out","/nix/store/sldkfjslkdfj-foo","","")]
 62 |     -- Or if the output has a known hash, then the hash type and hash:
 63 |     -- [("out","/nix/store/xyz-foo","sha256","abc123")]
 64 |     outs <- brackets $ sepCommas1 $ do
 65 |       parens $ do
 66 |         outName <- OutputName <$> text
 67 |         char ','
 68 |         outPath <- quotedStorePath
 69 |         char ','
 70 |         text >>= \case
 71 |           "" -> do
 72 |             -- If the next text is empty, it means this isn't a
 73 |             -- fixed-output hash. Then the next string should also be
 74 |             -- empty, and that's the end.
 75 |             string ",\"\""
 76 |             return (outName, (outPath, Nothing))
 77 |           hashtype -> case getFileHashConstructor hashtype of
 78 |             -- If it's not empty, then it should correspond to a valid
 79 |             -- hash type, and there should be some non-empty hash
 80 |             -- string coming next.
 81 |             Left err -> fail err
 82 |             Right constructor -> do
 83 |               char ','
 84 |               hash <- text
 85 |               return (outName, (outPath, Just $ constructor hash))
 86 |     char ','
 87 |     -- Grab the input derivation list. A comma-separated list of
 88 |     -- 2-tuples like so:
 89 |     -- [("/nix/store/abc-bar",["out"]), ("/nix/store/xyz-bux",["out","dev"])]
 90 |     inDerivs <- brackets $ sepCommas $ do
 91 |       parens $ do
 92 |         inDName <- quotedStorePath
 93 |         char ','
 94 |         inDOutputs <- map OutputName <$> textList
 95 |         return (inDName, inDOutputs)
 96 |     -- Grab the input file list (not derivations). Just a list of
 97 |     -- strings.
 98 |     char ','
 99 |     inFiles <- brackets $ sepCommas quotedStorePath
100 |     -- Grab the system info string.
101 |     system <- char ',' >> text
102 |     -- Grab the builder executable path.
103 |     builder <- char ',' >> map unpack text
104 |     -- Grab the builder arguments.
105 |     builderArgs <- char ',' >> textList
106 |     -- Grab the build environment, a list of 2-tuples.
107 |     char ','
108 |     buildEnv <- brackets $ sepCommas $ parens $ do
109 |       key <- text
110 |       value <- char ',' *> text
111 |       return (key, value)
112 |     return $ Derivation {
113 |       derivOutputs = H.fromList outs,
114 |       derivInputDerivations = H.fromList inDerivs,
115 |       derivInputPaths = inFiles,
116 |       derivSystem = system,
117 |       derivBuilder = builder,
118 |       derivArgs = builderArgs,
119 |       derivEnv = H.fromList buildEnv
120 |       }
121 | 
122 | -- | Parse a derivation string.
123 | parseDerivString :: String -> Either String Derivation
124 | parseDerivString s = case parse derivationParser "derivation" s of
125 |   Left err -> Left $ show err
126 |   Right deriv -> Right deriv
127 | 
128 | -- | Parse a derivation text.
129 | parseDerivText :: Text -> Either String Derivation
130 | parseDerivText s = case parse derivationParser "derivation" (unpack s) of
131 |   Left err -> Left $ show err
132 |   Right deriv -> Right deriv
133 | 
134 | -- | Parse a derivation file. Assumes the file exists.
135 | parseDerivFile :: FilePath -> IO (Either String Derivation)
136 | parseDerivFile p = parseDerivString <$> readFile p
137 | 
138 | -- | Parse a derivation file. Assumes the file exists and parses correctly.
139 | parseDerivFromPath :: NixStoreDir -> StorePath -> IO Derivation
140 | parseDerivFromPath sdir spath = parseDerivFile (spToFull sdir spath) >>= \case
141 |   Left err -> error err
142 |   Right deriv -> pure deriv
143 | 
144 | -- | Parse a derivation file from a storepath, using the NIX_STORE variable.
145 | parseDerivFromPath' :: StorePath -> IO Derivation
146 | parseDerivFromPath' p = getNixStoreDir >>= flip parseDerivFromPath p
147 | 
148 | -- | Parse a derivation file given its store prefix.
149 | parseDerivFromPrefix :: StorePrefix -> IO Derivation
150 | parseDerivFromPrefix (StorePrefix prefix) = do
151 |   parseDerivFromPath' =<< findSpByPrefix prefix
152 | 
153 | parseDerivAndOutputs :: Text -> IO (Either String DerivationAndOutputs)
154 | parseDerivAndOutputs txt = case T.split (=='!') (T.strip txt) of
155 |   [path] -> parseDerivFile (unpack path) >>= \case
156 |     Right deriv -> pure $ Right $ DerivationAndOutputs deriv Nothing
157 |     Left err -> pure $ Left err
158 |   [path, ""] -> parseDerivFile (unpack path) >>= \case
159 |     Right deriv -> pure $ Right $ DerivationAndOutputs deriv Nothing
160 |     Left err -> pure $ Left err
161 |   [path, outputs] -> do
162 |     let names = OutputName <$> T.split (==',') outputs
163 |     parseDerivFile (unpack path) >>= \case
164 |       Right deriv -> pure $ Right $ DerivationAndOutputs deriv (Just names)
165 |       Left err -> pure $ Left err
166 |   _ -> pure $ Left $ "Couldn't parse derivation/outputs indication " <> show txt
167 | 
168 | 
169 | instance NixCmdReturn DerivationAndOutputs where
170 |   nixCmd nixBin cmd args input = do
171 |     nixCmd nixBin cmd args input >>= parseDerivAndOutputs >>= \case
172 |       Left err -> error err
173 |       Right res -> pure res
174 | 


--------------------------------------------------------------------------------
/src/Nix/Derivation/Types.hs:
--------------------------------------------------------------------------------
 1 | module Nix.Derivation.Types where
 2 | 
 3 | import ClassyPrelude
 4 | 
 5 | import Nix.StorePath
 6 | import qualified Data.HashMap.Strict as H
 7 | import Nix.FileHash
 8 | 
 9 | -- | The main derivation type. This represents all of the information
10 | -- that is needed to construct a particular store object; the store
11 | -- object(s) that will be built are listed in the `derivOutputs` field.
12 | data Derivation = Derivation {
13 |   derivOutputs :: HashMap OutputName (StorePath, Maybe FileHash),
14 |   -- ^ Outputs the derivation is expected to produce and what they're
15 |   -- called. Those outputs might have known hashes (fixed-output
16 |   -- derivations); if so include those.
17 |   derivInputDerivations :: HashMap StorePath [OutputName],
18 |   -- ^ Derivations this derivation needs to have as inputs, and
19 |   -- outputs of those derivations.
20 |   derivInputPaths :: [StorePath],
21 |   -- ^ Non-derivation inputs the derivation needs in order to build
22 |   -- (paths that were copied from the file system to the store)
23 |   derivSystem :: Text,
24 |   -- ^ System the derivation is to be built on.
25 |   derivBuilder :: FilePath,
26 |   -- ^ Path to the executable to build the derivation.
27 |   derivArgs :: [Text],
28 |   -- ^ Arguments to the builder.
29 |   derivEnv :: HashMap Text Text
30 |   -- ^ Environment to run the builder in.
31 |   } deriving (Show, Eq, Generic)
32 | 
33 | newtype OutputName = OutputName {outputName::Text}
34 |   deriving (Show, Eq, Ord, Hashable, IsString)
35 | 
36 | -- | What is returned by nix-instantiate; the path to the derivation,
37 | -- plus optionally some output names.
38 | data DerivationAndOutputs
39 |   = DerivationAndOutputs !Derivation !(Maybe [OutputName])
40 | 
41 | newtype NoSuchOutput = NoSuchOutput OutputName
42 |   deriving (Show, Eq, Generic)
43 | 
44 | instance Exception NoSuchOutput
45 | 
46 | -- | Given a derivation and an output name, return the path that the
47 | -- output will correspond to.
48 | --
49 | -- For example, a derivation might be listed as having two outputs, "out"
50 | -- and "dev". Once that derivation is built (successfully), two paths
51 | -- will have been added to the nix store, one for each of the outputs.
52 | -- This function given the output name will produce the corresponding
53 | -- path that is expected to be built.
54 | --
55 | -- If the derivation doesn't provide the given output, Nothing is returned.
56 | lookupOutput :: Derivation -> OutputName -> Either NoSuchOutput StorePath
57 | lookupOutput Derivation{..} oname = case H.lookup oname derivOutputs of
58 |   Nothing -> Left $ NoSuchOutput oname
59 |   Just (path, _) -> Right path
60 | 


--------------------------------------------------------------------------------
/src/Nix/FileHash.hs:
--------------------------------------------------------------------------------
 1 | -- | Text representation of file hashes.
 2 | module Nix.FileHash where
 3 | 
 4 | import ClassyPrelude
 5 | import Database.SQLite.Simple.FromField (FromField(fromField))
 6 | import qualified Data.Text as T
 7 | 
 8 | -- | A representation of a hash, which expresses the type of
 9 | -- hash. This is encoded as a string in the form "<type>:<hash>",
10 | -- where <type> is sha256, sha1, or md5. The <hash> part might be
11 | -- encoded in hex or in base32. If a recursive hash, 'r:' is
12 | -- prepended to the string representation.
13 | data FileHash
14 |   = Sha256Hash Text -- ^ Hash computed with sha256.
15 |   | Sha1Hash Text -- ^ Hash computed with sha256.
16 |   | Md5Hash Text -- ^ Hash computed with sha256.
17 |   | RecursiveHash FileHash -- ^ Hash should be computed over a directory.
18 |   deriving (Show, Eq, Generic)
19 | 
20 | instance FromField FileHash where
21 |   fromField f = do
22 |     fileHashFromText <$> fromField f >>= \case
23 |       Right hash -> pure hash
24 |       Left err -> fail err
25 | 
26 | -- | Translate a file hash to text.
27 | fileHashToText :: FileHash -> Text
28 | fileHashToText = \case
29 |   Sha256Hash t -> "sha256:" <> t
30 |   Sha1Hash t -> "sha1:" <> t
31 |   Md5Hash t -> "md5:" <> t
32 |   RecursiveHash h -> "r:" <> fileHashToText h
33 | 
34 | -- | Translate text into a FileHash object.
35 | fileHashFromText :: Text -> Either String FileHash
36 | fileHashFromText txt = case T.split (==':') txt of
37 |   "r":rest -> RecursiveHash <$> fileHashFromText (intercalate ":" rest)
38 |   [hashtype, hash] -> getFileHashConstructor hashtype <*> pure hash
39 |   _ -> Left $ "Not a hash string: " <> show txt
40 | 
41 | -- | Given the identifier of a hash type, convert it into a FileHash
42 | -- constructor (or fail).
43 | getFileHashConstructor :: Text -> Either String (Text -> FileHash)
44 | getFileHashConstructor txt = case unpack txt of
45 |   'r':':':htype -> (RecursiveHash .) <$> go htype
46 |   htype -> go htype
47 |   where
48 |     go "sha256" = return Sha256Hash
49 |     go "sha1" = return Sha1Hash
50 |     go "md5" = return Md5Hash
51 |     go s = Left $ "Unknown hash type: " <> show s
52 | 


--------------------------------------------------------------------------------
/src/Nix/Nar.hs:
--------------------------------------------------------------------------------
 1 | -- | Nix store archives.
 2 | module Nix.Nar (
 3 |   module Nix.Nar.Types,
 4 |   module Nix.Nar.Serialization,
 5 |   module Nix.Nar.Subprocess
 6 |   ) where
 7 | 
 8 | import Nix.Nar.Types
 9 | import Nix.Nar.Serialization
10 | import Nix.Nar.Subprocess
11 | 


--------------------------------------------------------------------------------
/src/Nix/Nar/Serialization.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  2 | -- | Serialization of Nars and NarExports
  3 | module Nix.Nar.Serialization where
  4 | 
  5 | import ClassyPrelude hiding (take, try, Builder)
  6 | #ifdef USE_CEREAL
  7 | #define BINARY_CLASS Serialize
  8 | import Data.Serialize (Serialize(get, put), Put, Get, runGetLazy)
  9 | import Data.Serialize (putByteString, getByteString, execPut)
 10 | import Data.Serialize (getInt64le, putInt64le, label, lookAhead, skip)
 11 | #else
 12 | #define BINARY_CLASS Binary
 13 | import Data.Binary (Binary(put, get))
 14 | import Data.Binary.Get (Get, getInt64le, getByteString, skip, lookAhead, label)
 15 | import Data.Binary.Get (runGetOrFail)
 16 | import Data.Binary.Put (Put, putByteString, putInt64le, execPut)
 17 | #endif
 18 | import Data.ByteString.Builder (toLazyByteString)
 19 | import qualified Codec.Compression.Lzma as Lzma
 20 | import qualified Codec.Compression.GZip as GZip
 21 | import qualified Data.HashMap.Strict as H
 22 | import qualified Data.HashSet as HS
 23 | import qualified Data.ByteString as B
 24 | import qualified Data.ByteString.Char8 as B8
 25 | import qualified Data.ByteString.Lazy as BL
 26 | import Servant (MimeUnrender(..), OctetStream, MimeRender(..))
 27 | 
 28 | 
 29 | import Nix.StorePath (NixStoreDir(..), StorePath(..))
 30 | import Nix.StorePath (parseFullStorePath, spToFull)
 31 | import Nix.Nar.Types
 32 | 
 33 | -- | Wrap the Int64 type to create custom BINARY_CLASS instance
 34 | newtype NarInt = NarInt Int deriving (Show, Eq, Ord, Num)
 35 | 
 36 | -- NarInts are written as a 8 bytes in little endian format
 37 | instance BINARY_CLASS NarInt where
 38 |   put (NarInt n) = putInt64le $ fromIntegral n
 39 |   get = NarInt . fromIntegral <$> getInt64le
 40 | 
 41 | -- | Wrap to create custom BINARY_CLASS instance
 42 | newtype NarString = NarString ByteString deriving (Show, Eq, Ord, IsString)
 43 | instance BINARY_CLASS NarString where
 44 |   put (NarString s) = put (NarInt $ length s) *> putByteString (padTo8 s)
 45 |     where padTo8 bs | length bs `mod` 8 == 0 = bs
 46 |           padTo8 bs = bs <> replicate (8 - (length bs `mod` 8)) 0
 47 | 
 48 |   get = do
 49 |     -- Get the length of the string
 50 |     NarInt len <- get
 51 |     -- Read that many bytes
 52 |     result <- NarString <$> getByteString len
 53 |     -- Read any bytes remaining (padded to a multiple of 8)
 54 |     when (len `mod` 8 /= 0) $ do
 55 |       skip (8 - (len `mod` 8))
 56 |     pure result
 57 | 
 58 | -- | Convenience function to resolve type ambiguity.
 59 | putNS :: NarString -> Put
 60 | putNS = put
 61 | 
 62 | -- | Read a particular nar string, fail if it doesn't match
 63 | getExactNS :: NarString -> Get ()
 64 | getExactNS expected = do
 65 |   s <- get
 66 |   when (s /= expected) $ do
 67 |     fail ("expected string " <> show expected <> " but got " <> show s)
 68 | 
 69 | -- | Read an arbitrary nar string, and then convert it into a bytestring.
 70 | getSomeNS :: Get ByteString
 71 | getSomeNS = get >>= \(NarString s) -> pure s
 72 | 
 73 | -- | Read a particular bytestring (not nar string -- exact bytes)
 74 | getThisByteString :: ByteString -> Get ()
 75 | getThisByteString expected = do
 76 |   s <- getByteString (length expected)
 77 |   when (s /= expected) $ do
 78 |     fail ("expected string " <> show expected <> " but got " <> show s)
 79 | 
 80 | -- | Write a store directory and path into a Put monad.
 81 | putStorePath :: NixStoreDir -> StorePath -> Put
 82 | putStorePath sd sp = putNS $ NarString $ B8.pack $ spToFull sd sp
 83 | 
 84 | -- | Magic constant at the beginning of an export.
 85 | magicExportStartConstant :: ByteString
 86 | magicExportStartConstant = B.pack (1 : replicate 7 0)
 87 | 
 88 | -- | Magic constant to indicate start of export metadata.
 89 | magicExportMetadataConstant :: ByteString
 90 | magicExportMetadataConstant = "NIXE" <> B.pack (replicate 4 0)
 91 | 
 92 | -- | Parse a nar string into a store directory and store path.
 93 | getStorePath :: Get (NixStoreDir, StorePath)
 94 | getStorePath = do
 95 |   NarString s <- get
 96 |   case parseFullStorePath (decodeUtf8 s) of
 97 |     Left err -> fail err
 98 |     Right (sd, sp) -> pure (sd, sp)
 99 | 
100 | instance BINARY_CLASS NarElement where
101 |   put element = inParens internal where
102 |     inParens p = putNS "(" *> p *> putNS ")"
103 |     internal = case element of
104 |       NarSymLink target -> do
105 |         mapM_ putNS ["type", "symlink", "target", NarString target]
106 |       NarFile exec contents -> do
107 |         mapM_ putNS ["type", "regular"]
108 |         when (exec == Executable) $ do
109 |           mapM_ putNS ["executable", ""]
110 |         mapM_ putNS ["contents", NarString contents]
111 |       NarDirectory elements -> do
112 |         mapM_ putNS ["type", "directory"]
113 |         forM_ (sortOn fst $ H.toList elements) $ \(name, element) -> do
114 |           putNS "entry"
115 |           inParens $ do
116 |             mapM_ putNS ["name", NarString name, "node"]
117 |             put element
118 | 
119 |   get = label "NarElement" $ inParens element where
120 |     inParens p = label "openParens" (getExactNS "(") *> p
121 |                  <* label "closeParens" (getExactNS ")")
122 |     try' getter = lookAhead getter >> getter
123 |     many_ p results = (p >>= \result -> many_ p (result:results))
124 |                       <|> pure results
125 |     getDir = H.fromList <$> many_ entry [] where
126 |       entry = do
127 |         try' (getExactNS "entry")
128 |         inParens $ do
129 |           NarString name <- getExactNS "name" *> get
130 |           element <- getExactNS "node" *> get
131 |           pure (name, element)
132 |     element = do
133 |       getExactNS "type"
134 |       get >>= \case
135 |         "directory" -> NarDirectory <$> getDir
136 |         "symlink" -> NarSymLink <$> (getExactNS "target" *> getSomeNS)
137 |         "regular" -> do
138 |           isExecutable <- do
139 |             (try' (mapM getExactNS ["executable", ""]) *> pure Executable)
140 |               <|> pure NotExecutable
141 |           NarFile isExecutable <$> (getExactNS "contents" *> getSomeNS)
142 |         (t :: NarString) -> do
143 |           fail ("unsupported element type: " <> show t)
144 | 
145 | instance BINARY_CLASS Nar where
146 |   get = label "Nar" $ Nar <$> (getExactNS "nix-archive-1" *> get)
147 |   put (Nar elem) = putNS "nix-archive-1" >> put elem
148 | 
149 | instance BINARY_CLASS NarExport where
150 |   put export = do
151 |     let NarMetadata {..} = neMetadata export
152 |     -- Write the NAR surrounded by constants
153 |     putByteString magicExportStartConstant
154 |     put (neNar export)
155 |     putByteString magicExportMetadataConstant
156 | 
157 |     -- Write the store path
158 |     put (NarString $ B8.pack $ spToFull nmStoreDirectory nmStorePath)
159 | 
160 |     -- Write the references
161 |     put (NarInt $ length nmReferences)
162 |     forM (sort $ HS.toList nmReferences) $ \sp -> do
163 |       put (NarString $ B8.pack $ spToFull nmStoreDirectory sp)
164 | 
165 |     -- If there's a deriver, write it. Otherwise an empty string
166 |     put $ case nmDeriver of
167 |       Nothing -> ""
168 |       Just sp -> NarString $ B8.pack $ spToFull nmStoreDirectory sp
169 | 
170 |     -- If no signature, put 0, else 1 and then the signature
171 |     case nmSignature of
172 |       Nothing -> put (NarInt 0)
173 |       Just (Signature sig) -> put (NarInt 1) *> put (NarString sig)
174 | 
175 |     -- The end of the export is eight zeroes
176 |     putByteString $ B.replicate 8 0
177 | 
178 |   get = do
179 |     -- Read the NAR surrounded by constants
180 |     getThisByteString magicExportStartConstant
181 |     neNar <- get
182 |     getThisByteString magicExportMetadataConstant
183 | 
184 |     -- Get the store path of the exported object
185 |     (nmStoreDirectory, nmStorePath) <- getStorePath
186 |     -- Get the references
187 |     nmReferences <- HS.fromList <$> do
188 |       NarInt numReferences <- get
189 |       forM [0 .. (numReferences - 1)] $ \_ -> do
190 |         snd <$> getStorePath
191 |     -- Get the deriver (optional)
192 |     nmDeriver <- getSomeNS >>= \case
193 |       "" -> pure Nothing
194 |       raw -> case parseFullStorePath (decodeUtf8 raw) of
195 |         Left err -> fail err
196 |         Right (_, path) -> pure $ Just path
197 |     -- Get the signature (optional)
198 |     nmSignature <- get >>= \case
199 |       (0 :: NarInt) -> pure Nothing
200 |       1 -> Just . Signature <$> getSomeNS
201 |       n -> fail ("Expected either 0 or 1 before the signature, got " <> show n)
202 | 
203 |     -- Consume the final 8 bytes
204 |     getByteString 8
205 | 
206 |     pure $ NarExport neNar (NarMetadata {..})
207 | 
208 | -- Byte sequence that all xzips start with
209 | xzMagicHeader :: BL.ByteString
210 | xzMagicHeader = BL.pack [0xFD, 0x37, 0x7A, 0x58, 0x5A, 0x00]
211 | 
212 | -- Byte sequence that all gzips start with
213 | gzMagicHeader :: BL.ByteString
214 | gzMagicHeader = BL.pack [0x1f, 0x8b, 0x08]
215 | 
216 | data Uncompressed
217 |   = FromGZip BL.ByteString
218 |   | FromXZip BL.ByteString
219 |   | Wasn'tCompressed BL.ByteString
220 |   deriving (Show, Eq, Generic)
221 | 
222 | -- | Detect if the bytestring is compressed, and decompress it if so.
223 | decompressIfCompressed :: BL.ByteString -> BL.ByteString
224 | decompressIfCompressed bytes =
225 |   if BL.isPrefixOf xzMagicHeader bytes
226 |   then Lzma.decompress bytes
227 |   else if BL.isPrefixOf gzMagicHeader bytes
228 |   then GZip.decompress bytes
229 |   else bytes
230 | 
231 | runGet_ :: BINARY_CLASS a => BL.ByteString -> Either String a
232 | #ifdef USE_CEREAL
233 | runGet_ = runGetLazy get
234 | #else
235 | runGet_ bs = case runGetOrFail get bs of
236 |   Right (_, _, a) -> Right a
237 |   Left (_, _, err) -> Left err
238 | #endif
239 | 
240 | runPut_ :: BINARY_CLASS a => a -> BL.ByteString
241 | runPut_ = toLazyByteString . execPut . put
242 | 
243 | instance MimeRender OctetStream Nar where
244 |   mimeRender _ = runPut_
245 | 
246 | instance MimeUnrender OctetStream Nar where
247 |   mimeUnrender _ bs = runGet_ $ decompressIfCompressed bs
248 | 
249 | instance MimeRender OctetStream NarExport where
250 |   mimeRender _ = runPut_
251 | 
252 | instance MimeUnrender OctetStream NarExport where
253 |   mimeUnrender _ bs = runGet_ $ decompressIfCompressed bs
254 | 


--------------------------------------------------------------------------------
/src/Nix/Nar/Subprocess.hs:
--------------------------------------------------------------------------------
 1 | -- | Getting and registering NARs via subprocessing with the nix-store CLI.
 2 | module Nix.Nar.Subprocess where
 3 | 
 4 | import ClassyPrelude
 5 | 
 6 | import Nix.Nar.Types (Nar, NarExport(neMetadata), NarMetadata(nmStorePath))
 7 | import Nix.Nar.Serialization (runGet_, runPut_)
 8 | import Nix.Bin (NixBinDir, nixCmd)
 9 | import Nix.StorePath (StorePath, NixStoreDir, spToFull, spToPath)
10 | import qualified Data.ByteString.Lazy as BL
11 | 
12 | -- | Ask nix for an archive of a store object.
13 | getNar :: NixBinDir -> NixStoreDir -> StorePath -> IO Nar
14 | getNar nixBin nsdir spath = do
15 |   let path = spToFull nsdir spath
16 |   narBytes <- nixCmd nixBin "store" ["--dump", path] ""
17 |   case runGet_ (fromStrict narBytes) of
18 |     Right nar -> pure nar
19 |     Left err -> error $ concat ["In file " <> show path <> ":\n", err]
20 | 
21 | -- | Ask nix for an export of a store object.
22 | getNarExport :: NixBinDir -> NixStoreDir -> StorePath -> IO NarExport
23 | getNarExport nixBin nsdir spath = do
24 |   let path = spToFull nsdir spath
25 |   narBytes <- nixCmd nixBin "store" ["--export", path] ""
26 |   case runGet_ (fromStrict narBytes) of
27 |     Right nar -> pure nar
28 |     Left err -> error $ concat ["In file " <> show path <> ":\n", err]
29 | 
30 | -- | Import a nix export into the nix store.
31 | importNarExport :: NixBinDir -> NarExport -> IO ()
32 | importNarExport nixBin export = do
33 |   let path = nmStorePath $ neMetadata export
34 |       bytes = runPut_ export
35 |   nixCmd nixBin "store" ["--import"] bytes
36 |     `catch` \(e :: SomeException) -> do
37 |       let p = "/tmp/" <> spToPath path
38 |       putStrLn $ "writing bytes to " <> tshow p
39 |       BL.writeFile p bytes
40 |       error $ "When importing " <> show path <> ": " <> show e
41 | 


--------------------------------------------------------------------------------
/src/Nix/Nar/Types.hs:
--------------------------------------------------------------------------------
 1 | -- | Nix archives (Nar) and exports (NarExport)
 2 | module Nix.Nar.Types where
 3 | 
 4 | import ClassyPrelude hiding (take, try, Builder)
 5 | import qualified Data.ByteString as B
 6 | import qualified Data.ByteString.Base64 as B64
 7 | 
 8 | import Nix.StorePath (NixStoreDir, StorePath, PathSet)
 9 | 
10 | -- | An archived nix store object.
11 | newtype Nar = Nar NarElement deriving (Eq)
12 | 
13 | data IsExecutable = Executable | NotExecutable
14 |   deriving (Show, Eq, Generic)
15 | 
16 | -- | An archived nix store object.
17 | data NarElement
18 |   = NarDirectory (HashMap B.ByteString NarElement)
19 |   | NarFile IsExecutable B.ByteString
20 |   | NarSymLink B.ByteString
21 |   deriving (Show, Eq, Generic)
22 | 
23 | -- | Metadata associated with a NAR.
24 | data NarMetadata = NarMetadata {
25 |   nmStoreDirectory :: NixStoreDir,
26 |   nmStorePath :: StorePath,
27 |   nmReferences :: PathSet,
28 |   nmDeriver :: Maybe StorePath,
29 |   nmSignature :: Maybe Signature
30 |   } deriving (Show, Eq, Generic)
31 | 
32 | newtype KeyName = KeyName {unKeyName::Text}
33 |   deriving (Show, Eq, Generic, Hashable, IsString)
34 | 
35 | newtype Signature = Signature {unSignature::ByteString}
36 |   deriving (Show, Eq, Generic, Hashable, IsString)
37 | 
38 | data SignaturePair = SignaturePair !KeyName !Signature
39 |   deriving (Show, Eq, Generic)
40 | 
41 | -- Encode a keyname/signature pair
42 | signatureToBytes :: SignaturePair -> ByteString
43 | signatureToBytes (SignaturePair (KeyName key) (Signature sig)) = do
44 |   encodeUtf8 key <> ":" <> sig
45 | 
46 | parseSignaturePair :: ByteString -> Either String SignaturePair
47 | parseSignaturePair bs = do
48 |   let sep = fromIntegral $ fromEnum ':'
49 |   case B.split sep bs of
50 |     [key, bytes] -> do
51 |       decoded <- B64.decode bytes
52 |       Right (SignaturePair (KeyName $ decodeUtf8 key) (Signature decoded))
53 |     _ -> Left $ "Couldn't parse signature " <> show bs
54 | 
55 | -- | An exported nix archive
56 | data NarExport = NarExport {neNar :: Nar, neMetadata :: NarMetadata}
57 |   deriving (Eq, Generic, Show)
58 | 
59 | -- | Make a custom show instance so that we don't dump binary data to screen.
60 | instance Show Nar where show _ = "Nix archive"
61 | 


--------------------------------------------------------------------------------
/src/Nix/NarExport.hs:
--------------------------------------------------------------------------------
  1 | -- | Haskell abstraction for nix NAR exports.
  2 | module Nix.NarExport where
  3 | 
  4 | import ClassyPrelude
  5 | import qualified Data.ByteString.Char8 as B8
  6 | import qualified Data.ByteString.Lazy.Char8 as LB8
  7 | 
  8 | import Nix.Nar (Nar, narToBytestring, getNar)
  9 | import Nix.Bin (NixBinDir, getNixBinDir, nixCmd)
 10 | import Nix.StorePath (StorePath, NixStoreDir, spToFull,
 11 |                       ioParseFullStorePath, getNixStoreDir)
 12 | import Data.ByteString.Builder (toLazyByteString, word64LE, byteString)
 13 | 
 14 | data NarExport = NarExport {
 15 |   neStoreDir :: NixStoreDir,
 16 |   -- ^ Path to the nix store.
 17 |   neStorePath :: StorePath,
 18 |   -- ^ Path of the contained store object.
 19 |   neNar :: Nar,
 20 |   -- ^ Archived store object.
 21 |   neReferences :: [StorePath],
 22 |   -- ^ References of the object.
 23 |   neDeriver :: Maybe StorePath
 24 |   -- ^ Path to the derivation that produced the store object.
 25 |   } deriving (Show, Eq, Generic)
 26 | 
 27 | -- | Load a nar export from disk. Note that we could do this by just
 28 | -- calling `nix-store --export`; however, since we know how to construct
 29 | -- an export one with more type safety, we can do this here.
 30 | getExport :: NixBinDir -> NixStoreDir -> StorePath -> IO NarExport
 31 | getExport nixBin storeDir spath = do
 32 |   let full = spToFull storeDir spath
 33 |   nar <- getNar nixBin storeDir spath
 34 |   -- Get references and deriver info from nix-store.
 35 |   refs <- nixCmd nixBin "store" ["--query", "--references", full]
 36 |   deriver <- nixCmd nixBin "store" ["--query", "--deriver", full] >>= \case
 37 |     "unknown-deriver\n" -> pure Nothing
 38 |     path -> Just . snd <$> ioParseFullStorePath path
 39 |   pure NarExport {neStoreDir = storeDir, neStorePath = spath,
 40 |                   neNar = nar, neReferences = refs, neDeriver = deriver}
 41 | 
 42 | -- | Get an export using the default nix store and bin paths.
 43 | getExport' :: StorePath -> IO NarExport
 44 | getExport' spath = do
 45 |   nixBin <- getNixBinDir
 46 |   storeDir <- getNixStoreDir
 47 |   getExport nixBin storeDir spath
 48 | 
 49 | -- | Get an export as a raw bytestring from the nix-store command.
 50 | getExportRaw :: NixBinDir -> NixStoreDir -> StorePath -> IO ByteString
 51 | getExportRaw nixBin storeDir spath = do
 52 |   nixCmd nixBin "store" ["--export", spToFull storeDir spath]
 53 | 
 54 | getExportRaw' :: StorePath -> IO ByteString
 55 | getExportRaw' spath = do
 56 |   nixBin <- getNixBinDir
 57 |   storeDir <- getNixStoreDir
 58 |   getExportRaw nixBin storeDir spath
 59 | 
 60 | 
 61 | -- | Magic number nix expects at the beginning of an export.
 62 | _EXPORT_MAGIC_1 :: ByteString
 63 | _EXPORT_MAGIC_1 = "\x01\x00\x00\x00\x00\x00\x00\x00"
 64 | 
 65 | -- Another magic 8-byte number that comes after the NAR.
 66 | _EXPORT_MAGIC_2 :: ByteString
 67 | _EXPORT_MAGIC_2 = "NIXE\x00\x00\x00\x00"
 68 | 
 69 | -- | Convert a NarExport to a ByteString.
 70 | --
 71 | -- Nix exports are a binary format. The logic of this function
 72 | -- serializes the NarExport, including:
 73 | --
 74 | -- * An 8-byte magic header, which nix-store reads when it imports.
 75 | -- * The bytes of the NAR itself.
 76 | -- * Another magic bytestring, which is 'NIXE' followed by four nulls.
 77 | -- * The path to the object in the nix store being imported.
 78 | -- * The number of references.
 79 | -- * The path of each reference.
 80 | -- * The deriver path, if known (else an empty string).
 81 | -- * 8 empty bytes, to indicate we're not including a signature.
 82 | -- * 8 empty bytes, for reasons unknown to me but needed by nix-store.
 83 | --
 84 | -- A note on string encoding:
 85 | --
 86 | -- Each string referenced above (e.g. paths) is represented by
 87 | -- first writing its length as an integer encoded in
 88 | -- little-endian 8 bytes, then the string itself, and then as
 89 | -- many null bytes as are needed to get to the nearest multiple
 90 | -- of 8 bytes. So for example, the string "hello" would be
 91 | -- represented as
 92 | --
 93 | --   "\x05\NUL\NUL\NUL\NUL\NUL\NUL\NULhello\NUL\NUL\NUL"
 94 | --
 95 | -- Note that there are three zeros following the "hello" text, in
 96 | -- order to pad it to eight bytes.
 97 | narExportToBytestring :: NarExport -> LB8.ByteString
 98 | narExportToBytestring NarExport{..} = toLazyByteString $ concat $ [
 99 |   -- Magic 8-byte number nix expects at the beginning of an export.
100 |   byteString _EXPORT_MAGIC_1,
101 |   -- Bytes of the nar itself.
102 |   byteString $ narToBytestring neNar,
103 |   -- Another magic 8-byte number that comes after the NAR.
104 |   byteString _EXPORT_MAGIC_2,
105 |   -- Store path of the object being archived.
106 |   addStorePath neStorePath,
107 |   -- Add the number of references.
108 |   addInt $ length neReferences
109 |   -- Add the paths of references, sorted lexicographically.
110 |   ] <> map addStorePath (sort neReferences) <> [
111 |   -- Add the deriver if it's known, otherwise an empty string.
112 |   maybe (addString "") addStorePath neDeriver,
113 |   -- Add 16 zeros: 8 to indicate no signature, and then another 8 to
114 |   -- indicate the end of the export.
115 |   byteString $ replicate 16 0
116 |   ] where
117 |     addInt i = word64LE (fromIntegral i)
118 |     -- Implementing the string-encoding logic described above.
119 |     addString str = concat [
120 |         -- Add the length of a string, represented in 8 bytes.
121 |         addInt (length str)
122 |         -- Add the string.
123 |       , byteString str
124 |         -- Add padding if necessary, to make the total length a multiple of 8.
125 |       , byteString $ let padding = 8 - (length str `mod` 8) in
126 |         if (padding < 8) then replicate padding 0 else ""
127 |       ]
128 |     addStorePath sp = addString $! B8.pack $! spToFull neStoreDir sp
129 | 


--------------------------------------------------------------------------------
/src/Nix/NarInfo.hs:
--------------------------------------------------------------------------------
  1 | -- | Haskell representation of NAR information.
  2 | module Nix.NarInfo where
  3 | 
  4 | import ClassyPrelude
  5 | import Data.KVMap
  6 | import Data.Attoparsec.ByteString.Lazy (Result(..), parse)
  7 | import qualified Data.Text as T
  8 | 
  9 | import Servant (MimeUnrender(..), ToHttpApiData(..), OctetStream)
 10 | 
 11 | import Nix.StorePath (StorePrefix(StorePrefix))
 12 | import Nix.FileHash (FileHash(..), fileHashFromText)
 13 | import Nix.Nar.Types (SignaturePair, parseSignaturePair)
 14 | 
 15 | -- | Nix archive info. This returns metadata about an object that the
 16 | -- binary cache can serve to a client.
 17 | data NarInfo = NarInfo {
 18 |   storePath :: FilePath, -- ^ Path of the store object.
 19 |   narHash :: FileHash, -- ^ Hash of the nix archive.
 20 |   narSize :: Int, -- ^ Size of the nix archive.
 21 |   fileSize :: Int, -- ^ Size of the uncompressed store object.
 22 |   fileHash :: FileHash, -- ^ Hash of the uncompressed store object.
 23 |   narReq :: NarRequest, -- ^ How to request this NAR.
 24 |   compression :: NarCompressionType, -- ^ How this NAR is compressed.
 25 |   references :: [FilePath], -- ^ Other store objects this references.
 26 |   deriver :: Maybe FilePath, -- ^ The derivation file for this object.
 27 |   sig :: Maybe SignaturePair -- Possible signature of the cache.
 28 |   } deriving (Show, Eq, Generic)
 29 | 
 30 | instance FromKVMap NarInfo where
 31 |   fromKVMap (KVMap kvm) = do
 32 |     let lookupE key = case lookup key kvm of
 33 |           Nothing -> Left $ "No key " <> show key <> " was present."
 34 |           Just val -> return val
 35 |         parseNonNegInt txt = case readMay txt of
 36 |           Just n | n >= 0 -> Right n
 37 |           _ -> Left $ show txt <> " is not a non-negative integer"
 38 |         parseNarRequest compType txt = do
 39 |           let suf = compTypeToExt compType
 40 |           case "nar/" `T.isPrefixOf` txt of
 41 |             False -> Left "Expected nar req to start with 'nar/'"
 42 |             True -> case suf `T.isSuffixOf` txt of
 43 |               False -> Left $ "Expected nar req to end with " <> show suf
 44 |               True -> do
 45 |                 let narPath = T.drop 4 $ T.dropEnd (length suf) txt
 46 |                 return $ NarRequest narPath compType
 47 | 
 48 |     storePath <- T.unpack <$> lookupE "StorePath"
 49 |     narHash <- lookupE "NarHash" >>= fileHashFromText
 50 |     narSize <- lookupE "NarSize" >>= parseNonNegInt
 51 |     fileSize <- lookupE "FileSize" >>= parseNonNegInt
 52 |     fileHash <- lookupE "FileHash" >>= fileHashFromText
 53 |     compression <- lookupE "Compression" >>= parseCompressionType
 54 |     narReq <-  lookupE "URL" >>= parseNarRequest compression
 55 |     let splitWS = filter (/= "") . T.split (flip elem [' ', '\t', '\n', '\r'])
 56 |         references = case lookup "References" kvm of
 57 |           Nothing -> []
 58 |           Just refs -> map T.unpack $ splitWS refs
 59 |         deriver = Nothing
 60 |     sig <- case lookup "Sig" kvm of
 61 |              Nothing -> pure Nothing
 62 |              Just sigTxt -> Just <$> parseSignaturePair (encodeUtf8 sigTxt)
 63 |     return $ NarInfo storePath narHash narSize fileSize fileHash
 64 |                narReq compression references deriver sig
 65 | 
 66 | instance MimeUnrender OctetStream NarInfo where
 67 |   mimeUnrender _ bstring = case parse parseKVMap bstring of
 68 |     Done _ kvmap -> fromKVMap kvmap
 69 |     Fail _ _ message -> Left message
 70 | 
 71 | -- | Types of compression supported for NAR archives.
 72 | data NarCompressionType = NarBzip2 | NarXzip
 73 |   deriving (Show, Eq, Generic)
 74 | 
 75 | -- | Convert a compression type into a filename extension.
 76 | compTypeToExt :: NarCompressionType -> Text
 77 | compTypeToExt NarBzip2 = ".nar.bz2"
 78 | compTypeToExt NarXzip = ".nar.xz"
 79 | 
 80 | -- | Convert a compression type string.
 81 | parseCompressionType :: Text -> Either String NarCompressionType
 82 | parseCompressionType = \case
 83 |   "xz" -> return NarXzip
 84 |   "xzip" -> return NarXzip
 85 |   "bz2" -> return NarBzip2
 86 |   "bzip2" -> return NarBzip2
 87 |   ctype -> Left (show ctype <> " is not a known compression type.")
 88 | 
 89 | -- | Request for a nix archive.
 90 | -- The first argument is some sort of key that the server provides (as
 91 | -- a response to the .narinfo route) for how to fetch the package. The
 92 | -- second argument is the compression type.
 93 | data NarRequest = NarRequest Text NarCompressionType
 94 |   deriving (Show, Eq, Generic)
 95 | 
 96 | -- | Store prefixes are used to request NAR information.
 97 | instance ToHttpApiData NarRequest where
 98 |   toUrlPiece (NarRequest key ctype) = key <> compTypeToExt ctype
 99 | 
100 | -- | Requesting information about a nix archive, by providing its store prefix.
101 | newtype NarInfoReq = NarInfoReq StorePrefix
102 | 
103 | -- | Store prefixes are used to request NAR information.
104 | instance ToHttpApiData NarInfoReq where
105 |   toUrlPiece (NarInfoReq (StorePrefix prefix)) = prefix <> ".narinfo"
106 | 


--------------------------------------------------------------------------------
/src/Nix/ReferenceCache.hs:
--------------------------------------------------------------------------------
  1 | -- | Cache store paths and their references
  2 | module Nix.ReferenceCache (
  3 |   ReferenceCache(..),
  4 |   newReferenceCache, initializeReferenceCache,
  5 |   getReferences, getReferencesIncludeSelf, computeClosure,
  6 |   addPath, recordReferences, getDeriver, recordDeriver,
  7 |   getSignature, recordSignature
  8 |   ) where
  9 | 
 10 | import Database.SQLite.Simple (Connection, Query, Only(..), lastInsertRowId)
 11 | import Database.SQLite.Simple (open, execute_, execute, query, query_)
 12 | import qualified Data.HashMap.Strict as H
 13 | import qualified Data.HashSet as HS
 14 | import qualified Data.Text as T
 15 | import System.FilePath (takeDirectory)
 16 | import System.Environment (lookupEnv)
 17 | 
 18 | import Nix.Cache.Common hiding (log)
 19 | import Nix.Bin (NixBinDir(..), getNixBinDir, nixCmd)
 20 | import Nix.Nar.Types (SignaturePair(..), Signature(..), KeyName(..))
 21 | import Nix.StorePath (NixStoreDir(..), PathTree, PathSet, StorePath, spToText)
 22 | import Nix.StorePath (getNixStoreDir, spToFull, parseStorePath, spToPath)
 23 | import Nix.StorePath (ioParseStorePath)
 24 | 
 25 | -- | Figure out where to access the local nix state DB.
 26 | getNixDBDir :: IO FilePath
 27 | getNixDBDir = lookupEnv "NIX_DB_DIR" >>= \case
 28 |   Just dir -> pure dir
 29 |   Nothing -> lookupEnv "NIX_STATE_DIR" >>= \case
 30 |     Just stateDir -> pure (stateDir </> "nix" </> "db" </> "db.sqlite")
 31 |     Nothing -> do
 32 |       NixBinDir d <- getNixBinDir
 33 |       pure $ takeDirectory (takeDirectory (takeDirectory d))
 34 |          </> "var" </> "nix" </> "db" </> "db.sqlite"
 35 | 
 36 | -- | Figure out the location in which to put the cache.
 37 | getPathCacheLocation :: IO FilePath
 38 | getPathCacheLocation = lookupEnv "CLIENT_SQLITE_CACHE" >>= \case
 39 |   Just location -> pure location
 40 |   Nothing -> lookupEnv "HOME" >>= \case
 41 |     Nothing -> error "HOME variable isn't set"
 42 |     Just home -> pure (home </> ".nix-client-cache")
 43 | 
 44 | -- | Path reference cache, backed by sqlite
 45 | data ReferenceCache = ReferenceCache {
 46 |   -- | Location of the nix store.
 47 |   nprcStoreDir :: NixStoreDir,
 48 |   -- | Connection to the local nix database (optional).
 49 |   nprcLocalNixDbConnection :: Maybe Connection,
 50 |   -- | Location on disk for nix binaries.
 51 |   nprcBinDir :: NixBinDir,
 52 |   -- | Location of the cache SQLite database.
 53 |   nprcCacheLocation :: FilePath,
 54 |   -- | Database connection for the local cache. Syncronized in MVar to
 55 |   -- allow lastrowid to be deterministic.
 56 |   nprcConnection :: MVar Connection,
 57 |   -- | Map store paths to their database row ID, so that we don't have to
 58 |   -- look them up all the time.
 59 |   nprcPathIdCache :: MVar (HashMap StorePath Int64),
 60 |   -- | Computed store path dependency tree.
 61 |   nprcPathReferences :: MVar PathTree,
 62 |   -- | Computed store path derivers. Not all paths have known derivers.
 63 |   nprcPathDerivers :: MVar (HashMap StorePath (Maybe StorePath)),
 64 |   -- | Signatures. Each path can have up to one signature per public key.
 65 |   nprcPathSignatures :: MVar (HashMap StorePath (HashMap KeyName Signature)),
 66 |   -- | Logging function.
 67 |   nprcLogger :: Maybe (Text -> IO ())
 68 |   }
 69 | 
 70 | log :: ReferenceCache -> Text -> IO ()
 71 | log cache msg = case nprcLogger cache of
 72 |   Nothing -> pure ()
 73 |   Just logger -> logger msg
 74 | 
 75 | -- | Attempt to connect to the local SQLite nix database. If the
 76 | -- connection fails, or it doesn't have a ValidPaths table, return Nothing.
 77 | attemptLocalNixConnection :: FilePath -> IO (Maybe Connection)
 78 | attemptLocalNixConnection dbpath = do
 79 |   putStrLn $ "Attempting local nix DB connection on DB path " <> tshow dbpath
 80 |   conn <- open dbpath
 81 |   let test = query_ conn "select count(*) from ValidPaths" :: IO [Only Int]
 82 |   (Just conn <$ test) `catch` \(err::SomeException) -> do
 83 |     putStrLn $ "Can't use local nix SQLite database: " <> tshow err
 84 |     pure Nothing
 85 | 
 86 | newReferenceCache :: IO ReferenceCache
 87 | newReferenceCache = do
 88 |   nprcCacheLocation <- getPathCacheLocation
 89 |   nprcLocalNixDbConnection <- attemptLocalNixConnection =<< getNixDBDir
 90 |   nprcStoreDir <- getNixStoreDir
 91 |   nprcBinDir <- getNixBinDir
 92 |   nprcConnection <- newMVar =<< open nprcCacheLocation
 93 |   nprcPathIdCache <- newMVar mempty
 94 |   nprcPathReferences <- newMVar mempty
 95 |   nprcPathDerivers <- newMVar mempty
 96 |   nprcPathSignatures <- newMVar mempty
 97 |   let nprcLogger = pure putStrLn
 98 |   pure ReferenceCache {..}
 99 | 
100 | -- | Get the references of an object by asking either a nix command or the DB.
101 | -- This information is cached by the caller of this function.
102 | getReferencesUncached :: ReferenceCache -> StorePath -> IO (Maybe PathSet)
103 | getReferencesUncached cache spath = case nprcLocalNixDbConnection cache of
104 |   -- We can't access the DB directly. Use the CLI.
105 |   Nothing -> do
106 |     let storeDir = nprcStoreDir cache
107 |         args = ["--query", "--references", spToFull storeDir spath]
108 |     map (Just . HS.fromList) (nixCmd (nprcBinDir cache) "store" args "")
109 |       `catch` \(_::SomeException) -> pure Nothing
110 |   -- Pull the references directly out of the database.
111 |   Just conn -> do
112 |     -- Ensure it's in the nix DB by getting its ID
113 |     let qry = "select id from ValidPaths where path = ?"
114 |     let row = (Only $ spToFull (nprcStoreDir cache) spath)
115 |     log cache $ "Running query " <> tshow qry <> " with path " <> tshow row
116 |     query conn qry row >>= \case
117 |       [Only (nixPathId :: Int64)] -> do
118 |         refs <- query conn getPathsQuery (Only nixPathId)
119 |         map (Just . HS.fromList) $
120 |           mapM ioParseStorePath (map fromOnly refs)
121 |       _ -> pure Nothing
122 | 
123 | -- | Get a store path's deriver from the cache, and update the cache.
124 | --
125 | -- Note the return type here:
126 | -- * If the store path isn't in the database, we'll return Nothing
127 | -- * If it's in the database, but has no deriver, we'll return (Just Nothing)
128 | -- * Otherwise, we'll return (Just (Just <deriver path>))
129 | getDeriver :: ReferenceCache -> StorePath -> IO (Maybe (Maybe StorePath))
130 | getDeriver cache spath = do
131 |   let
132 |     getUncached = case nprcLocalNixDbConnection cache of
133 |       -- We can't access the DB directly. Use the CLI.
134 |       Nothing -> do
135 |         let storeDir = nprcStoreDir cache
136 |             args = ["--query", "--deriver", spToFull storeDir spath]
137 |             cmd = nixCmd (nprcBinDir cache) "store" args "" >>= \case
138 |               "unknown-deriver" -> pure (Just Nothing)
139 |               path -> Just . Just <$> ioParseStorePath path
140 |         catch cmd (\(_::SomeException) -> pure Nothing)
141 |       -- Pull the deriver directly out of the database.
142 |       Just conn -> do
143 |         -- Ensure it's in the nix DB by getting its ID
144 |         let qry = "select id, deriver from ValidPaths where path = ?"
145 |         let row = (Only $ spToFull (nprcStoreDir cache) spath)
146 |         log cache $ "Running query " <> tshow qry <> " with path " <> tshow row
147 |         query conn qry row >>= \case
148 |           [Only (Just deriverTxt)] -> Just . Just <$> ioParseStorePath deriverTxt
149 |           [Only Nothing] -> pure (Just Nothing)
150 |           _ -> pure Nothing
151 | 
152 |     getFromCache = do
153 |       modifyMVar (nprcPathDerivers cache) $ \derivers -> do
154 |         case H.lookup spath derivers of
155 |           Just maybeDeriver -> pure (derivers, Just maybeDeriver)
156 |           Nothing -> getPathId cache spath >>= \case
157 |             Nothing -> pure (derivers, Nothing)
158 |             Just pathId -> do
159 |               conn <- readMVar (nprcConnection cache)
160 |               let qry = "select deriver from Paths where id = ?"
161 |               query conn qry (Only pathId) >>= \case
162 |                 -- If references have been recorded, parse and return them
163 |                 [Only (Just deriverText)] -> do
164 |                   mDeriver <- case deriverText of
165 |                                 "unknown-deriver" -> pure Nothing
166 |                                 path -> Just <$> ioParseStorePath path
167 |                   pure (H.insert spath mDeriver derivers, Just mDeriver)
168 |                 _ -> pure (derivers, Nothing)
169 | 
170 |   getFromCache >>= \case
171 |     Just result -> pure $ Just result
172 |     Nothing -> do
173 |       log cache $ "no cached deriver for " <> tshow spath
174 |       getUncached >>= \case
175 |         Nothing -> pure Nothing
176 |         Just maybeDeriver -> do
177 |           addPath cache spath
178 |           recordDeriver cache spath maybeDeriver
179 |           pure $ Just maybeDeriver
180 | 
181 | -- | Get the full runtime path dependency closure of a store path.
182 | computeClosure :: ReferenceCache -> StorePath -> IO PathSet
183 | computeClosure cache path = HS.fromList <$> do
184 |   let storeDir = nprcStoreDir cache
185 |   nixCmd (nprcBinDir cache) "store" ["-qR", spToFull storeDir path] ""
186 | 
187 | -- | Query which will return all of the references of a path.
188 | getPathsQuery :: Query
189 | getPathsQuery = fromString $ concat [
190 |   "select path from ValidPaths inner join (",
191 |   "select reference from ValidPaths inner join Refs on id = referrer where id = ?",
192 |   ") on id = reference"
193 |   ]
194 | 
195 | -- | Get the references of a path, checking and updating the cache.
196 | -- Doesn't filter out self-references.
197 | getReferencesIncludeSelf :: ReferenceCache -> StorePath -> IO (Maybe PathSet)
198 | getReferencesIncludeSelf cache spath = do
199 |   let
200 |     getCached = do
201 |       modifyMVar (nprcPathReferences cache) $ \tree -> do
202 |         case H.lookup spath tree of
203 |           Just refs -> pure (tree, Just refs)
204 |           Nothing -> getPathId cache spath >>= \case
205 |             Nothing -> pure (tree, Nothing)
206 |             Just pathId -> do
207 |               conn <- readMVar (nprcConnection cache)
208 |               let qry = "select refs from Paths where id = ?"
209 |               query conn qry (Only pathId) >>= \case
210 |                 -- If references have been recorded, parse and return them
211 |                 [Only (Just refs)] -> do
212 |                   let refTexts = T.words refs
213 |                   refs <- map HS.fromList $ forM refTexts $ \txt -> do
214 |                     case parseStorePath txt of
215 |                       Right path -> pure path
216 |                       Left err -> error $ "When parsing references of path "
217 |                                        <> spToPath spath <> ": " <> err
218 |                   pure (H.insert spath refs tree, Just refs)
219 |                 _ -> pure (tree, Nothing)
220 | 
221 |   getCached >>= \case
222 |     Just refs -> pure $ Just refs
223 |     Nothing -> do
224 |       log cache $ "no cached reference set for " <> tshow spath
225 |       getReferencesUncached cache spath >>= \case
226 |         Nothing -> pure Nothing
227 |         Just refs -> do
228 |           recordReferences cache spath refs
229 |           pure $ Just refs
230 | 
231 | -- | Get a store path's references, excluding self-references.
232 | getReferences :: ReferenceCache -> StorePath -> IO (Maybe PathSet)
233 | getReferences cache path = do
234 |   map (HS.delete path) <$> getReferencesIncludeSelf cache path
235 | 
236 | -- | Get a store path's ID. Caches in memory.
237 | getPathId :: ReferenceCache -> StorePath -> IO (Maybe Int64)
238 | getPathId cache path = do
239 |   modifyMVar (nprcPathIdCache cache) $ \pathIdCache -> do
240 |     case H.lookup path pathIdCache of
241 |       Just pathId -> pure (pathIdCache, Just pathId)
242 |       Nothing -> do
243 |         let row = (Only $ spToText path)
244 |         conn <- readMVar (nprcConnection cache)
245 |         query conn "select id from Paths where path = ?" row >>= \case
246 |           [Only pathId'] -> do
247 |             pure (H.insert path pathId' pathIdCache, Just pathId')
248 |           _ -> do
249 |             pure (pathIdCache, Nothing)
250 | 
251 | -- | Store the references of a path. Caches in memory and in the DB.
252 | recordReferences :: ReferenceCache -> StorePath -> PathSet -> IO ()
253 | recordReferences cache path refs = do
254 |   pathId <- addPath cache path
255 |   modifyMVar_ (nprcPathReferences cache) $ \tree -> do
256 |     case H.lookup path tree of
257 |       Just refs' | refs == refs' -> pure tree
258 |       Just _ -> error $ "Inconsistent reference lists for path " <> show path
259 |       Nothing -> do
260 |         -- First insert them into the database, then add to the cache
261 |         withMVar (nprcConnection cache) $ \conn -> do
262 |           let refsText = intercalate " " $ map spToText $ HS.toList refs
263 |               qry = "update Paths set refs = ? where id = ?"
264 |           execute conn qry (refsText, pathId)
265 |           pure $ H.insert path refs tree
266 | 
267 | -- | Record a path's deriver.
268 | recordDeriver :: ReferenceCache -> StorePath -> Maybe StorePath -> IO ()
269 | recordDeriver cache path mDeriver = do
270 |   pathId <- addPath cache path
271 |   modifyMVar_ (nprcPathDerivers cache) $ \derivers -> do
272 |     let storeDir = nprcStoreDir cache
273 |         mDeriverTxt = case mDeriver of
274 |           Just dpath -> spToFull storeDir dpath
275 |           Nothing -> "unknown-deriver"
276 |         qry = "update Paths set deriver = ? where id = ?"
277 |         add = withMVar (nprcConnection cache) $ \conn -> do
278 |           execute conn qry (mDeriverTxt, pathId)
279 |           pure $ H.insert path mDeriver derivers
280 |     case H.lookup path derivers of
281 |       -- Case 1: we don't have a deriver path (or lack thereof)
282 |       -- recorded, so update the database and cache
283 |       Nothing -> add
284 |       -- Case 2: we have recorded that there's no deriver, but now
285 |       -- we *do* have a deriver. Update the cache.
286 |       Just Nothing | isJust mDeriver -> add
287 |       -- Case 3: we already have a deriver path (or lack thereof)
288 |       -- recorded, and this doesn't add any new information. Leave
289 |       -- things unchanged.
290 |       _ -> pure derivers
291 | 
292 | getSignature :: ReferenceCache -> StorePath -> KeyName -> IO (Maybe Signature)
293 | getSignature cache spath key@(KeyName name) = do
294 |   pathId <- addPath cache spath
295 |   let
296 |     readFromDB = do
297 |       conn <- readMVar (nprcConnection cache)
298 |       let sql = fromString $
299 |             "select signature from Signatures inner join Paths " <>
300 |             "on path_id = id where id = ? and key_name = ?"
301 |       query conn (fromString sql) (pathId, name) >>= \case
302 |         [Only signature] -> pure $ Just (Signature signature)
303 |         _ -> pure Nothing
304 |   modifyMVar (nprcPathSignatures cache) $ \sigs -> do
305 |     case H.lookup spath sigs of
306 |       Just sigsByKey -> case H.lookup key sigsByKey of
307 |         -- in the outer map and inner map
308 |         Just sigBytes -> pure (sigs, Just sigBytes)
309 |         -- in the outer map but not inner map
310 |         Nothing -> readFromDB >>= \case
311 |           -- not in the database: give up
312 |           Nothing -> pure (sigs, Nothing)
313 |           -- in the database
314 |           Just sigBytes -> do
315 |             let sigsByKey' = H.insert key sigBytes sigsByKey
316 |             pure (H.insert spath sigsByKey' sigs, Just sigBytes)
317 |       -- not in the outer map
318 |       Nothing -> readFromDB >>= \case
319 |         Nothing -> pure (sigs, Nothing)
320 |         Just sigBytes -> do
321 |           pure (H.insert spath (H.singleton key sigBytes) sigs, Just sigBytes)
322 | 
323 | 
324 | recordSignature :: ReferenceCache -> StorePath -> SignaturePair -> IO ()
325 | recordSignature cache spath (SignaturePair key sig) = do
326 |   pathId <- addPath cache spath
327 |   let
328 |     recordInDB = withMVar (nprcConnection cache) $ \conn -> do
329 |       let qry = fromString $
330 |             "insert or ignore into Signatures " <>
331 |             "(path_id, key_name, signature) values (?, ?, ?)"
332 |       execute conn qry (pathId, unKeyName key, unSignature sig)
333 | 
334 |   modifyMVar_ (nprcPathSignatures cache) $ \signatures -> do
335 |     case H.lookup spath signatures of
336 |       Just sigsByKey -> case H.lookup key sigsByKey of
337 |         Just sig' | sig == sig' -> pure signatures
338 |         Just sig' | otherwise -> error $ concat [
339 |           "Conflicting signatures for ", show spath, ": ", show sig',
340 |           " is stored, but trying to store new signature ", show sig
341 |           ]
342 |         Nothing -> do
343 |           recordInDB
344 |           pure (H.insert spath (H.insert key sig sigsByKey) signatures)
345 |       Nothing -> do
346 |         recordInDB
347 |         pure (H.insert spath (H.singleton key sig) signatures)
348 | 
349 | -- | Add a store path (if it's not there yet) and get its ID. There are
350 | -- basically three cases here:
351 | --
352 | -- 1. In the in-memory cache: just return it.
353 | -- 2. In the database: add the ID to the in-memory cache, return it.
354 | -- 3. Not in the database: add it to the database, add new ID to the
355 | --    in-memory cache, and return it.
356 | addPath :: ReferenceCache -> StorePath -> IO Int64
357 | addPath cache path = do
358 |   modifyMVar (nprcPathIdCache cache) $ \pathIdCache -> do
359 |     case H.lookup path pathIdCache of
360 |       Just pathId -> pure (pathIdCache, pathId)
361 |       Nothing -> do
362 |         let row = (Only $ spToText path)
363 |         pathId <- withMVar (nprcConnection cache) $ \conn -> do
364 |           query conn "select id from Paths where path = ?" row >>= \case
365 |             [Only pathId'] -> pure pathId'
366 |             _ -> do
367 |               let row = Only (spToText path)
368 |               execute conn "insert into Paths (path) values (?)" row
369 |               lastInsertRowId conn
370 |         pure (H.insert path pathId pathIdCache, pathId)
371 | 
372 | 
373 | -- | Create the tables in the path cache
374 | initializeReferenceCache :: ReferenceCache -> IO ()
375 | initializeReferenceCache nprc = do
376 |   withMVar (nprcConnection nprc) $ \conn -> do
377 |     execute_ conn $ fromString $
378 |       "create table if not exists Paths " <>
379 |       "(id integer primary key, path text unique not null, " <>
380 |       "refs text, deriver text)"
381 | 
382 |     execute_ conn $ fromString $
383 |       "create table if not exists Signatures " <>
384 |       "(path_id integer not null references Paths(id) on delete cascade, " <>
385 |       "key_name text not null, signature text not null, " <>
386 |       "constraint one_sig_per_key_per_path unique " <>
387 |       "(path_id, key_name, signature))"
388 | 


--------------------------------------------------------------------------------
/src/Nix/StorePath.hs:
--------------------------------------------------------------------------------
  1 | -- | Haskell representation of nix store paths.
  2 | module Nix.StorePath where
  3 | 
  4 | import ClassyPrelude hiding (try)
  5 | import Data.Aeson (ToJSON, FromJSON)
  6 | import Data.HashSet (HashSet)
  7 | import Servant (MimeUnrender(..), OctetStream)
  8 | import Servant.HTML.Lucid (HTML)
  9 | import System.Environment (getEnv)
 10 | import System.FilePath (takeFileName, takeDirectory, isAbsolute)
 11 | import System.Process (readCreateProcess, shell)
 12 | import Text.Regex.PCRE.Heavy (scan, re)
 13 | import qualified Data.Text as T
 14 | import qualified Data.Text.Encoding as T
 15 | 
 16 | import Nix.Bin (NixCmdReturn(nixCmd))
 17 | 
 18 | -- | The nix store directory.
 19 | newtype NixStoreDir = NixStoreDir FilePath
 20 |   deriving (Show, Eq, Generic, Hashable, IsString, ToJSON, FromJSON)
 21 | 
 22 | -- | The 32-character prefix of an object in the nix store.
 23 | newtype StorePrefix = StorePrefix Text
 24 |   deriving (Show, Eq, Ord, Generic, Hashable, IsString)
 25 | 
 26 | -- | The hash and name of an object in the nix store.
 27 | data StorePath = StorePath {spPrefix :: StorePrefix, spName :: Text}
 28 |   deriving (Eq, Ord, Generic)
 29 | 
 30 | instance Show StorePath where
 31 |   show (StorePath (StorePrefix prefix) name) = unpack (prefix <> "-" <> name)
 32 | 
 33 | instance Hashable StorePath
 34 | 
 35 | -- | A dependency tree, represented as a mapping from a store path to
 36 | -- its set of (immediate, not transitive) dependent paths.
 37 | type PathTree = HashMap StorePath PathSet
 38 | 
 39 | -- | A set of store paths.
 40 | type PathSet = HashSet StorePath
 41 | 
 42 | -- | Path to an object in the nix store.
 43 | type FullStorePath = (NixStoreDir, StorePath)
 44 | 
 45 | -- | Read the NIX_STORE variable to get the path to the nix store.
 46 | getNixStoreDir :: IO NixStoreDir
 47 | getNixStoreDir = NixStoreDir <$> getEnv "NIX_STORE"
 48 | 
 49 | -- | Parse a nix store path from text. The input text should be a
 50 | -- basepath, not a full path (i.e., it should not be
 51 | -- '/nix/store/xyz-foo', but instead should be 'xyz-foo').
 52 | parseStorePath :: Text -> Either String StorePath
 53 | parseStorePath txt =
 54 |   case scan [re|^([\w\d]{32})-(.*)|] txt of
 55 |     [(_, [StorePrefix -> hash, name])] -> Right $ StorePath hash name
 56 |     _ -> Left $ show txt <> " does not appear to be a store basepath"
 57 | 
 58 | -- | Parse a store path. The source can be either a full (absolute)
 59 | -- path or a store (base) path.
 60 | permissiveParseStorePath :: Text -> Either String StorePath
 61 | permissiveParseStorePath txt = do
 62 |   case (parseStorePath txt, parseFullStorePath txt) of
 63 |     (Right spath, _) -> pure spath
 64 |     (_, Right (_, spath)) -> pure spath
 65 |     (Left err1, Left err2) -> Left $ concat [
 66 |       "Not a base store path (", show err1, ") and not an absolute ",
 67 |       "store path (", show err2, ")"
 68 |       ]
 69 | 
 70 | -- | Parse a store path from text. Probably not super efficient but oh well.
 71 | parseFullStorePath :: Text -> Either String FullStorePath
 72 | parseFullStorePath (T.unpack -> p) = case (takeDirectory p, takeFileName p) of
 73 |   (d, _) | not (isAbsolute d) -> do
 74 |     Left ("store path must be absolute: " <> show d <> " (" <> p <> ")")
 75 |   (_, "") -> Left ("basename of store path " <> show p <> " is empty")
 76 |   (storeDir, base) -> do
 77 |     storePath <- parseStorePath (T.pack base)
 78 |     pure (NixStoreDir storeDir, storePath)
 79 | 
 80 | -- | Parse a StorePath in the IO monad. The input can be absolute or base.
 81 | ioParseStorePath :: MonadIO io => Text -> io StorePath
 82 | ioParseStorePath txt = liftIO $ case permissiveParseStorePath txt of
 83 |   Left err -> error err
 84 |   Right sp -> return sp
 85 | 
 86 | -- | Parse a full store path in the IO monad.
 87 | ioParseFullStorePath :: MonadIO io => Text -> io FullStorePath
 88 | ioParseFullStorePath txt = liftIO $ case parseFullStorePath txt of
 89 |   Left err -> error err
 90 |   Right result -> return result
 91 | 
 92 | -- | Given a nix store dir and a store path, produce a full file path.
 93 | spToFull :: NixStoreDir -> StorePath -> FilePath
 94 | spToFull (NixStoreDir storeDir) p = storeDir </> spToPath p
 95 | 
 96 | -- | Same as above, but uses a FullStorePath, when that's more concise.
 97 | spToFull' :: FullStorePath -> FilePath
 98 | spToFull' = uncurry spToFull
 99 | 
100 | -- | Convert a StorePath to Text.
101 | spToText :: StorePath -> Text
102 | spToText (StorePath (StorePrefix hash) name) = hash <> "-" <> name
103 | 
104 | -- | Convert a StorePath to a FilePath.
105 | spToPath :: StorePath -> FilePath
106 | spToPath = unpack . spToText
107 | 
108 | -- | Find a nix store path by its store prefix. If multiple paths
109 | -- satisfy the prefix, the first one will be taken.
110 | findSpByPrefix :: Text -> IO StorePath
111 | findSpByPrefix prefix = do
112 |   NixStoreDir dir <- getNixStoreDir
113 |   let cmd = "ls " <> dir <> " | grep '^" <> unpack prefix <> "'"
114 |   result <- readCreateProcess (shell cmd) ""
115 |   case parseFullStorePath $ pack result of
116 |     Left err -> error err
117 |     Right (_, sp) -> return sp
118 | 
119 | -- | Find a nix store path by suffix. If multiple paths satisfy the
120 | -- suffix, the first one will be taken.
121 | findSpBySuffix :: Text -> IO StorePath
122 | findSpBySuffix prefix = do
123 |   NixStoreDir dir <- getNixStoreDir
124 |   let cmd = "ls " <> dir <> " | grep '" <> unpack prefix <> "$'"
125 |   result <- readCreateProcess (shell cmd) ""
126 |   case parseFullStorePath $ pack result of
127 |     Left err -> error err
128 |     Right (_, sp) -> return sp
129 | 
130 | -- | Find a nix store path by some text that appears in the path. If
131 | -- multiple paths satisfy the search, the first one will be taken.
132 | findSp :: Text -> IO StorePath
133 | findSp text = do
134 |   NixStoreDir dir <- getNixStoreDir
135 |   let cmd = "ls " <> dir <> " | grep '" <> unpack text <> "'"
136 |   result <- readCreateProcess (shell cmd) ""
137 |   case parseFullStorePath $ pack result of
138 |     Left err -> error err
139 |     Right (_, sp) -> return sp
140 | 
141 | -- | Return an abbreviated version of a store path, e.g. for
142 | -- debugging. Uses only the first 6 characters of the prefix.
143 | abbrevSP :: StorePath -> Text
144 | abbrevSP (StorePath (StorePrefix hash) name) = T.take 6 hash <> "-" <> name
145 | 
146 | instance MimeUnrender OctetStream StorePath where
147 |   mimeUnrender _ = map snd . parseFullStorePath . T.decodeUtf8 . toStrict
148 | 
149 | instance MimeUnrender HTML StorePath where
150 |   mimeUnrender _ = map snd . parseFullStorePath . T.decodeUtf8 . toStrict
151 | 
152 | instance NixCmdReturn FullStorePath where
153 |   nixCmd nixBin cmd args input = do
154 |     rawPath <- nixCmd nixBin cmd args input
155 |     ioParseFullStorePath rawPath
156 | 
157 | instance NixCmdReturn StorePath where
158 |   nixCmd nixBin cmd args input = do
159 |     ioParseStorePath =<< nixCmd nixBin cmd args input
160 | 
161 | instance NixCmdReturn [StorePath] where
162 |   nixCmd nixBin cmd args input = do
163 |     rawPaths <- nixCmd nixBin cmd args input
164 |     forM (T.lines rawPaths) $ \line ->
165 |       ioParseStorePath line
166 | 


--------------------------------------------------------------------------------
/tests/Data/KVMap/Tests.hs:
--------------------------------------------------------------------------------
 1 | module Data.KVMap.Tests where
 2 | 
 3 | import ClassyPrelude hiding (ByteString)
 4 | import Test.Hspec (Spec, describe, it, shouldBe)
 5 | import qualified Data.HashMap.Strict as H
 6 | import Data.Attoparsec.ByteString.Lazy
 7 | 
 8 | import Data.KVMap
 9 | 
10 | kvMapSpec :: Spec
11 | kvMapSpec = describe "KVMap" $ do
12 |   describe "parsing" $ do
13 |     let txt = "X: hey\nY: Yo!"
14 |         kvmap = KVMap $ H.fromList [
15 |           ("X", "hey"),
16 |           ("Y", "Yo!")
17 |           ]
18 |     it "should parse a kv map" $ do
19 |       case parse parseKVMap txt of
20 |         Done _ kvmap' -> kvmap' `shouldBe` kvmap
21 |         Fail _ _ message -> error message
22 | 


--------------------------------------------------------------------------------
/tests/Nix/Cache/Types/Tests.hs:
--------------------------------------------------------------------------------
 1 | -- | Tests related to the base types that support the nix cache.
 2 | module Nix.Cache.Types.Tests where
 3 | 
 4 | import ClassyPrelude hiding (ByteString)
 5 | import Test.QuickCheck (Arbitrary(..), oneof, property, elements)
 6 | import Data.ByteString.Lazy (ByteString)
 7 | import Data.Either (isLeft)
 8 | import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
 9 | import Servant
10 | 
11 | import Nix.Cache.Types
12 | import Nix.FileHash
13 | 
14 | instance Arbitrary Text where
15 |   arbitrary = fromString <$> arbitrary
16 | 
17 | instance Arbitrary FileHash where
18 |   arbitrary = do
19 |     let letters = ['a'..'f'] <> ['0'..'9']
20 |         str = replicateM 32 $ elements letters
21 |     oneof [Sha256Hash <$> str, Sha1Hash <$> str, Md5Hash <$> str,
22 |            RecursiveHash <$> arbitrary]
23 | 
24 | fileHashSpec :: Spec
25 | fileHashSpec = describe "file hashes" $ do
26 |   it "should parse from a string" $ do
27 |     property $ \hash -> do
28 |       let strRep = fileHashToText hash
29 |       fileHashFromText strRep `shouldBe` Right hash
30 | 
31 | nixCacheInfoSpec :: Spec
32 | nixCacheInfoSpec = describe "nix-cache-info" $ do
33 |   describe "parsing" $ do
34 |     let txt = "StoreDir: /test/store/dir"
35 |         info = NixCacheInfo {
36 |           storeDir = "/test/store/dir",
37 |           wantMassQuery = False,
38 |           priority = Nothing
39 |           }
40 |         unrender :: ByteString -> Either String NixCacheInfo
41 |         unrender = mimeUnrender (Proxy :: Proxy OctetStream)
42 |     it "should parse the storedir" $ do
43 |       unrender txt `shouldBe` Right info
44 |     it "should not have a problem with newlines" $ do
45 |       unrender (txt <> "\n") `shouldBe` Right info
46 |     it "should fail if the storedir isn't there" $ do
47 |       let bad = "StoreDerp: /test/store/derp"
48 |       unrender bad `shouldSatisfy` isLeft
49 |     it "should grab wantmassquery" $ do
50 |       let txt = "StoreDir: /x\nWantMassQuery: 1"
51 |           info = NixCacheInfo {
52 |             storeDir = "/x",
53 |             wantMassQuery = True,
54 |             priority = Nothing
55 |             }
56 |       unrender txt `shouldBe` Right info
57 |     it "should grab priority" $ do
58 |       let txt = "Priority: 23\nStoreDir: /x\nWantMassQuery: 1"
59 |           info = NixCacheInfo {
60 |             storeDir = "/x",
61 |             wantMassQuery = True,
62 |             priority = Just 23
63 |             }
64 |       unrender txt `shouldBe` Right info
65 | 


--------------------------------------------------------------------------------
/tests/Nix/Derivation/Tests.hs:
--------------------------------------------------------------------------------
 1 | module Nix.Derivation.Tests where
 2 | 
 3 | import ClassyPrelude
 4 | import qualified Data.Text as T
 5 | import Test.Hspec
 6 | import Test.RandomStrings (randomWord, randomASCII)
 7 | import qualified Data.HashMap.Strict as H
 8 | 
 9 | import Nix.Derivation
10 | import Nix.StorePath
11 | import Nix.Bin
12 | 
13 | -- | Create a minimal derivation in the nix store. Does not do
14 | -- resource cleanup! These files should be tiny though.
15 | createDeriv :: Text -> Text -> Text -> IO (NixStoreDir, StorePath, Derivation)
16 | createDeriv name builder system= do
17 |   let expr = concat ["derivation {name = ", show name, ";",
18 |                      "builder = ", show builder, ";",
19 |                      "system = ", show system, ";}"]
20 |   (storeDir, path) <- nixCmd' "instantiate" ["-E", expr]
21 |   deriv <- parseDerivFromPath storeDir path
22 |   return (storeDir, path, deriv)
23 | 
24 | createRandomDeriv :: IO (NixStoreDir, StorePath, Derivation)
25 | createRandomDeriv = do
26 |   name <- T.pack <$> randomWord randomASCII 10
27 |   builder <- T.pack <$> randomWord randomASCII 10
28 |   system <- T.pack <$> randomWord randomASCII 10
29 |   createDeriv name builder system
30 | 
31 | derivSpec :: Spec
32 | derivSpec = describe "derivations" $ do
33 |   it "should parse a derivation" $ do
34 |     name <- T.pack <$> randomWord randomASCII 10
35 |     builder <- T.pack <$> randomWord randomASCII 10
36 |     system <- T.pack <$> randomWord randomASCII 10
37 |     (_, _, deriv) <- createDeriv name builder system
38 |     H.size (derivEnv deriv) `shouldBe` 4
39 |     derivGetEnv "name" deriv `shouldBe` Just name
40 |     derivGetEnv "builder" deriv `shouldBe` Just builder
41 |     derivGetEnv "system" deriv `shouldBe` Just system
42 |     let Just out = derivGetEnv "out" deriv
43 |     outpath <- snd <$> ioParseFullStorePath out
44 |     derivGetOut "out" deriv `shouldBe` Just (outpath, Nothing)
45 | 
46 | 
47 | 
48 | -- parseAllDerivs :: IO ()
49 | -- parseAllDerivs = do
50 | --   nixStore <- getEnv "NIX_STORE"
51 | --   let isDeriv path = ".drv" `isSuffixOf` path
52 | --   derivs <- filter isDeriv <$> getDirectoryContents nixStore
53 | --   forM_ derivs $ \path ->
54 | --     parseDerivFile (nixStore </> path) >>= \case
55 | --       Left err -> error $ "In file " <> path <> ": " <> err
56 | --      _ -> return ()
57 | 


--------------------------------------------------------------------------------
/tests/Nix/NarExport/Tests.hs:
--------------------------------------------------------------------------------
 1 | -- | WIP: tests for narexport
 2 | module Nix.NarExport.Tests where
 3 | 
 4 | import ClassyPrelude
 5 | import Test.Hspec
 6 | 
 7 | import Nix.Bin
 8 | import Nix.StorePath
 9 | import Nix.Nar
10 | import Nix.NarExport
11 | import Nix.Derivation.Tests (createRandomDeriv)
12 | 
13 | narExportSpec :: Spec
14 | narExportSpec = describe "NarExport" $ do
15 |   it "should create an export" $ do
16 |     binDir <- getNixBinDir
17 |     -- Create a random derivation so we have something to play with
18 |     (sdir, dpath, _) <- createRandomDeriv
19 |     nar <- getNar binDir sdir dpath
20 |     export <- getExport binDir sdir dpath
21 |     neNar export `shouldBe` nar
22 |   it "should serialize the same as nix-store does" $ do
23 |     binDir <- getNixBinDir
24 |     -- Create a random derivation so we have something to play with
25 |     (sdir, dpath, _) <- createRandomDeriv
26 |     export <- getExport binDir sdir dpath
27 |     nsExport <- nixCmd binDir "store" ["--export", spToFull sdir dpath]
28 |     toStrict (narExportToBytestring export) `shouldBe` nsExport
29 | 


--------------------------------------------------------------------------------
/tests/Unit.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import ClassyPrelude
 4 | import Test.Hspec (hspec)
 5 | 
 6 | 
 7 | import qualified Nix.Cache.Types.Tests as TypesTests
 8 | import qualified Data.KVMap.Tests as KVMapTests
 9 | import qualified Data.ByteString.Char8 as B8
10 | import System.IO.Unsafe (unsafePerformIO)
11 | 
12 | import Nix.StorePath
13 | import Nix.Cache.Client
14 | import Nix.Derivation
15 | import Nix.Derivation.Tests
16 | import Nix.Nar
17 | import Nix.NarExport
18 | import Nix.NarExport.Tests
19 | import Nix.Bin
20 | 
21 | -- Define some things purely to suppress redundancy warnings
22 | type FOO1 = StorePath
23 | type FOO2 = NixCacheAuth
24 | type FOO3 = Derivation
25 | type FOO4 = NarExport
26 | foo1 :: NixStoreDir -> Derivation -> IO PathSet
27 | foo1 = derivInputs
28 | 
29 | spath :: StorePath
30 | spath = StorePath "00782dxdzwfi9306k1f6dj70g8ai8gx5" "python3.4-astroid-1.4.4"
31 | 
32 | sdir :: NixStoreDir
33 | sdir = unsafePerformIO getNixStoreDir
34 | 
35 | nbdir :: NixBinDir
36 | nbdir = unsafePerformIO getNixBinDir
37 | 
38 | export :: NarExport
39 | export = unsafePerformIO $ getExport' spath
40 | 
41 | exBytes :: ByteString
42 | exBytes = toStrict $ narExportToBytestring export
43 | 
44 | narBytes :: ByteString
45 | narBytes = narToBytestring $ neNar export
46 | 
47 | len :: Int
48 | len = length (_EXPORT_MAGIC_1 <> narBytes <> _EXPORT_MAGIC_2)
49 | 
50 | getn :: Int -> ByteString -> [Int]
51 | getn n = map fromEnum . B8.unpack . take n
52 | 
53 | rawExport :: ByteString
54 | rawExport = unsafePerformIO $ getExportRaw' spath
55 | 
56 | main :: IO ()
57 | main = hspec $ do
58 |   TypesTests.nixCacheInfoSpec
59 |   KVMapTests.kvMapSpec
60 |   TypesTests.fileHashSpec
61 |   derivSpec
62 |   narExportSpec
63 | 


--------------------------------------------------------------------------------