nix-serve-ng (empty) → 1.0.0
raw patch · 7 files changed
+1409/−0 lines, 7 filesdep +asyncdep +basedep +base16
Dependencies added: async, base, base16, base32, bytestring, charset, http-client, http-types, managed, megaparsec, mtl, network, optparse-applicative, tasty-bench, temporary, text, turtle, vector, wai, wai-extra, warp, warp-tls
Files
- LICENSE +10/−0
- benchmark/Main.hs +133/−0
- cbits/nix.cpp +219/−0
- nix-serve-ng.cabal +89/−0
- src/Main.hs +391/−0
- src/Nix.hsc +337/−0
- src/Options.hs +230/−0
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2022, Arista Networks, Inc.+All rights reserved.+ +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:+ + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+ * Neither the name of Arista Networks nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.+ +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ARISTA NETWORKS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ benchmark/Main.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedStrings #-}++{-| To benchmark `nix-serve-ng`, run the following commands:++ > $ nix build+ > $ PATH="./result/bin:${PATH}" cabal v1-bench --benchmark-option=--time-mode=wall++ You can compare against the old `nix-serve` by changing the first command+ to:++ > $ nix build --file '<nixpkgs>' nix-serve+-}+module Main where++import Control.Applicative (empty)+import Data.Foldable (traverse_)+import Data.Vector (Vector)+import Numeric.Natural (Natural)+import Turtle (d)++import qualified Control.Concurrent.Async as Async+import qualified Data.ByteString.Lazy as ByteString+import qualified Data.ByteString.Lazy.Char8 as Char8+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Network.HTTP.Client as HTTP+import qualified System.IO as IO+import qualified System.IO.Temp as Temp+import qualified Test.Tasty.Bench as Bench+import qualified Turtle++prepareMixed :: Natural -> IO (Vector FilePath)+prepareMixed maxSize =+ Temp.withSystemTempFile "zeros" \tempFile handle -> do+ IO.hClose handle++ let generate i = do+ let size =+ truncate+ ( fromIntegral maxSize+ ** (fromIntegral i / fromIntegral numFiles)+ :: Double+ )++ ByteString.writeFile tempFile (ByteString.replicate size 0)++ text <- Turtle.single do+ Turtle.inproc "nix-store"+ [ "--add", Text.pack tempFile ]+ empty++ return (Text.unpack (Turtle.lineToText text))++ Vector.generateM (fromIntegral numFiles) generate++prepareConstant :: Natural -> IO (Vector FilePath)+prepareConstant size =+ Temp.withSystemTempFile "zeros" \tempFile handle -> do+ IO.hClose handle++ ByteString.writeFile tempFile (ByteString.replicate (fromIntegral size) 0)++ text <- Turtle.single do+ Turtle.inproc "nix-store"+ [ "--add", Text.pack tempFile ]+ empty++ let path = Text.unpack (Turtle.lineToText text)++ return (Vector.replicate (fromIntegral numFiles) path)++port :: Int+port = 8000++numFiles :: Natural+numFiles = 10++runNixServe :: IO ()+runNixServe =+ Turtle.procs "nix-serve"+ [ "--quiet", "--port", Turtle.format d port ]+ empty++host :: String+host = "http://localhost:" <> show port++main :: IO ()+main = do+ manager <- HTTP.newManager HTTP.defaultManagerSettings++ Async.withAsync runNixServe \_ -> do+ let fetchNarInfo file = do+ let hash = take 32 (drop 11 file)++ request <- HTTP.parseRequest (host <> "/" <> hash <> ".narinfo")++ response <- HTTP.httpLbs request manager++ return (HTTP.responseBody response)++ let fetchNar file = do+ bytes <- fetchNarInfo file++ let relativePath =+ ( Char8.unpack+ . ByteString.drop 5+ . (!! 1)+ . Char8.lines+ ) bytes++ request <- HTTP.parseRequest (host <> "/" <> relativePath)++ response <- HTTP.httpLbs request manager++ return (HTTP.responseBody response)++ Bench.defaultMain+ [ Bench.env (prepareMixed 10000000) \files -> do+ Bench.bench ("fetch present NAR info ×" <> show numFiles)+ (Bench.nfAppIO (traverse_ fetchNarInfo) files)+ , Bench.bench "fetch absent NAR info ×1"+ (Bench.nfAppIO fetchNarInfo "/nix/store/00000000000000000000000000000000")+ , Bench.env (prepareConstant 0) \files -> do+ Bench.bench ("fetch empty NAR ×" <> show numFiles)+ (Bench.nfAppIO (traverse_ fetchNar) files)+ , Bench.env (prepareConstant 10000000) \files -> do+ Bench.bench ("fetch 10 MB NAR ×" <> show numFiles)+ (Bench.nfAppIO (traverse_ fetchNar) files)+ , Bench.env (prepareMixed 10000000) \files -> do+ Bench.bench ("fetch NARs of mixed sizes up to 10 MB ×" <> show numFiles)+ (Bench.nfAppIO (traverse_ fetchNar) files)+ ]
+ cbits/nix.cpp view
@@ -0,0 +1,219 @@+#include <cstddef>+#include <cstdlib>+#include <nix/store-api.hh>+#include <nix/log-store.hh>+#include "nix.hh"++using namespace nix;++// Copied from:+//+// https://github.com/NixOS/nix/blob/2.8.1/perl/lib/Nix/Store.xs#L24-L37+static ref<Store> getStore()+{+ static std::shared_ptr<Store> _store;++ if (!_store) {+ loadConfFile();++ _store = openStore();+ }++ return ref<Store>(_store);+}++extern "C" {++void freeString(struct string * const input)+{+ free((void *) input->data);+}++}++// TODO: Perhaps use convention where destination is first argument+void copyString(std::string const input, struct string * const output)+{+ size_t const size = input.size();++ char * data = (char *) calloc(size, sizeof(char));++ input.copy(data, size);++ output->size = size;++ output->data = data;+}++static const struct string emptyString = { .data = NULL, .size = 0 };++extern "C" {++void freeStrings(struct strings * const input)+{+ size_t size = input->size;++ for (size_t i = 0; i < size; i++) {+ freeString(&input->data[i]);+ }+}++}++void copyStrings+ ( std::vector<std::string> input+ , struct strings * const output+ )+{+ size_t const size = input.size();++ struct string * data = (struct string *) calloc(input.size(), sizeof(struct string));++ for (size_t i = 0; i < size; i++) {+ copyString(input[i], &data[i]);+ }++ output->data = data;++ output->size = size;+}++extern "C" {++void getStoreDir(struct string * const output)+{+ copyString(settings.nixStore, output);+}++void queryPathFromHashPart+ ( char const * const hashPart+ , struct string * const output+ )+{+ ref<Store> store = getStore();++ std::optional<StorePath> path = store->queryPathFromHashPart(hashPart);++ if (path.has_value()) {+ copyString(store->printStorePath(path.value()), output);+ } else {+ *output = emptyString;+ }+}++void queryPathInfo+ ( char const * const storePath+ , PathInfo * const output+ )+{+ ref<Store> store = getStore();++ ref<ValidPathInfo const> const validPathInfo =+ store->queryPathInfo(store->parseStorePath(storePath));++ std::optional<StorePath const> const deriver = validPathInfo->deriver;++ if (deriver.has_value()) {+ copyString(store->printStorePath(deriver.value()), &output->deriver);+ } else {+ output->deriver = emptyString;+ };++ copyString(validPathInfo->narHash.to_string(Base32, true), &output->narHash);++ output->narSize = validPathInfo->narSize;++ std::vector<std::string> references(validPathInfo->references.size());++ std::transform(+ validPathInfo->references.begin(),+ validPathInfo->references.end(),+ references.begin(),+ [=](StorePath storePath) { return store->printStorePath(storePath); }+ );++ copyStrings(references, &output->references);++ std::vector<std::string> sigs(validPathInfo->sigs.begin(), validPathInfo->sigs.end());++ copyStrings(sigs, &output->sigs);+}++void freePathInfo(struct PathInfo * const input)+{+ freeString(&input->deriver);+ freeString(&input->narHash);+ freeStrings(&input->references);+ freeStrings(&input->sigs);+}++// TODO: This can be done in Haskell using the `ed25519` package+void signString+ ( char const * const secretKey+ , char const * const message+ , struct string * const output+ )+{+ std::string signature = SecretKey(secretKey).signDetached(message);++ copyString(signature, output);+}++bool dumpPath+ ( char const * const hashPart+ , bool (* const callback)(char const * const data, size_t const size)+ )+{+ ref<Store> store = getStore();++ std::optional<StorePath> storePath =+ store->queryPathFromHashPart(hashPart);++ if (storePath.has_value()) {+ LambdaSink sink([=](std::string_view v) {+ bool succeeded = (*callback)(v.data(), v.size());++ if (!succeeded) {+ // We don't really care about the error message. The only+ // reason for throwing an exception here is that this is the+ // only way that a Nix sink can exit early.+ throw std::runtime_error("");+ }+ });++ try {+ store->narFromPath(storePath.value(), sink);+ } catch (const std::runtime_error & e) {+ // Intentionally do nothing. We're only using the exception as a+ // short-circuiting mechanism.+ }++ return true;+ } else {+ return false;+ }+}++void dumpLog(char const * const baseName, struct string * const output) {+ ref<Store> store = getStore();++ StorePath storePath(baseName);++ auto subs = getDefaultSubstituters();++ subs.push_front(store);++ *output = emptyString;++ for (auto & sub : subs) {+ LogStore * logStore = dynamic_cast<LogStore *>(&*sub);++ std::optional<std::string> log = logStore->getBuildLog(storePath);++ if (log.has_value()) {+ copyString(log.value(), output);+ }+ }+}++}
+ nix-serve-ng.cabal view
@@ -0,0 +1,89 @@+cabal-version: 3.0+name: nix-serve-ng+version: 1.0.0+synopsis:+ A drop-in replacement for nix-serve that's faster and more stable++license: BSD-3-Clause+license-file: LICENSE+author: Arista Networks+maintainer: opensource@awakesecurity.com+copyright: 2022 Arista Networks++executable nix-serve+ hs-source-dirs: src++ main-is: Main.hs++ other-modules: Nix+ , Options++ -- https://nixos.org/manual/nix/stable/installation/supported-platforms.html+ if arch(x86_64) && os(linux)+ cxx-options: -DSYSTEM="x86_64-linux"+ elif arch(aarch64) && os(linux)+ cxx-options: -DSYSTEM="aarch64-linux"+ elif arch(aarch64) && os(darwin)+ cxx-options: -DSYSTEM="aarch64-darwin"+ elif arch(x86_64) && os(darwin)+ cxx-options: -DSYSTEM="x86_64-darwin"+ else+ buildable: False++ include-dirs: cbits++ cxx-sources: cbits/nix.cpp++ cxx-options: -std=c++17++ build-depends: base < 5+ , base16+ , base32+ , bytestring+ , charset+ , http-types+ , managed+ , megaparsec+ , mtl+ , network+ , optparse-applicative+ , vector+ , wai+ , wai-extra+ , warp+ , warp-tls++ pkgconfig-depends:+ nix-store++ if os(darwin)+ extra-libraries: c+++ elif os(linux)+ extra-libraries: stdc+++ else+ buildable: False++ default-language: Haskell2010++ ghc-options: -Wall -threaded -O2 -rtsopts++benchmark benchmark+ hs-source-dirs: benchmark++ main-is: Main.hs++ type: exitcode-stdio-1.0++ build-depends: base+ , async+ , bytestring+ , http-client+ , text+ , turtle+ , tasty-bench+ , temporary+ , vector++ default-language: Haskell2010++ ghc-options: -Wall -O2 -threaded
+ src/Main.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import Data.CharSet.ByteSet (ByteSet(..))+import Data.Function ((&))+import Network.Socket (SockAddr(..))+import Network.Wai (Application)+import Nix (NoSuchPath(..), PathInfo(..))+import Numeric.Natural (Natural)+import Options (Options(..), Socket(..), SSL(..), Verbosity(..))++import qualified Control.Exception as Exception+import qualified Control.Monad as Monad+import qualified Control.Monad.Except as Except+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ByteString.Char8+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Lazy as ByteString.Lazy+import qualified Data.CharSet.ByteSet as ByteSet+import qualified Data.Vector as Vector+import qualified Data.Void as Void+import qualified Network.HTTP.Types as Types+import qualified Network.Socket as Socket+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as WarpTLS+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger+import qualified Nix+import qualified Options+import qualified Options.Applicative as Options+import qualified System.Environment as Environment++data ApplicationOptions = ApplicationOptions+ { priority :: Integer+ , storeDirectory :: ByteString+ , secretKey :: Maybe ByteString+ }++-- https://github.com/NixOS/nix/blob/2.8.1/src/libutil/hash.cc#L83-L84+validHashPartBytes :: ByteSet+validHashPartBytes =+ ByteSet.fromList+ ( [ 0x30 .. 0x39 ] -- 0..9+ <> [ 0x61 .. 0x64 ] -- abcd+ <> [ 0x66 .. 0x6E ] -- fghijklmn+ <> [ 0x70 .. 0x73 ] -- pqrs+ <> [ 0x76 .. 0x7A ] -- vwxyz+ )++validHashPart :: ByteString -> Bool+validHashPart hash = ByteString.all (`ByteSet.member` validHashPartBytes) hash++makeApplication :: ApplicationOptions -> Application+makeApplication ApplicationOptions{..} request respond = do+ let stripStore = ByteString.stripPrefix (storeDirectory <> "/")++ let done = Except.throwError++ let internalError message = do+ let headers = [ ("Content-Type", "text/plain") ]++ let builder = "Internal server error: " <> message <> ".\n"++ let response =+ Wai.responseBuilder+ Types.status500+ headers+ builder++ done response++ let noSuchPath = do+ let headers = [ ("Content-Type", "text/plain") ]++ let builder = "No such path.\n"++ let response =+ Wai.responseBuilder+ Types.status404+ headers+ builder++ done response++ let invalidPath = do+ let headers = [ ("Content-Type", "text/plain") ]++ let builder = "Invalid path.\n"++ let response =+ Wai.responseBuilder+ Types.status400+ headers+ builder++ done response++ result <- Except.runExceptT do+ let rawPath = Wai.rawPathInfo request++ if | Just prefix <- ByteString.stripSuffix ".narinfo" rawPath+ , Just hashPart <- ByteString.stripPrefix "/" prefix -> do+ Monad.unless (ByteString.length hashPart == 32 && validHashPart hashPart) do+ invalidPath++ maybeStorePath <- liftIO (Nix.queryPathFromHashPart hashPart)++ storePath <- case maybeStorePath of+ Left NoSuchPath -> noSuchPath+ Right storePath -> return storePath++ pathInfo@PathInfo{..} <- liftIO (Nix.queryPathInfo storePath)++ narHash2 <- case ByteString.stripPrefix "sha256:" narHash of+ Nothing -> do+ internalError "NAR hash missing sha256: prefix"+ Just narHash2 -> do+ return narHash2++ referenceNames <- case traverse stripStore references of+ Nothing -> do+ internalError "references missing store directory prefix"+ Just names -> do+ return names++ let referencesBuilder+ | not (Vector.null referenceNames) =+ "References:"+ <> foldMap (\name -> " " <> Builder.byteString name) referenceNames+ <> "\n"+ | otherwise =+ mempty++ deriverBuilder <-+ case deriver of+ Just d ->+ case stripStore d of+ Just name ->+ return+ ( "Deriver: "+ <> Builder.byteString name+ <> "\n"+ )++ Nothing -> do+ internalError "deriver missing store directory prefix"++ Nothing ->+ return mempty++ fingerprint <- case Nix.fingerprintPath storePath pathInfo of+ Nothing -> internalError "invalid NAR hash"+ Just builder -> do+ return (ByteString.Lazy.toStrict (Builder.toLazyByteString builder))++ signatures <- case secretKey of+ Just key -> do+ signature <- liftIO (Nix.signString key fingerprint)++ return (Vector.singleton signature)++ Nothing -> do+ return sigs++ let buildSignature signature =+ "Sig: " <> Builder.byteString signature <> "\n"++ let builder =+ "StorePath: "+ <> Builder.byteString storePath+ <> "\nURL: nar/"+ <> Builder.byteString hashPart+ <> "-"+ <> Builder.byteString narHash2+ <> ".nar\nCompression: none\nNarHash: "+ <> Builder.byteString narHash+ <> "\nNarSize: "+ <> Builder.word64Dec narSize+ <> "\n"+ <> referencesBuilder+ <> deriverBuilder+ <> foldMap buildSignature signatures++ let size =+ ( ByteString.Lazy.toStrict+ . Builder.toLazyByteString+ . Builder.int64Dec+ . ByteString.Lazy.length+ . Builder.toLazyByteString+ ) builder++ let headers =+ [ ("Content-Type", "text/x-nix-narinfo")+ , ("Content-Length", size)+ ]++ let response =+ Wai.responseBuilder+ Types.status200+ headers+ builder++ done response++ | Just prefix <- ByteString.stripSuffix ".nar" rawPath+ , Just interior <- ByteString.stripPrefix "/nar/" prefix -> do+ let interiorLength = ByteString.length interior++ (hashPart, maybeExpectedNarHash) <- if+ | interiorLength == 85+ , (hashPart, rest) <- ByteString.splitAt 32 interior+ , Just (0x2D, expectedNarHash) <- ByteString.uncons rest -> do+ return (hashPart, Just (ByteString.Char8.pack "sha256:" <> expectedNarHash))++ | interiorLength == 32 -> do+ return (interior, Nothing)++ | otherwise -> do+ invalidPath++ Monad.unless (validHashPart hashPart) do+ invalidPath++ maybeStorePath <- liftIO (Nix.queryPathFromHashPart hashPart)++ storePath <- case maybeStorePath of+ Left NoSuchPath-> noSuchPath+ Right storePath -> return storePath++ PathInfo{ narHash } <- liftIO (Nix.queryPathInfo storePath)++ Monad.unless (all (narHash ==) maybeExpectedNarHash) do+ let headers = [ ("Content-Type", "text/plain") ]++ let builder =+ "Incorrect NAR hash. Maybe the path has been recreated.\n"++ let response =+ Wai.responseBuilder+ Types.status404+ headers+ builder++ done response++ let streamingBody write flush = do+ result <- Nix.dumpPath hashPart callback++ case result of+ Left exception -> Exception.throwIO exception+ Right x -> return x+ where+ callback builder = do+ () <- write builder+ flush++ let headers = [ ("Content-Type", "text/plain") ]++ let response =+ Wai.responseStream Types.status200 headers streamingBody++ done response++ | Just suffix <- ByteString.stripPrefix "/log/" rawPath -> do+ let hashPart = ByteString.take 32 suffix++ Monad.unless (ByteString.length hashPart == 32 && validHashPart hashPart) do+ invalidPath++ maybeBytes <- liftIO (Nix.dumpLog suffix)++ bytes <- case maybeBytes of+ Nothing -> noSuchPath+ Just bytes -> return bytes++ let lazyBytes = ByteString.Lazy.fromStrict bytes++ let headers = [ ("Content-Type", "text/plain") ]++ let response =+ Wai.responseLBS Types.status200 headers lazyBytes++ done response++ | rawPath == "/nix-cache-info" -> do+ let headers = [ ("Content-Type", "text/plain") ]++ let builder =+ "StoreDir: "+ <> Builder.byteString storeDirectory+ <> "\nWantMassQuery: 1\nPriority: "+ <> Builder.integerDec priority+ <> "\n"++ let response =+ Wai.responseBuilder Types.status200 headers builder++ done response++ | otherwise -> do+ let headers = [ ("Content-Type", "text/plain") ]++ let builder = "File not found.\n"++ let response =+ Wai.responseBuilder Types.status404 headers builder++ done response++ case result of+ Left response -> respond response+ Right void -> Void.absurd void++toSocket :: Natural -> FilePath -> IO Socket.Socket+toSocket backlog path = do+ let family = Socket.AF_UNIX++ Monad.unless (Socket.isSupportedFamily family) do+ fail "Unix domain sockets are not supported on this system"++ socket <- Socket.socket family Socket.Stream Socket.defaultProtocol++ Socket.bind socket (SockAddrUnix path)++ Socket.listen socket (fromIntegral backlog)++ return socket++readSecretKey :: FilePath -> IO ByteString+readSecretKey = fmap ByteString.Char8.strip . ByteString.readFile++main :: IO ()+main = do+ options@Options{ priority, timeout, verbosity } <- do+ Options.execParser Options.parserInfo++ storeDirectory <- Nix.getStoreDir++ secretKeyFile <- Environment.lookupEnv "NIX_SECRET_KEY_FILE"++ secretKey <- traverse readSecretKey secretKeyFile++ let logger =+ case verbosity of+ Quiet -> id+ Normal -> RequestLogger.logStdout+ Verbose -> RequestLogger.logStdoutDev++ let application = logger (makeApplication ApplicationOptions{..})++ let sharedSettings =+ Warp.defaultSettings+ & Warp.setTimeout (fromIntegral timeout)++ case options of+ Options{ ssl = Disabled, socket = TCP{ host, port } } -> do+ let settings =+ sharedSettings+ & Warp.setHost host+ & Warp.setPort port++ Warp.runSettings settings application++ Options{ ssl = Disabled, socket = Unix{ backlog, path } } -> do+ socket <- toSocket backlog path++ Warp.runSettingsSocket sharedSettings socket application++ Options{ ssl = Enabled{ cert, key }, socket = TCP{ host, port } } -> do+ let tlsSettings = WarpTLS.tlsSettings cert key++ let settings =+ sharedSettings+ & Warp.setHost host+ & Warp.setPort port++ WarpTLS.runTLS tlsSettings settings application++ Options{ ssl = Enabled{ cert, key }, socket = Unix{ backlog, path } } -> do+ let tlsSettings = WarpTLS.tlsSettings cert key++ socket <- toSocket backlog path++ WarpTLS.runTLSSocket tlsSettings sharedSettings socket application
+ src/Nix.hsc view
@@ -0,0 +1,337 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Nix where++import Control.Applicative (empty)+import Control.Exception (Exception, SomeException)+import Control.Monad.Managed (Managed)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import Data.Vector (Vector)+import Data.Word (Word64)+import Foreign (FunPtr, Ptr, Storable(..))+import Foreign.C (CChar, CLong, CSize(..), CString)++import qualified Control.Exception as Exception+import qualified Control.Monad as Monad+import qualified Control.Monad.Managed as Managed+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Base32 as Base32+import qualified Data.ByteString.Builder as Builder+import qualified Data.IORef as IORef+import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as Vector.Storable+import qualified Foreign++#include "nix.hh"++foreign import ccall "freeString" freeString :: Ptr String_ -> IO ()++data String_ = String_ { data_ :: Ptr CChar, size :: CSize }++instance Storable String_ where+ sizeOf _ = #{size struct string}++ alignment _ = #{alignment struct string}++ peek pointer = do+ data_ <- #{peek struct string, data} pointer++ size <- #{peek struct string, size} pointer++ return String_{ data_, size }++ poke pointer String_{ data_, size } = do+ #{poke struct string, data} pointer data_++ #{poke struct string, size} pointer size++fromString_ :: String_ -> IO ByteString+fromString_ String_{ data_, size } =+ ByteString.packCStringLen (data_, fromIntegral @CSize @Int size)++toString_ :: ByteString -> Managed String_+toString_ bytes = do+ (data_, size) <- Managed.managed (ByteString.useAsCStringLen bytes)++ return String_{ data_, size = fromIntegral @Int @CSize size }++foreign import ccall "freeStrings" freeStrings :: Ptr Strings -> IO ()++data Strings = Strings+ { data_ :: Ptr String_+ , size :: CSize+ }++instance Storable Strings where+ sizeOf _ = #{size struct strings}++ alignment _ = #{alignment struct strings}++ peek pointer = do+ data_ <- #{peek struct strings, data} pointer++ size <- #{peek struct strings, size} pointer++ return Strings{ data_, size }++ poke pointer Strings{ data_, size } = do+ #{poke struct strings, data} pointer data_++ #{poke struct strings, size} pointer size++fromStrings :: Strings -> IO (Vector ByteString)+fromStrings Strings{ data_, size} = do+ foreignPointer <- Foreign.newForeignPtr_ data_++ let storableVector =+ Vector.Storable.unsafeFromForeignPtr0 foreignPointer+ (fromIntegral @CSize @Int size)++ traverse fromString_ (Vector.convert storableVector)++toStrings :: Vector ByteString -> Managed Strings+toStrings vector = do+ storableVector <- fmap Vector.convert (traverse toString_ vector)++ data_ <- Managed.managed (Vector.Storable.unsafeWith storableVector)++ let size = fromIntegral @Int @CSize (Vector.Storable.length storableVector)++ return Strings{ data_, size }++foreign import ccall "freePathInfo" freePathInfo :: Ptr CPathInfo -> IO ()++{-| We don't use the original @ValidPathInfo@ Nix type. Rather, the C FFI+ defines a @pathinfo@ struct that wraps a subset of what we need in a+ C-compatible API+-}+data CPathInfo = CPathInfo+ { deriver :: String_+ , narHash :: String_+ , narSize :: CLong+ , references :: Strings+ , sigs :: Strings+ }++instance Storable CPathInfo where+ sizeOf _ = #{size struct PathInfo}++ alignment _ = #{alignment struct PathInfo}++ peek pointer = do+ deriver <- #{peek struct PathInfo, deriver} pointer++ narHash <- #{peek struct PathInfo, narHash} pointer++ narSize <- #{peek struct PathInfo, narSize} pointer++ references <- #{peek struct PathInfo, references} pointer++ sigs <- #{peek struct PathInfo, sigs} pointer++ return CPathInfo{ deriver, narHash, narSize, references, sigs }++ poke pointer CPathInfo{ deriver, narHash, narSize, references, sigs } = do+ #{poke struct PathInfo, deriver} pointer deriver++ #{poke struct PathInfo, narHash} pointer narHash++ #{poke struct PathInfo, narSize} pointer narSize++ #{poke struct PathInfo, references} pointer references++ #{poke struct PathInfo, sigs} pointer sigs++data PathInfo = PathInfo+ { deriver :: Maybe ByteString+ , narHash :: ByteString+ , narSize :: Word64+ , references :: Vector ByteString+ , sigs :: Vector ByteString+ } deriving stock (Show)++fromCPathInfo :: CPathInfo -> IO PathInfo+fromCPathInfo CPathInfo{ deriver, narHash, narSize, references, sigs } = do+ deriver_ <-+ if data_ (deriver :: String_) == Foreign.nullPtr+ then return Nothing+ else fmap Just (fromString_ deriver)++ narHash_ <- fromString_ narHash++ references_ <- fromStrings references++ sigs_ <- fromStrings sigs++ return PathInfo+ { deriver = deriver_+ , narHash = narHash_+ , narSize = fromIntegral @CLong @Word64 narSize+ , references = references_+ , sigs = sigs_+ }++foreign import ccall "getStoreDir" getStoreDir_ :: Ptr String_ -> IO ()++getStoreDir :: IO ByteString+getStoreDir =+ Foreign.alloca \output -> do+ let open = getStoreDir_ output+ let close = freeString output+ Exception.bracket_ open close do+ string_ <- peek output+ fromString_ string_++data NoSuchPath = NoSuchPath+ deriving anyclass (Exception)+ deriving stock (Show)++foreign import ccall "queryPathFromHashPart" queryPathFromHashPart_+ :: CString -> Ptr String_ -> IO ()++queryPathFromHashPart :: ByteString -> IO (Either NoSuchPath ByteString)+queryPathFromHashPart hashPart = do+ ByteString.useAsCString hashPart \cHashPart -> do+ Foreign.alloca \output -> do+ let open = queryPathFromHashPart_ cHashPart output+ let close = freeString output+ Exception.bracket_ open close do+ string_@String_{ data_} <- peek output+ if data_ == Foreign.nullPtr+ then return (Left NoSuchPath)+ else fmap Right (fromString_ string_)++foreign import ccall "queryPathInfo" queryPathInfo_+ :: CString -> Ptr CPathInfo -> IO ()++queryPathInfo :: ByteString -> IO PathInfo+queryPathInfo storePath = do+ ByteString.useAsCString storePath \cStorePath -> do+ Foreign.alloca \output -> do+ let open = queryPathInfo_ cStorePath output+ let close = freePathInfo output+ Exception.bracket_ open close do+ cPathInfo <- peek output+ fromCPathInfo cPathInfo++fingerprintPath :: ByteString -> PathInfo -> Maybe Builder+fingerprintPath storePath PathInfo{ narHash, narSize, references } = do+ suffix <- ByteString.stripPrefix "sha256:" narHash++ base32Suffix <- if+ | ByteString.length suffix == 64+ , Right digest <- Base16.decodeBase16 suffix ->+ return (Base32.encodeBase32' digest)+ | ByteString.length suffix == 52 ->+ return suffix+ | otherwise ->+ empty++ return+ ( "1;"+ <> Builder.byteString storePath+ <> ";sha256:"+ <> Builder.byteString base32Suffix+ <> ";"+ <> Builder.word64Dec narSize+ <> ";"+ <> referencesBuilder+ )+ where+ referencesBuilder =+ case Vector.uncons references of+ Nothing ->+ mempty+ Just (r0, rs) ->+ Builder.byteString r0+ <> foldMap (\r -> "," <> Builder.byteString r) rs++foreign import ccall "signString" signString_+ :: CString -> CString -> Ptr String_ -> IO ()++signString :: ByteString -> ByteString -> IO ByteString+signString secretKey fingerprint =+ ByteString.useAsCString secretKey \cSecretKey ->+ ByteString.useAsCString fingerprint \cFingerprint ->+ Foreign.alloca \output -> do+ let open = signString_ cSecretKey cFingerprint output+ let close = freeString output+ Exception.bracket_ open close do+ string_ <- peek output+ fromString_ string_++foreign import ccall "dumpPath" dumpPath_+ :: CString -> FunPtr (Ptr CChar -> CSize -> IO Bool) -> IO Bool++dumpPath :: ByteString -> (Builder -> IO ()) -> IO (Either SomeException ())+dumpPath hashPart builderCallback = do+ result <- IORef.newIORef (Right ())++ let cCallback :: Ptr CChar -> CSize -> IO Bool+ cCallback pointer cSize = do+ let handler :: SomeException -> IO Bool+ handler exception = do+ IORef.writeIORef result (Left exception)+ return False++ Exception.handle handler do+ -- At the time of this writing Nix uses a maximum chunk size of+ -- 64 kibibytes, which could potentially increase in the future.+ -- However:+ --+ -- • Data.Int.Int guarantees `maxBound :: Int` supports at least+ -- 128 mebibytes+ -- • The latest version of GHC sets `maxBound :: Int` to+ -- support at least 2 gibibytes+ -- • On 64-bit systems (almost all systems nowadays)+ -- `maxBound :: Int` supports 8 exbibytes+ --+ -- … so even though this conversion could potentially overflow,+ -- it's unlikely to happen (and it's not even clear what we+ -- would do to fix the overflow anyway since the `bytestring`+ -- package requires an `Int` size).+ let len = fromIntegral @CSize @Int cSize++ byteString <- ByteString.packCStringLen (pointer, len)++ builderCallback (Builder.byteString byteString)++ return True++ wrappedCCallback <- wrapCallback cCallback++ ByteString.useAsCString hashPart \cHashPart -> do+ success <- dumpPath_ cHashPart wrappedCCallback++ Monad.when (not success) do+ IORef.writeIORef result (Left (Exception.toException NoSuchPath))++ IORef.readIORef result++foreign import ccall "dumpLog" dumpLog_+ :: CString -> Ptr String_ -> IO ()++dumpLog :: ByteString -> IO (Maybe ByteString)+dumpLog baseName = do+ ByteString.useAsCString baseName \cBaseName -> do+ Foreign.alloca \output -> do+ let open = dumpLog_ cBaseName output+ let close = freeString output+ Exception.bracket_ open close do+ string_@String_{ data_} <- peek output+ if data_ == Foreign.nullPtr+ then return Nothing+ else fmap Just (fromString_ string_)++foreign import ccall "wrapper" wrapCallback+ :: (Ptr CChar -> CSize -> IO Bool) -> IO (FunPtr (Ptr CChar -> CSize -> IO Bool))
+ src/Options.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Options where++import Control.Applicative (optional, (<|>))+import Data.String (IsString(..))+import Data.Void (Void)+import Network.Wai.Handler.Warp (HostPreference, Port)+import Numeric.Natural (Natural)+import Options.Applicative (Parser, ParserInfo, ReadM)+import Text.Megaparsec (Parsec)++import qualified Options.Applicative as Options+import qualified Text.Megaparsec as Megaparsec+import qualified Text.Megaparsec.Char.Lexer as Lexer++data Socket+ = TCP { host :: HostPreference, port :: Port }+ | Unix { backlog :: Natural, path :: FilePath }++data SSL = Disabled | Enabled { cert :: FilePath, key :: FilePath }++data Verbosity = Quiet | Normal | Verbose++data Options = Options+ { priority :: Integer+ , socket :: Socket+ , ssl :: SSL+ , timeout :: Natural+ , verbosity :: Verbosity+ }++parseCert :: Parser FilePath+parseCert =+ Options.strOption+ ( Options.long "ssl-cert"+ <> Options.help "The path to the SSL certificate file"+ <> Options.metavar "FILE"+ )++parseKey :: Parser FilePath+parseKey =+ Options.strOption+ ( Options.long "ssl-key"+ <> Options.help "The path to the SSL key file"+ <> Options.metavar "FILE"+ )++parseSslEnabled :: Parser SSL+parseSslEnabled = do+ -- [NOTE: enable-ssl]+ --+ -- We parse this for backwards compatibility with nix-serve, but ignore+ -- it. Instead, we use the presence of the --ssl-key and --ssl-cert+ -- options to detect whether SSL is enabled+ Options.switch+ ( Options.long "enable-ssl"+ <> Options.internal+ )++ cert <- parseCert++ key <- parseKey++ return Enabled{..}++parseSsl :: Parser SSL+parseSsl = parseSslEnabled <|> pure Disabled++parseTcp :: Parser Socket+parseTcp = do+ host <- Options.strOption+ ( Options.long "host"+ <> Options.help "The hostname to bind to"+ <> Options.metavar "*|*4|!4|*6|!6|IPv4|IPv6"+ -- The default host for warp is "*4", but we specify a default of+ -- "*" for backwards compatibility with nix-serve, which defaults to+ -- binding to any IP address. Also, binding to any IP address is+ -- probably a better default anyway than binding to only IPv4+ -- addresses.+ <> Options.value "*"+ <> Options.showDefaultWith (\_ -> "*")+ )++ port <- Options.option Options.auto+ ( Options.long "port"+ <> Options.help "The port to bind to"+ <> Options.metavar "0-65535"+ -- This is also for backwards compatibility with nix-serve, which+ -- defaults to port 5000.+ <> Options.value 5000+ )++ return TCP{..}++defaultBacklog :: Natural+defaultBacklog = 1024++parseUnix :: Parser Socket+parseUnix = do+ backlog <- Options.option Options.auto+ ( Options.long "backlog"+ <> Options.help "The maximum number of connections allowed for the backlog"+ <> Options.metavar "INTEGER"+ <> Options.value defaultBacklog+ )++ path <- Options.strOption+ ( Options.long "socket"+ <> Options.short 'S'+ <> Options.help "The socket to bind to"+ <> Options.metavar "PATH"+ )++ return Unix{..}++parseSocket :: Parser Socket+parseSocket = parseTcp <|> parseUnix++parsePriority :: Parser Integer+parsePriority =+ Options.option Options.auto+ ( Options.long "priority"+ <> Options.help "The priority of the cache (lower is higher priority)"+ <> Options.metavar "INTEGER"+ <> Options.value 30+ )++parseTimeout :: Parser Natural+parseTimeout =+ Options.option Options.auto+ ( Options.long "timeout"+ <> Options.help "Timeout for requests"+ <> Options.metavar "SECONDS"+ -- nix-serve does not timeout requests, but warp insists on a+ -- timeout, so we use the same default timeout as hydra+ <> Options.value (10 * 60)+ )++parseVerbosity :: Parser Verbosity+parseVerbosity =+ Options.flag' Quiet+ ( Options.long "quiet"+ <> Options.help "Disable logging"+ )+ <|> Options.flag' Verbose+ ( Options.long "verbose"+ <> Options.help "Log verbosely"+ )+ <|> pure Normal++parseOptions :: Parser Options+parseOptions = do+ socket <- parseTcp <|> parseUnix++ ssl <- parseSsl++ priority <- parsePriority++ timeout <- parseTimeout++ verbosity <- parseVerbosity++ return Options{..}++parseReader :: Parsec Void String a -> ReadM a+parseReader parser =+ Options.eitherReader \string -> do+ case Megaparsec.parse parser "(input)" string of+ Left bundle -> Left (Megaparsec.errorBundlePretty bundle)+ Right a -> Right a++-- This is only for backwards compatibility with nix-serve, which supports+-- the --listen option+parseListen :: Parser Options+parseListen = do+ let parseTcpListen :: Parsec Void String Socket+ parseTcpListen = do+ host <- parseHost <|> pure "*"++ _ <- ":"++ port <- Lexer.decimal++ -- See: [NOTE: enable-ssl]+ _ <- optional ":ssl"++ return TCP{..}++ let parseUnixListen :: Parsec Void String Socket+ parseUnixListen = do+ let backlog = defaultBacklog++ path <- Megaparsec.takeRest++ return Unix{..}++ let parseSocketListen = parseTcpListen <|> parseUnixListen++ ssl <- parseSsl++ socket <- Options.option (parseReader parseSocketListen)+ ( Options.long "listen"+ <> Options.short 'l'+ <> Options.help "The TLS-enabled host and port to bind to"+ <> Options.metavar "[HOST]:PORT|UNIX_SOCKET"+ <> Options.hidden+ )++ priority <- parsePriority++ timeout <- parseTimeout++ verbosity <- parseVerbosity++ return Options{..}++parserInfo :: ParserInfo Options+parserInfo =+ Options.info+ (Options.helper <*> (parseOptions <|> parseListen))+ (Options.progDesc "Serve the current Nix store as a binary cache")++parseHost :: Parsec Void String HostPreference+parseHost = do+ string <- Megaparsec.takeWhileP Nothing (/= ':')+ return (fromString string)