diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,23 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [1.5] - 2023-05-17 + +### Added + +- `cachix pin` - See https://docs.cachix.org/pins + +### Fixed + +- Reverted "Rewrite C++ bits to Haskell" + + This reverts 15 commits related towards getting Cachix to + built statically without C++ code in Nix. + + Since it's not possible to interact with Nix sqlite directly + in a reliable manner, we'll go the route of autogenerating C++ + binding without Template Haskell, at some point. + ## [1.4.2] - 2023-04-05 ### Fixed diff --git a/cachix.cabal b/cachix.cabal --- a/cachix.cabal +++ b/cachix.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cachix -version: 1.4.2 +version: 1.5 license: Apache-2.0 license-file: LICENSE copyright: 2018 Domen Kozar @@ -45,9 +45,10 @@ location: https://github.com/cachix/cachix library - import: defaults + import: defaults exposed-modules: Cachix.Client + Cachix.Client.CNix Cachix.Client.Commands Cachix.Client.Config Cachix.Client.Config.Orphans @@ -59,14 +60,12 @@ Cachix.Client.NixConf Cachix.Client.NixVersion Cachix.Client.OptionsParser - Cachix.Client.ProcessGraph Cachix.Client.Push Cachix.Client.Push.S3 Cachix.Client.PushQueue Cachix.Client.Retry Cachix.Client.Secrets Cachix.Client.Servant - Cachix.Client.Store Cachix.Client.URI Cachix.Client.Version Cachix.Client.WatchStore @@ -81,10 +80,11 @@ Cachix.Deploy.Websocket Cachix.Deploy.WebsocketPong Data.Conduit.ByteString + System.Nix.Base32 - hs-source-dirs: src - other-modules: Paths_cachix - autogen-modules: Paths_cachix + hs-source-dirs: src + other-modules: Paths_cachix + autogen-modules: Paths_cachix build-depends: , aeson , async @@ -102,19 +102,20 @@ , cryptonite , deepseq , dhall >=1.28.0 - , direct-sqlite >=2.3.28 , directory , ed25519 , either , extra , filepath , fsnotify >=0.4.1 + , hercules-ci-cnix-store , here , hnix-store-core >=0.6.1.0 , http-client , http-client-tls , http-conduit , http-types + , inline-c-cpp , katip , lukko , lzma-conduit @@ -152,6 +153,9 @@ , versions , websockets , wuss + + -- These versions are pinned in hercules-ci-cnix-store + pkgconfig-depends: nix-main, nix-store executable cachix import: defaults diff --git a/src/Cachix/Client.hs b/src/Cachix/Client.hs --- a/src/Cachix/Client.hs +++ b/src/Cachix/Client.hs @@ -23,6 +23,7 @@ Config configCommand -> Config.run cachixOptions configCommand GenerateKeypair name -> Commands.generateKeypair env name Push pushArgs -> Commands.push env pushArgs + Pin pingArgs -> Commands.pin env pingArgs WatchStore watchArgs name -> Commands.watchStore env watchArgs name WatchExec pushArgs name cmd args -> Commands.watchExec env pushArgs name cmd args Use name useOptions -> Commands.use env name useOptions diff --git a/src/Cachix/Client/CNix.hs b/src/Cachix/Client/CNix.hs new file mode 100644 --- /dev/null +++ b/src/Cachix/Client/CNix.hs @@ -0,0 +1,19 @@ +module Cachix.Client.CNix where + +import Hercules.CNix.Store (Store, StorePath, isValidPath, storePathToPath) +import Protolude +import System.Console.Pretty (Color (..), color) + +filterInvalidStorePaths :: Store -> [StorePath] -> IO [Maybe StorePath] +filterInvalidStorePaths store = + traverse (filterInvalidStorePath store) + +filterInvalidStorePath :: Store -> StorePath -> IO (Maybe StorePath) +filterInvalidStorePath store storePath = do + isValid <- isValidPath store storePath + if isValid + then return $ Just storePath + else do + path <- storePathToPath store storePath + hPutStrLn stderr $ color Yellow $ "Warning: " <> decodeUtf8With lenientDecode path <> " is not valid, skipping" + return Nothing diff --git a/src/Cachix/Client/Commands.hs b/src/Cachix/Client/Commands.hs --- a/src/Cachix/Client/Commands.hs +++ b/src/Cachix/Client/Commands.hs @@ -10,21 +10,23 @@ watchStore, watchExec, use, + pin, ) where import qualified Cachix.API as API import Cachix.API.Error +import Cachix.Client.CNix (filterInvalidStorePath) import qualified Cachix.Client.Config as Config import Cachix.Client.Env (Env (..)) -import qualified Cachix.Client.Env as Env import Cachix.Client.Exception (CachixException (..)) import Cachix.Client.HumanSize (humanSize) import qualified Cachix.Client.InstallationMode as InstallationMode import qualified Cachix.Client.NixConf as NixConf import Cachix.Client.NixVersion (assertNixVersion) import Cachix.Client.OptionsParser - ( PushArguments (..), + ( PinOptions (..), + PushArguments (..), PushOptions (..), ) import Cachix.Client.Push @@ -34,9 +36,9 @@ exportSigningKey, ) import Cachix.Client.Servant -import qualified Cachix.Client.Store as Store import qualified Cachix.Client.WatchStore as WatchStore import qualified Cachix.Types.BinaryCache as BinaryCache +import qualified Cachix.Types.PinCreate as PinCreate import qualified Cachix.Types.SigningKeyCreate as SigningKeyCreate import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (throwM) @@ -47,6 +49,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T.IO import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import Hercules.CNix.Store (Store, StorePath, followLinksToStorePath, storePathToPath, withStore) import Network.HTTP.Types (status401, status404) import Protolude hiding (toS) import Protolude.Conv @@ -167,12 +170,14 @@ normalized <- liftIO $ for inputStorePaths $ - \path -> Store.followLinksToStorePath (Env.storePrefix env) (toS path) + \path -> do + storePath <- followLinksToStorePath (pushParamsStore pushParams) (encodeUtf8 path) + filterInvalidStorePath (pushParamsStore pushParams) storePath pushedPaths <- pushClosure (mapConcurrentlyBounded (numJobs opts)) pushParams - (Store.StorePath . toS <$> normalized) + (catMaybes normalized) case (length normalized, length pushedPaths) of (0, _) -> putTextError "Nothing to push." (_, 0) -> putTextError "Nothing to push - all store paths are already on Cachix." @@ -184,10 +189,34 @@ putTextError :: Text -> IO () putTextError = hPutStrLn stderr +pin :: Env -> PinOptions -> IO () +pin env pinOpts = do + authToken <- Config.getAuthTokenRequired (config env) + storePath <- withStore $ \store -> do + path <- followLinksToStorePath store (encodeUtf8 $ pinStorePath pinOpts) + storePathToPath store path + traverse_ (validateArtifact (toS storePath)) (pinArtifacts pinOpts) + let pinCreate = + PinCreate.PinCreate + { name = pinName pinOpts, + storePath = toS storePath, + artifacts = pinArtifacts pinOpts, + keep = pinKeep pinOpts + } + void $ escalate <=< retryAll $ \_ -> + (`runClientM` clientenv env) $ API.createPin cachixClient authToken (pinCacheName pinOpts) pinCreate + where + validateArtifact :: Text -> Text -> IO () + validateArtifact storePath artifact = do + -- strip prefix / from artifact path if it exists + let artifactPath = storePath <> "/" <> fromMaybe artifact (T.stripPrefix "/" artifact) + exists <- doesFileExist (toS artifactPath) + unless exists $ throwIO $ ArtifactNotFound $ "Artifact " <> artifactPath <> " doesn't exist." + watchStore :: Env -> PushOptions -> Text -> IO () watchStore env opts name = do withPushParams env opts name $ \pushParams -> - WatchStore.startWorkers (numJobs opts) pushParams + WatchStore.startWorkers (pushParamsStore pushParams) (numJobs opts) pushParams watchExec :: Env -> PushOptions -> Text -> Text -> [Text] -> IO () watchExec env pushOpts name cmd args = withPushParams env pushOpts name $ \pushParams -> do @@ -198,7 +227,7 @@ } watch = do hDuplicateTo stderr stdout -- redirect all stdout to stderr - WatchStore.startWorkers (numJobs pushOpts) pushParams + WatchStore.startWorkers (pushParamsStore pushParams) (numJobs pushOpts) pushParams (_, exitCode) <- Async.concurrently watch $ do @@ -229,14 +258,14 @@ then "" else "(retry #" <> show (rsIterNumber retrystatus) <> ") " -pushStrategy :: Maybe Token -> PushOptions -> Text -> BinaryCache.CompressionMethod -> Store.StorePath -> PushStrategy IO () -pushStrategy authToken opts name compressionMethod storePath = +pushStrategy :: Store -> Maybe Token -> PushOptions -> Text -> BinaryCache.CompressionMethod -> StorePath -> PushStrategy IO () +pushStrategy store authToken opts name compressionMethod storePath = PushStrategy { onAlreadyPresent = pass, on401 = handleCacheResponse name authToken, onError = throwM, onAttempt = \retrystatus size -> do - let path = Store.getPath storePath + path <- decodeUtf8With lenientDecode <$> storePathToPath store storePath -- we append newline instead of putStrLn due to https://github.com/haskell/text/issues/242 putStr $ retryText retrystatus <> "compressing using " <> T.toLower (show compressionMethod) <> " and pushing " <> path <> " (" <> humanSize (fromIntegral size) <> ")\n", onDone = pass, @@ -246,7 +275,7 @@ } withPushParams :: Env -> PushOptions -> Text -> (PushParams IO () -> IO ()) -> IO () -withPushParams env pushOpts name action = do +withPushParams env pushOpts name m = do pushSecret <- findPushSecret (config env) name authToken <- Config.getAuthTokenMaybe (config env) compressionMethodBackend <- case pushSecret of @@ -258,17 +287,12 @@ Left err -> handleCacheResponse name authToken err Right binaryCache -> pure (Just $ BinaryCache.preferredCompressionMethod binaryCache) let compressionMethod = fromMaybe BinaryCache.ZSTD (head $ catMaybes [Cachix.Client.OptionsParser.compressionMethod pushOpts, compressionMethodBackend]) - wal <- Store.getUseSqliteWAL - action - PushParams - { pushParamsName = name, - pushParamsSecret = pushSecret, - pushParamsClientEnv = clientenv env, - pushParamsStrategy = pushStrategy authToken pushOpts name compressionMethod, - pushParamsWithStore = - Store.withLocalStore $ - Store.LocalStoreOptions - { Store.storePrefix = Env.storePrefix env, - Store.useSqliteWAL = wal - } - } + withStore $ \store -> + m + PushParams + { pushParamsName = name, + pushParamsSecret = pushSecret, + pushParamsClientEnv = clientenv env, + pushParamsStrategy = pushStrategy store authToken pushOpts name compressionMethod, + pushParamsStore = store + } diff --git a/src/Cachix/Client/Env.hs b/src/Cachix/Client/Env.hs --- a/src/Cachix/Client/Env.hs +++ b/src/Cachix/Client/Env.hs @@ -11,6 +11,8 @@ import qualified Cachix.Client.OptionsParser as Options import Cachix.Client.URI (getBaseUrl) import Cachix.Client.Version (cachixVersion) +import qualified Hercules.CNix as CNix +import qualified Hercules.CNix.Util as CNix.Util import Network.HTTP.Client ( ManagerSettings, managerModifyRequest, @@ -23,16 +25,27 @@ import Protolude.Conv import Servant.Client.Streaming (ClientEnv, mkClientEnv) import System.Directory (canonicalizePath) +import System.Posix.Signals (getSignalMask, setSignalMask) data Env = Env { cachixoptions :: Config.CachixOptions, clientenv :: ClientEnv, - config :: Config, - storePrefix :: Text + config :: Config } mkEnv :: Options.Flags -> IO Env mkEnv flags = do + signalset <- getSignalMask + -- Initialize the Nix library + CNix.init + + -- darwin: restore the signal mask modified by Nix + -- https://github.com/cachix/cachix/issues/501 + setSignalMask signalset + + -- Interrupt Nix before throwing UserInterrupt + CNix.Util.installDefaultSigINTHandler + -- make sure path to the config is passed as absolute to dhall logic canonicalConfigPath <- canonicalizePath (Options.configPath flags) cfg <- Config.getConfig canonicalConfigPath @@ -47,8 +60,7 @@ Env { cachixoptions = cachixOptions, clientenv = clientEnv, - config = cfg, - storePrefix = "/nix" -- https://github.com/cachix/cachix/issues/85 + config = cfg } customManagerSettings :: ManagerSettings diff --git a/src/Cachix/Client/Exception.hs b/src/Cachix/Client/Exception.hs --- a/src/Cachix/Client/Exception.hs +++ b/src/Cachix/Client/Exception.hs @@ -15,6 +15,7 @@ | NarStreamingError ExitCode Text | NarHashMismatch Text | DeprecatedCommand Text + | ArtifactNotFound Text | AccessDeniedBinaryCache Text | BinaryCacheNotFound Text deriving (Show, Typeable) @@ -27,6 +28,7 @@ displayException (AmbiguousInput s) = toS s displayException (NoInput s) = toS s displayException (NoConfig s) = toS s + displayException (ArtifactNotFound s) = toS s displayException (NoSigningKey s) = toS s displayException (NetRcParseError s) = toS s displayException (NarStreamingError _ s) = toS s diff --git a/src/Cachix/Client/OptionsParser.hs b/src/Cachix/Client/OptionsParser.hs --- a/src/Cachix/Client/OptionsParser.hs +++ b/src/Cachix/Client/OptionsParser.hs @@ -4,6 +4,7 @@ ( CachixCommand (..), PushArguments (..), PushOptions (..), + PinOptions (..), BinaryCacheName, getOpts, Flags (..), @@ -16,9 +17,10 @@ import qualified Cachix.Client.URI as URI import qualified Cachix.Deploy.OptionsParser as DeployOptions import qualified Cachix.Types.BinaryCache as BinaryCache +import Cachix.Types.PinCreate (Keep (..)) import qualified Data.Text as T import Options.Applicative -import Protolude hiding (option, toS) +import Protolude hiding (toS) import Protolude.Conv import qualified Prelude @@ -77,6 +79,7 @@ | Config Config.Command | GenerateKeypair BinaryCacheName | Push PushArguments + | Pin PinOptions | WatchStore PushOptions Text | WatchExec PushOptions Text Text [Text] | Use BinaryCacheName InstallationMode.UseOptions @@ -89,6 +92,15 @@ | PushWatchStore PushOptions Text deriving (Show) +data PinOptions = PinOptions + { pinCacheName :: BinaryCacheName, + pinName :: Text, + pinStorePath :: Text, + pinArtifacts :: [Text], + pinKeep :: Maybe Keep + } + deriving (Show) + data PushOptions = PushOptions { compressionLevel :: Int, compressionMethod :: Maybe BinaryCache.CompressionMethod, @@ -104,6 +116,7 @@ <> command "config" (Config <$> Config.parser) <> command "generate-keypair" (infoH generateKeypair (progDesc "Generate signing key pair for a binary cache")) <> command "push" (infoH push (progDesc "Upload Nix store paths to a binary cache")) + <> command "pin" (infoH pin (progDesc "Pin a store path to prevent it from being garbage collected")) <> command "watch-exec" (infoH watchExec (progDesc "Run a command while it's running watch /nix/store for newly added store paths and upload them to a binary cache")) <> command "watch-store" (infoH watchStore (progDesc "Indefinitely watch /nix/store for newly added store paths and upload them to a binary cache")) <> command "use" (infoH use (progDesc "Configure a binary cache by writing nix.conf and netrc files")) @@ -159,6 +172,19 @@ pushPaths = (\paths opts cache -> PushPaths opts cache paths) <$> many (strArgument (metavar "PATHS...")) + keepParser = daysParser <|> revisionsParser <|> foreverParser <|> pure Nothing + -- these three flag are mutually exclusive + daysParser = Just . Days <$> option auto (long "keep-days" <> metavar "INT") + revisionsParser = Just . Revisions <$> option auto (long "keep-revisions" <> metavar "INT") + foreverParser = flag' (Just Forever) (long "keep-forever") + pinOptions = + PinOptions + <$> nameArg + <*> strArgument (metavar "PIN-NAME") + <*> strArgument (metavar "STORE-PATH") + <*> many (strOption (metavar "ARTIFACTS..." <> long "artifact" <> short 'a')) + <*> keepParser + pin = Pin <$> pinOptions watchExec = WatchExec <$> pushOptions <*> nameArg <*> strArgument (metavar "CMD") <*> many (strArgument (metavar "-- ARGS")) watchStore = WatchStore <$> pushOptions <*> nameArg pushWatchStore = diff --git a/src/Cachix/Client/ProcessGraph.hs b/src/Cachix/Client/ProcessGraph.hs deleted file mode 100644 --- a/src/Cachix/Client/ProcessGraph.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Cachix.Client.ProcessGraph where - -import Control.Concurrent.Async (mapConcurrently) -import Data.IORef (atomicModifyIORef', newIORef, readIORef) -import qualified Data.Set as Set -import Protolude - -processGraph :: - forall a. - (Ord a) => - -- | Initial list of items - [a] -> - -- | Function to process an item and return a list of new items - (a -> IO [a]) -> - -- | Set of processed items - IO (Set a) -processGraph initialItems processItem = do - processedItems <- newIORef Set.empty - let processNode :: a -> IO () - processNode item = do - alreadyProcessed <- atomicModifyIORef' processedItems $ \items -> - if Set.member item items - then (items, True) - else (Set.insert item items, False) - unless alreadyProcessed $ do - newItems <- processItem item - _ <- mapConcurrently processNode newItems - return () - _ <- mapConcurrently processNode initialItems - readIORef processedItems diff --git a/src/Cachix/Client/Push.hs b/src/Cachix/Client/Push.hs --- a/src/Cachix/Client/Push.hs +++ b/src/Cachix/Client/Push.hs @@ -34,7 +34,6 @@ import Cachix.Client.Retry (retryAll) import Cachix.Client.Secrets import Cachix.Client.Servant -import qualified Cachix.Client.Store as Store import qualified Cachix.Types.BinaryCache as BinaryCache import qualified Cachix.Types.MultipartUpload as Multipart import qualified Cachix.Types.NarInfoCreate as Api @@ -45,7 +44,7 @@ import Control.Monad.Trans.Resource (ResourceT) import Control.Retry (RetryStatus) import Crypto.Sign.Ed25519 -import Data.ByteArray.Encoding (Base (..), convertToBase) +import qualified Data.ByteString.Base64 as B64 import Data.Conduit import qualified Data.Conduit.Lzma as Lzma (compress) import qualified Data.Conduit.Zstd as Zstd (compress) @@ -53,6 +52,10 @@ import qualified Data.Set as Set import Data.String.Here import qualified Data.Text as T +import Hercules.CNix (StorePath) +import qualified Hercules.CNix.Std.Set as Std.Set +import Hercules.CNix.Store (Store) +import qualified Hercules.CNix.Store as Store import Network.HTTP.Types (status401, status404) import Protolude hiding (toS) import Protolude.Conv @@ -73,10 +76,10 @@ { pushParamsName :: Text, pushParamsSecret :: PushSecret, -- | how to report results, (some) errors, and do some things - pushParamsStrategy :: Store.StorePath -> PushStrategy m r, + pushParamsStrategy :: StorePath -> PushStrategy m r, -- | cachix base url, connection manager, see 'Cachix.Client.URI.defaultCachixBaseUrl', 'Servant.Client.mkClientEnv' pushParamsClientEnv :: ClientEnv, - pushParamsWithStore :: forall a. (Store.Store -> m a) -> m a + pushParamsStore :: Store } data PushStrategy m r = PushStrategy @@ -105,16 +108,14 @@ pushSingleStorePath :: (MonadMask m, MonadIO m) => - Maybe Store.Store -> -- | details for pushing to cache PushParams m r -> -- | store path - Store.StorePath -> + StorePath -> -- | r is determined by the 'PushStrategy' m r -pushSingleStorePath Nothing cache storePath = pushParamsWithStore cache $ \store -> - pushSingleStorePath (Just store) cache storePath -pushSingleStorePath (Just store) cache storePath = retryAll $ \retrystatus -> do +pushSingleStorePath cache storePath = retryAll $ \retrystatus -> do + storeHash <- liftIO $ Store.getStorePathHash storePath let name = pushParamsName cache strategy = pushParamsStrategy cache storePath -- Check if narinfo already exists @@ -125,11 +126,11 @@ cachixClient (getCacheAuthToken (pushParamsSecret cache)) name - (NarInfoHash.NarInfoHash (Store.getStorePathHash store storePath)) + (NarInfoHash.NarInfoHash (decodeUtf8With lenientDecode storeHash)) case res of Right NoContent -> onAlreadyPresent strategy -- we're done as store path is already in the cache Left err - | isErr err status404 -> uploadStorePath (Just store) cache storePath retrystatus + | isErr err status404 -> uploadStorePath cache storePath retrystatus | isErr err status401 -> on401 strategy err | otherwise -> onError strategy err @@ -139,17 +140,16 @@ uploadStorePath :: (MonadIO m) => - Maybe Store.Store -> -- | details for pushing to cache PushParams m r -> - Store.StorePath -> + StorePath -> RetryStatus -> -- | r is determined by the 'PushStrategy' m r -uploadStorePath Nothing cache storePath retrystatus = pushParamsWithStore cache $ \store -> - uploadStorePath (Just store) cache storePath retrystatus -uploadStorePath (Just store@(Store.Store storePrefix _)) cache storePath retrystatus = do - let storePathText = Store.getPath storePath +uploadStorePath cache storePath retrystatus = do + let store = pushParamsStore cache + -- TODO: storePathText is redundant. Use storePath directly. + storePathText <- liftIO $ Store.storePathToPath store storePath let (storeHash, storeSuffix) = splitStorePath $ toS storePathText cacheName = pushParamsName cache authToken = getCacheAuthToken (pushParamsSecret cache) @@ -168,9 +168,10 @@ narHashRef <- liftIO $ newIORef ("" :: ByteString) fileHashRef <- liftIO $ newIORef ("" :: ByteString) - normalized <- liftIO $ Store.followLinksToStorePath storePrefix $ toS storePathText - pathinfo <- liftIO $ escalateAs FatalError =<< Store.queryPathInfo store (toS normalized) - let storePathSize = Store.narSize pathinfo + -- This should be a noop because storePathText came from a StorePath + normalized <- liftIO $ Store.followLinksToStorePath store $ toS storePathText + pathinfo <- liftIO $ Store.queryPathInfo store normalized + let storePathSize = Store.validPathInfoNarSize pathinfo onAttempt strategy retrystatus storePathSize withCompressor $ \compressor -> liftIO $ do @@ -189,19 +190,22 @@ Right (narId, uploadId, parts) -> do narSize <- readIORef narSizeRef narHash <- ("sha256:" <>) . System.Nix.Base32.encode <$> readIORef narHashRef - nixNarHash <- escalateAs (FatalError . toS) $ Store.base16to32 $ Store.narHash pathinfo - when (narHash /= nixNarHash) $ throwM $ NarHashMismatch $ toS storePathText <> ": Nar hash mismatch between nix-store --dump (" <> narHash <> ") and nix db (" <> nixNarHash <> ").\nYou can repair db metadata by running as root: $ nix-store --verify --repair --check-contents" + narHashNix <- Store.validPathInfoNarHash32 pathinfo + when (narHash /= toS narHashNix) $ throwM $ NarHashMismatch $ toS storePathText <> ": Nar hash mismatch between nix-store --dump and nix db. You can repair db metadata by running as root: $ nix-store --verify --repair --check-contents" fileHash <- readIORef fileHashRef fileSize <- readIORef fileSizeRef - let deriver = - if omitDeriver strategy - then Nothing - else Store.getStorePathBaseName store . Store.StorePath <$> Store.deriver pathinfo - references = sort $ Store.references pathinfo - let fp = fingerprint storePathText narHash narSize references + deriverPath <- + if omitDeriver strategy + then pure Nothing + else Store.validPathInfoDeriver store pathinfo + deriver <- for deriverPath Store.getStorePathBaseName + referencesPathSet <- Store.validPathInfoReferences store pathinfo + referencesPaths <- sort . fmap toS <$> for referencesPathSet (Store.storePathToPath store) + references <- sort . fmap toS <$> for referencesPathSet Store.getStorePathBaseName + let fp = fingerprint (decodeUtf8With lenientDecode storePathText) narHash narSize referencesPaths sig = case pushParamsSecret cache of PushToken _ -> Nothing - PushSigningKey _ signKey -> Just $ (toS :: ByteString -> Text) $ convertToBase Base64 $ unSignature $ dsign (signingSecretKey signKey) fp + PushSigningKey _ signKey -> Just $ toS $ B64.encode $ unSignature $ dsign (signingSecretKey signKey) fp nic = Api.NarInfoCreate { Api.cStoreHash = storeHash, @@ -210,8 +214,8 @@ Api.cNarSize = narSize, Api.cFileSize = fileSize, Api.cFileHash = toS fileHash, - Api.cReferences = Store.getStorePathBaseName store . Store.StorePath <$> references, - Api.cDeriver = fromMaybe "unknown-deriver" deriver, + Api.cReferences = references, + Api.cDeriver = maybe "unknown-deriver" (decodeUtf8With lenientDecode) deriver, Api.cSig = sig } escalate $ Api.isNarInfoCreateValid nic @@ -238,21 +242,26 @@ (forall a b. (a -> m b) -> [a] -> m [b]) -> PushParams m r -> -- | Initial store paths - [Store.StorePath] -> + [StorePath] -> -- | Every @r@ per store path of the entire closure of store paths m [r] -pushClosure traversal pushParams inputStorePaths = pushParamsWithStore pushParams $ \store -> do - missingPaths <- getMissingPathsForClosure (Just store) pushParams inputStorePaths - traversal (\path -> retryAll $ \retrystatus -> uploadStorePath (Just store) pushParams path retrystatus) missingPaths +pushClosure traversal pushParams inputStorePaths = do + missingPaths <- getMissingPathsForClosure pushParams inputStorePaths + traversal (\path -> retryAll $ \retrystatus -> uploadStorePath pushParams path retrystatus) missingPaths -getMissingPathsForClosure :: Maybe Store.Store -> (MonadIO m, MonadMask m) => PushParams m r -> [Store.StorePath] -> m [Store.StorePath] -getMissingPathsForClosure Nothing pushParams inputPaths = pushParamsWithStore pushParams $ \store -> - getMissingPathsForClosure (Just store) pushParams inputPaths -getMissingPathsForClosure (Just store) pushParams inputPaths = do - let clientEnv = pushParamsClientEnv pushParams +getMissingPathsForClosure :: (MonadIO m, MonadMask m) => PushParams m r -> [StorePath] -> m [StorePath] +getMissingPathsForClosure pushParams inputPaths = do + let store = pushParamsStore pushParams + clientEnv = pushParamsClientEnv pushParams -- Get the transitive closure of dependencies - paths <- liftIO $ Store.computeClosure store inputPaths - let pathsAndHashes = (\path -> (,) (Store.getStorePathHash store path) path) <$> paths + (paths :: [Store.StorePath]) <- + liftIO $ do + inputs <- Std.Set.new + for_ inputPaths $ \path -> do + Std.Set.insertFP inputs path + closure <- Store.computeFSClosure store Store.defaultClosureParams inputs + Std.Set.toListFP closure + hashes <- for paths (liftIO . fmap (decodeUtf8With lenientDecode) . Store.getStorePathHash) -- Check what store paths are missing missingHashesList <- retryAll $ \_ -> @@ -263,9 +272,14 @@ cachixClient (getCacheAuthToken (pushParamsSecret pushParams)) (pushParamsName pushParams) - (map fst pathsAndHashes) + hashes ) - let missingHashes = Set.fromList missingHashesList + let missingHashes = Set.fromList (encodeUtf8 <$> missingHashesList) + pathsAndHashes <- liftIO $ + for paths $ + \path -> do + hash_ <- Store.getStorePathHash path + pure (hash_, path) return $ map snd $ filter (\(hash_, _path) -> Set.member hash_ missingHashes) pathsAndHashes -- TODO: move to a separate module specific to cli diff --git a/src/Cachix/Client/PushQueue.hs b/src/Cachix/Client/PushQueue.hs --- a/src/Cachix/Client/PushQueue.hs +++ b/src/Cachix/Client/PushQueue.hs @@ -12,15 +12,16 @@ ) where +import Cachix.Client.CNix (filterInvalidStorePath) import qualified Cachix.Client.Push as Push import Cachix.Client.Retry (retryAll) -import Cachix.Client.Store (StorePath) import Control.Concurrent.Async import Control.Concurrent.Extra (once) import Control.Concurrent.STM (TVar, modifyTVar', newTVarIO, readTVar) import qualified Control.Concurrent.STM.Lock as Lock import qualified Control.Concurrent.STM.TBQueue as TBQueue import qualified Data.Set as S +import Hercules.CNix.Store (StorePath) import Protolude import qualified System.Posix.Signals as Signals import qualified System.Systemd.Daemon as Systemd @@ -44,7 +45,9 @@ bracket_ (inProgressModify (+ 1)) (inProgressModify (\x -> x - 1)) $ retryAll $ \retrystatus -> do - Push.uploadStorePath Nothing pushParams storePath retrystatus + maybeStorePath <- filterInvalidStorePath (Push.pushParamsStore pushParams) storePath + for_ maybeStorePath $ \validatedStorePath -> + Push.uploadStorePath pushParams validatedStorePath retrystatus where inProgressModify f = atomically $ modifyTVar' (inProgress workerState) f @@ -96,7 +99,7 @@ if isEmpty then return S.empty else return $ alreadyQueued workerState - missingStorePaths <- Push.getMissingPathsForClosure Nothing pushParams storePaths + missingStorePaths <- Push.getMissingPathsForClosure pushParams storePaths let missingStorePathsSet = S.fromList missingStorePaths uncachedMissingStorePaths = S.difference missingStorePathsSet alreadyQueuedSet atomically $ for_ uncachedMissingStorePaths $ TBQueue.writeTBQueue pushqueue diff --git a/src/Cachix/Client/Store.hs b/src/Cachix/Client/Store.hs deleted file mode 100644 --- a/src/Cachix/Client/Store.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Cachix.Client.Store - ( -- * Opening a store - LocalStoreOptions (..), - withLocalStore, - withStore, - Store (..), - - -- * Working store contents - PathInfo (..), - StorePath (..), - getUseSqliteWAL, - base16to32, - computeClosure, - queryPathInfo, - followLinksToStorePath, - getStorePathHash, - getStorePathBaseName, - getPath, - ) -where - -import Cachix.Client.ProcessGraph (processGraph) -import Data.ByteArray.Encoding (Base (..), convertFromBase) -import qualified Data.Set as Set -import qualified Data.Text as T -import Database.SQLite3 (SQLData) -import qualified Database.SQLite3 as SQLite -import Protolude hiding (toS) -import Protolude.Conv -import System.Console.Pretty (Color (..), color) -import System.Directory (canonicalizePath) -import qualified System.Nix.Base32 -import System.Process (readProcessWithExitCode) - -type StorePrefix = Text - -data Store = Store StorePrefix SQLite.Database - -data StorePath = StorePath Text - deriving (Eq, Ord) - -data PathInfo = PathInfo - { deriver :: Maybe Text, - narSize :: Int64, - narHash :: Text, - references :: [Text] - } - -followLinksToStorePath :: Text -> FilePath -> IO FilePath -followLinksToStorePath prefix path = do - storePath <- canonicalizePath path - let storePath' = T.drop (T.length prefix) (toS storePath) - return $ toS $ prefix <> T.intercalate "/" (take 3 $ T.splitOn "/" storePath') - --- | Options for `withLocalStore`. -data LocalStoreOptions = LocalStoreOptions - { -- | The path to the Nix store directory. Typically: @"/nix"@ - storePrefix :: !Text, - -- | Whether to use SQLite Write-Ahead Logging (WAL) mode. - -- - -- This needs to match the ambient configuration, because otherwise, the db - -- may be corrupted: https://github.com/cachix/cachix/issues/475 - useSqliteWAL :: !Bool - } - --- | Run an 'IO' action while retaining a 'Store' resource for the duration of the action. --- --- This does not rely on the @nix@ command being available. -withLocalStore :: LocalStoreOptions -> (Store -> IO a) -> IO a -withLocalStore opts = - bracket open close - where - uri = "file:" <> toS (storePrefix opts) <> "/var/nix/db/db.sqlite?immutable=1" - flags = [SQLite.SQLOpenReadOnly, SQLite.SQLOpenURI] - close (Store _ db) = SQLite.close db - vfs = - if useSqliteWAL opts - then SQLite.SQLVFSDefault - else SQLite.SQLVFSUnixDotFile - open = do - conn <- SQLite.open2 uri flags vfs - return $ Store (storePrefix opts) conn - --- | 'withLocalStore' but infers 'useSqliteWAL' from the @nix show-config@ command. -withStore :: Text -> (Store -> IO a) -> IO a -withStore storePrefix_ f = do - wal <- getUseSqliteWAL - withLocalStore - LocalStoreOptions - { storePrefix = storePrefix_, - useSqliteWAL = wal - } - f - -getUseSqliteWAL :: IO Bool -getUseSqliteWAL = do - (_, out, _) <- readProcessWithExitCode "nix" ["show-config", "--extra-experimental-features", "nix-command"] mempty - pure (not ("use-sqlite-wal = false" `T.isInfixOf` toS out)) - -queryNarinfo :: Text -queryNarinfo = "select id, hash, deriver, narSize from ValidPaths where path = :path" - -queryReferences :: Text -queryReferences = "select path from Refs join ValidPaths on reference = id where referrer = :id" - -query :: Store -> Text -> [(Text, SQLData)] -> IO [[SQLite.SQLData]] -query (Store _ conn) txt bindings = - bracket (SQLite.prepare conn txt) SQLite.finalize $ \stmt -> do - SQLite.bindNamed stmt bindings - getRows stmt - -getRows :: SQLite.Statement -> IO [[SQLite.SQLData]] -getRows stmt = do - SQLite.step stmt >>= \case - SQLite.Row -> do - row <- SQLite.columns stmt - rows <- getRows stmt - return $ row : rows - SQLite.Done -> do - return [] - -queryPathInfo :: Store -> Text -> IO (Either Text PathInfo) -queryPathInfo store path = do - rows <- query store queryNarinfo [(":path", SQLite.SQLText path)] - case rows of - [] -> return $ Left $ "no such path " <> path - [[id_, SQLite.SQLText hash_, deriver, SQLite.SQLInteger narSize]] -> do - references <- query store queryReferences [(":id", id_)] - refs <- traverse go references - return $ - Right $ - PathInfo - { deriver = getDeriver deriver, - narSize = narSize, - narHash = hash_, - references = refs - } - _ -> return $ Left $ "got invalid narinfo from nix " <> show rows - where - go [SQLite.SQLText path_] = return path_ - go a = throwIO $ FatalError $ "invalid reference type " <> show a - - getDeriver :: SQLite.SQLData -> Maybe Text - getDeriver (SQLite.SQLText deriver) = Just deriver - getDeriver _ = Nothing - -computeClosure :: Store -> [StorePath] -> IO [StorePath] -computeClosure store initialPaths = do - allPaths <- - processGraph (getPath <$> initialPaths) $ \path -> do - queryPathInfo store path >>= \case - Left _ -> do - hPutStrLn stderr $ color Yellow $ "Warning: " <> path <> " is not valid, skipping" - return [] - Right pathInfo -> pure $ references pathInfo - return $ StorePath <$> Set.toList allPaths - -getStorePathHash :: Store -> StorePath -> Text -getStorePathHash store storePath = - T.take 32 $ getStorePathBaseName store storePath - -getPath :: StorePath -> Text -getPath (StorePath storePath) = storePath - -getStorePathBaseName :: Store -> StorePath -> Text -getStorePathBaseName (Store storePrefix _) (StorePath storePath) = - dropPrefix (dropSuffix "/" storePrefix <> "/store/") storePath - where - dropPrefix :: Text -> Text -> Text - dropPrefix prefix str = - fromMaybe str (T.stripPrefix prefix str) - - dropSuffix :: Text -> Text -> Text - dropSuffix suffix str = - fromMaybe str (T.stripSuffix suffix str) - -base16to32 :: Text -> Either Text Text -base16to32 path = - case T.splitOn ":" path of - [_, path_] -> convert path_ - [] -> convert path - _ -> Left $ "can't split : for " <> path - where - convert :: Text -> Either Text Text - convert stripped = - case convertFromBase Base16 (toS stripped :: ByteString) of - Left err -> Left $ toS err - Right decoded -> Right $ ("sha256:" <>) $ System.Nix.Base32.encode decoded diff --git a/src/Cachix/Client/WatchStore.hs b/src/Cachix/Client/WatchStore.hs --- a/src/Cachix/Client/WatchStore.hs +++ b/src/Cachix/Client/WatchStore.hs @@ -5,26 +5,28 @@ import Cachix.Client.Push import qualified Cachix.Client.PushQueue as PushQueue -import qualified Cachix.Client.Store as Store import qualified Control.Concurrent.STM.TBQueue as TBQueue +import Hercules.CNix.Store (Store) +import qualified Hercules.CNix.Store as Store import Protolude import System.FSNotify import qualified System.Systemd.Daemon as Systemd -startWorkers :: Int -> PushParams IO () -> IO () -startWorkers numWorkers pushParams = do +startWorkers :: Store -> Int -> PushParams IO () -> IO () +startWorkers store numWorkers pushParams = do void Systemd.notifyReady - withManager $ \mgr -> PushQueue.startWorkers numWorkers (producer mgr) pushParams + withManager $ \mgr -> PushQueue.startWorkers numWorkers (producer store mgr) pushParams -producer :: WatchManager -> PushQueue.Queue -> IO (IO ()) -producer mgr queue = do +producer :: Store -> WatchManager -> PushQueue.Queue -> IO (IO ()) +producer store mgr queue = do putTextError "Watching /nix/store for new store paths ..." - watchDir mgr "/nix/store" filterOnlyStorePaths (queueStorePathAction queue) + watchDir mgr "/nix/store" filterOnlyStorePaths (queueStorePathAction store queue) -queueStorePathAction :: PushQueue.Queue -> Event -> IO () -queueStorePathAction queue (Removed lockFile _ _) = do - atomically $ TBQueue.writeTBQueue queue $ Store.StorePath (toS $ dropLast 5 lockFile) -queueStorePathAction _ _ = return () +queueStorePathAction :: Store -> PushQueue.Queue -> Event -> IO () +queueStorePathAction store queue (Removed lockFile _ _) = do + sp <- Store.parseStorePath store (encodeUtf8 $ toS $ dropLast 5 lockFile) + atomically $ TBQueue.writeTBQueue queue sp +queueStorePathAction _ _ _ = return () dropLast :: Int -> [a] -> [a] dropLast index xs = take (length xs - index) xs diff --git a/src/System/Nix/Base32.hs b/src/System/Nix/Base32.hs new file mode 100644 --- /dev/null +++ b/src/System/Nix/Base32.hs @@ -0,0 +1,39 @@ +module System.Nix.Base32 (encode) where + +-- Copied from hnix-store-core until there's a new release + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Vector as V +import Protolude + +-- | Encode a 'BS.ByteString' in Nix's base32 encoding +encode :: BS.ByteString -> T.Text +encode c = T.pack $ map char32 [nChar - 1, nChar - 2 .. 0] + where + digits32 = V.fromList "0123456789abcdfghijklmnpqrsvwxyz" + -- Each base32 character gives us 5 bits of information, while + -- each byte gives is 8. Because 'div' rounds down, we need to add + -- one extra character to the result, and because of that extra 1 + -- we need to subtract one from the number of bits in the + -- bytestring to cover for the case where the number of bits is + -- already a factor of 5. Thus, the + 1 outside of the 'div' and + -- the - 1 inside of it. + nChar = fromIntegral $ ((BS.length c * 8 - 1) `div` 5) + 1 + byte = BS.index c . fromIntegral + -- May need to switch to a more efficient calculation at some + -- point. + bAsInteger :: Integer + bAsInteger = + sum + [ fromIntegral (byte j) * (256 ^ j) + | j <- [0 .. BS.length c - 1] + ] + char32 :: Integer -> Char + char32 i = digits32 V.! digitInd + where + digitInd = + fromIntegral $ + bAsInteger + `div` (32 ^ i) + `mod` 32