Initial commit

LICENSE

@@ -0,0 +1,13 @@
+Copyright 2022 Arista Networks
+
+Licensed under the Apache License, Version 2.0 (the "License");
+you may not use this file except in compliance with the License.
+You may obtain a copy of the License at
+
+    http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software
+distributed under the License is distributed on an "AS IS" BASIS,
+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+See the License for the specific language governing permissions and
+limitations under the License.

cbits/nix.cpp

@@ -0,0 +1,149 @@
+#include <cstddef>
+#include <cstdlib>
+#include <nix/store-api.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);
+}
+
+}

cbits/nix.hh

@@ -0,0 +1,22 @@
+#include <stdint.h>
+#include <stddef.h>
+
+struct string {
+  char const * data;
+
+  size_t size;
+};
+
+struct strings {
+  struct string * data;
+
+  size_t size;
+};
+
+struct PathInfo {
+    struct string deriver;
+    struct string narHash;
+    uint64_t narSize;
+    struct strings references;
+    struct strings sigs;
+};

darwin/Sysctl.hs

@@ -0,0 +1,4 @@
+module Sysctl where
+
+_SO_MAX_CONN :: String
+_SO_MAX_CONN = "kern.ipc.somaxconn"

linux/Sysctl.hs

@@ -0,0 +1,4 @@
+module Sysctl where
+
+_SO_MAX_CONN :: String
+_SO_MAX_CONN = "net.core.somaxconn"

nix-serve-ng.cabal

@@ -0,0 +1,68 @@
+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:            Apache-2.0
+license-file:       LICENSE
+author:             Arista Networks
+maintainer:         opensource@awakesecurity.com
+copyright:          2022 Arista Networks
+
+executable nix-serve-ng
+    hs-source-dirs:   src
+
+    main-is:          Main.hs
+
+    other-modules:    Sysctl
+                    , Nix
+                    , Options
+
+    if os(darwin)
+      hs-source-dirs: darwin
+    elif os(linux)
+      hs-source-dirs: linux
+    else
+      buildable:      False
+
+    -- https://nixos.org/manual/nix/stable/installation/supported-platforms.html
+    if arch(i686) && os(linux)
+      cxx-options:    -DSYSTEM="i686-linux"
+    elif 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
+                    , bsd-sysctl
+                    , bytestring
+                    , http-types
+                    , managed
+                    , megaparsec
+                    , network
+                    , optparse-applicative
+                    , vector
+                    , wai
+                    , warp
+                    , warp-tls
+
+    extra-libraries:  nixstore
+                    , nixutil
+                    , c++
+
+    default-language: Haskell2010
+
+    ghc-options:      -Wall

nix/nix-serve-ng.nix

@@ -0,0 +1,18 @@
+{ mkDerivation, base, bsd-sysctl, bytestring, http-types, lib
+, managed, megaparsec, network, nixstore, nixutil
+, optparse-applicative, vector, wai, warp, warp-tls
+}:
+mkDerivation {
+  pname = "nix-serve-ng";
+  version = "1.0.0";
+  src = ./.;
+  isLibrary = false;
+  isExecutable = true;
+  executableHaskellDepends = [
+    base bsd-sysctl bytestring http-types managed megaparsec network
+    optparse-applicative vector wai warp warp-tls
+  ];
+  executableSystemDepends = [ nixstore nixutil ];
+  description = "A drop-in replacement for nix-serve that's faster and more stable";
+  license = lib.licenses.bsd3;
+}

shell.nix

@@ -0,0 +1,26 @@
+let
+  overlay = pkgsNew: pkgsOld: {
+    haskellPackages = pkgsOld.haskellPackages.override (old: {
+      overrides =
+        pkgsNew.lib.composeExtensions
+          (old.overrides or (_: _: { }))
+          (haskellPackagesNew: haskellPackagesOld: {
+            nix-serve-ng =
+              pkgsNew.haskell.lib.overrideCabal
+                (haskellPackagesNew.callPackage ./nix/nix-serve-ng.nix {
+                  nixstore = pkgsNew.nix;
+                  nixutil = pkgsNew.nix;
+                })
+                (old: {
+                  executableSystemDepends = (old.executableSystemDepends or []) ++ [
+                    pkgsNew.boost.dev
+                  ];
+                });
+          });
+    });
+  };
+
+  pkgs = import <nixpkgs> { config = { }; overlays = [ overlay ]; };
+
+in
+  pkgs.haskellPackages.nix-serve-ng.env

src/Main.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Main where
+
+import Data.Function ((&))
+import Network.Socket (SockAddr(..))
+import Nix (PathInfo(..))
+import Options (Options(..), Socket(..), SSL(..))
+import Sysctl (_SO_MAX_CONN)
+
+import qualified Control.Monad               as Monad
+import qualified Data.ByteString             as ByteString
+import qualified Data.ByteString.Lazy        as ByteString.Lazy
+import qualified Data.ByteString.Builder     as Builder
+import qualified Data.Vector                 as Vector
+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 Nix
+import qualified Options
+import qualified Options.Applicative         as Options
+import qualified System.BSD.Sysctl           as Sysctl
+
+toSocket :: FilePath -> IO Socket.Socket
+toSocket 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)
+
+    backlog <- Sysctl.sysctlReadInt _SO_MAX_CONN
+
+    Socket.listen socket (fromIntegral backlog)
+
+    return socket
+
+main :: IO ()
+main = do
+    options@Options{ priority } <- Options.execParser Options.parserInfo
+
+    storeDirectory <- Nix.getStoreDir
+
+    let stripStore = ByteString.stripPrefix (storeDirectory <> "/")
+
+    let application request respond = do
+            let rawPath = Wai.rawPathInfo request
+
+            if  | Just suffix <- ByteString.stripSuffix ".narinfo" rawPath
+                , Just hashPart <- ByteString.stripPrefix "/" suffix -> do
+                    maybeStorePath <- Nix.queryPathFromHashPart hashPart
+
+                    case maybeStorePath of
+                        Nothing -> do
+                            let headers = [ ("Content-Type", "text/plain") ]
+
+                            let builder = "No such path.\n"
+
+                            let response =
+                                    Wai.responseBuilder
+                                        Types.status404
+                                        headers
+                                        builder
+
+                            respond response
+                        Just storePath -> do
+                            PathInfo{..} <- Nix.queryPathInfo storePath
+
+                            case ByteString.stripPrefix "sha256:" narHash of
+                                Just narHash2 -> do
+                                    let referencesBuilder
+                                            | not (Vector.null references) =
+                                                case traverse stripStore references of
+                                                    Just names ->
+                                                            "References:"
+                                                        <>  foldMap (\name -> " " <> Builder.byteString name) names
+                                                        <>  "\n"
+                                            | otherwise =
+                                                mempty
+
+                                    let deriverBuilder =
+                                            case deriver of
+                                                Just d ->
+                                                    case stripStore d of
+                                                        Just name ->
+                                                                "Deriver: "
+                                                            <>  Builder.byteString name
+                                                            <>  "\n"
+                                                Nothing ->
+                                                    mempty
+
+                                    let builder =
+                                                "StorePath: "
+                                            <>  Builder.byteString storePath
+                                            <>  "\nURL: nar/"
+                                            <>  Builder.byteString hashPart
+                                            <>  "-"
+                                            <>  Builder.byteString narHash2
+                                            <>  "\nCompression: none\nNarHash: "
+                                            <>  Builder.byteString narHash
+                                            <>  "\nNarSize: "
+                                            <>  Builder.word64Dec narSize
+                                            <>  "\n"
+                                            <>  referencesBuilder
+                                            <>  deriverBuilder
+
+                                    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
+
+                                    respond response
+
+                                Nothing -> do
+                                    let headers =
+                                            [ ("Content-Type", "text/plain") ]
+
+                                    let builder = "Internal Server Error"
+
+                                    let response =
+                                            Wai.responseBuilder
+                                                Types.status500
+                                                headers
+                                                builder
+
+                                    respond 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
+
+                    respond response
+
+                | otherwise -> do
+                    let headers = [ ("Content-Type", "text/plain") ]
+
+                    let builder = "File not found.\n"
+
+                    let response =
+                            Wai.responseBuilder Types.status404 headers builder
+
+                    respond response
+ 
+    case options of
+        Options{ ssl = Disabled, socket = TCP{ host, port } } -> do
+            let settings =
+                    Warp.defaultSettings
+                        & Warp.setHost host
+                        & Warp.setPort port
+
+            Warp.runSettings settings application
+
+        Options{ ssl = Disabled, socket = Unix{ path } } -> do
+            let settings = Warp.defaultSettings
+
+            socket <- toSocket path
+
+            Warp.runSettingsSocket settings socket application
+
+        Options{ ssl = Enabled{ cert, key }, socket = TCP{ host, port } } -> do
+            let tlsSettings = WarpTLS.tlsSettings cert key
+
+            let settings =
+                    Warp.defaultSettings
+                        & Warp.setHost host
+                        & Warp.setPort port
+
+            WarpTLS.runTLS tlsSettings settings application
+
+        Options{ ssl = Enabled{ cert, key }, socket = Unix{ path } } -> do
+            let tlsSettings = WarpTLS.tlsSettings cert key
+
+            let settings = Warp.defaultSettings
+
+            socket <- toSocket path
+
+            WarpTLS.runTLSSocket tlsSettings settings socket application

src/Nix.hsc

@@ -0,0 +1,211 @@
+{-# LANGUAGE BlockArguments           #-}
+{-# LANGUAGE DuplicateRecordFields    #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE TypeApplications         #-}
+
+module Nix where
+
+import Control.Monad.Managed (Managed)
+import Data.ByteString (ByteString)
+import Data.Vector (Vector)
+import Data.Word (Word64)
+import Foreign (Ptr, Storable(..))
+import Foreign.C (CChar, CLong, CSize, CString)
+
+import qualified Control.Exception     as Exception
+import qualified Control.Monad.Managed as Managed
+import qualified Data.ByteString       as ByteString
+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 string, data} pointer
+
+        size <- #{peek struct string, size} pointer
+
+        return Strings{ data_, size }
+
+    poke pointer Strings{ data_, size } = do
+        #{poke struct string, data} pointer data_
+
+        #{poke struct string, 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 (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_
+
+foreign import ccall "queryPathFromHashPart" queryPathFromHashPart_
+    :: CString -> Ptr String_ -> IO ()
+
+queryPathFromHashPart :: ByteString -> IO (Maybe 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 Nothing
+                    else fmap Just (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
+
+

src/Options.hs

@@ -0,0 +1,181 @@
+{-# 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 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 { path :: FilePath }
+
+data SSL = Disabled | Enabled { cert :: FilePath, key :: FilePath }
+
+data Options = Options
+    { priority :: Integer
+    , socket   :: Socket
+    , ssl      :: SSL
+    }
+
+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{..}
+
+parseUnix :: Parser Socket
+parseUnix = do
+    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
+        )
+
+parseOptions :: Parser Options
+parseOptions = do
+    socket <- parseTcp <|> parseUnix
+
+    ssl <- parseSsl
+
+    priority <- parsePriority
+
+    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
+            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
+
+    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)