Initial commit
This commit is contained in:
Gabriella Gonzalez
209
src/Main.hs
Normal file
209
src/Main.hs
Normal file
@@ -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
|
||||
211
src/Nix.hsc
Normal file
211
src/Nix.hsc
Normal file
@@ -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
|
||||
|
||||
|
||||
181
src/Options.hs
Normal file
181
src/Options.hs
Normal file
@@ -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)
|
||||
Reference in New Issue
Block a user