packages feed

cachix 1.4.2 → 1.5

raw patch · 14 files changed

+259/−318 lines, 14 filesdep +hercules-ci-cnix-storedep +inline-c-cppdep −direct-sqlite

Dependencies added: hercules-ci-cnix-store, inline-c-cpp

Dependencies removed: direct-sqlite

Files

CHANGELOG.md view
@@ -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
cachix.cabal view
@@ -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
src/Cachix/Client.hs view
@@ -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
+ src/Cachix/Client/CNix.hs view
@@ -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
src/Cachix/Client/Commands.hs view
@@ -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+        }
src/Cachix/Client/Env.hs view
@@ -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
src/Cachix/Client/Exception.hs view
@@ -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
src/Cachix/Client/OptionsParser.hs view
@@ -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 =
− src/Cachix/Client/ProcessGraph.hs 
@@ -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
src/Cachix/Client/Push.hs view
@@ -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
src/Cachix/Client/PushQueue.hs view
@@ -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
− src/Cachix/Client/Store.hs 
@@ -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
src/Cachix/Client/WatchStore.hs view
@@ -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
+ src/System/Nix/Base32.hs view
@@ -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