cachix 0.6.0 → 0.6.1

raw patch · 16 files changed

+216/−490 lines, 16 filesdep +hercules-ci-cnix-storedep −inline-cdep −inline-c-cppPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hercules-ci-cnix-store

Dependencies removed: inline-c, inline-c-cpp

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• cachix.cabal +10/−23
• cbits/aliases.h +0/−8
• src/Cachix/Client/Commands.hs +26/−18
• src/Cachix/Client/Config.hs +9/−11
• src/Cachix/Client/Env.hs +7/−8
• src/Cachix/Client/InstallationMode.hs +18/−20
• src/Cachix/Client/NixVersion.hs +13/−1
• src/Cachix/Client/OptionsParser.hs +15/−14
• src/Cachix/Client/Push.hs +76/−68
• src/Cachix/Client/PushQueue.hs +13/−16
• src/Cachix/Client/Servant.hs +0/−1
• src/Cachix/Client/Store.hs +0/−250
• src/Cachix/Client/Store/Context.hs +0/−42
• src/Cachix/Client/URI.hs +1/−1
• src/Cachix/Client/WatchStore.hs +13/−9

@@ -7,6 +7,21 @@  ## Unreleased +## [0.6.1] - 2021-06-21++### Fixed++- Fix "Empty Stream" error+- #379 & #362: redirect cachix output to stderr+- #380: support having tilde in filepath of the config file++### Changed++- Factor out Store into hercules-ci-cnix-store+- `cachix authtoken` reads from stdin if no token is provided+- improved error message in case nar db hash mismatch happens+- Support LTS-18.0 Stackage+ ## [0.6.0] - 2021-01-08  ### Changed

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               cachix-version: 0.6.0+version: 0.6.1 license:            Apache-2.0 license-file:       LICENSE copyright:          2018 Domen Kožar@@ -16,7 +16,6 @@ extra-source-files:   CHANGELOG.md   README.md-  cbits/aliases.h   test/data/*.input   test/data/*.output @@ -59,8 +58,6 @@     Cachix.Client.Retry     Cachix.Client.Secrets     Cachix.Client.Servant-    Cachix.Client.Store-    Cachix.Client.Store.Context     Cachix.Client.URI     Cachix.Client.WatchStore     System.Nix.Base32@@ -70,30 +67,29 @@   autogen-modules:   Paths_cachix   build-depends:     , async-    , base                  >=4.7     && <5+    , base                    >=4.7     && <5     , base64-bytestring     , bytestring     , cachix-api     , concurrent-extra-    , conduit               >=1.3.0+    , conduit                 >=1.3.0     , conduit-extra     , containers     , cookie     , cryptonite-    , dhall                 >=1.28.0+    , dhall                   >=1.28.0     , directory     , ed25519     , filepath     , fsnotify+    , hercules-ci-cnix-store     , here     , http-client     , http-client-tls     , http-conduit     , http-types-    , inline-c-    , inline-c-cpp     , lzma-conduit-    , megaparsec            >=7.0.0+    , megaparsec              >=7.0.0     , memory     , mmorph     , netrc@@ -103,11 +99,11 @@     , resourcet     , retry     , safe-exceptions-    , servant               >=0.16+    , servant                 >=0.16     , servant-auth-    , servant-auth-client   >=0.3.3.0-    , servant-client        >=0.16-    , servant-client-core   >=0.16+    , servant-auth-client     >=0.3.3.0+    , servant-client          >=0.16+    , servant-client-core     >=0.16     , servant-conduit     , stm     , text@@ -116,16 +112,7 @@     , vector     , versions -  extra-libraries:-    stdc++-    boost_context--  include-dirs:      cbits   pkgconfig-depends: nix-store ==2.0 || >2.0, nix-main ==2.0 || >2.0-  ghc-options:       -optcxx-std=c++17--  if os(osx)-    ghc-options: -pgmc=clang++  executable cachix   import:             defaults

@@ -1,8 +0,0 @@-#pragma once--// inline-c-cpp doesn't seem to handle namespace operator or template-// syntax so we help it a bit for now. This definition can be inlined-// when it is supported by inline-c-cpp.-typedef nix::ref<nix::Store> refStore;-typedef nix::ref<const nix::ValidPathInfo> refValidPathInfo;-typedef nix::PathSet::iterator PathSetIterator;

@@ -48,6 +48,9 @@ import qualified Data.ByteString.Base64 as B64 import Data.String.Here 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) import Network.HTTP.Types (status401, status404) import Protolude hiding (toS) import Protolude.Conv@@ -60,12 +63,13 @@ import qualified System.Posix.Signals as Signals import qualified System.Process -authtoken :: Env -> Text -> IO ()-authtoken env token = do+authtoken :: Env -> Maybe Text -> IO ()+authtoken env (Just token) = do   -- TODO: check that token actually authenticates!   writeConfig (configPath (cachixoptions env)) $ case config env of     Just cfg -> Config.setAuthToken cfg $ Token (toS token)     Nothing -> mkConfig token+authtoken env Nothing = authtoken env . Just . T.strip =<< T.IO.getContents  generateKeypair :: Env -> Text -> IO () generateKeypair env name = do@@ -156,11 +160,12 @@       -- This is somewhat like the behavior of `cat` for example.       (_, paths) -> return paths   pushParams <- getPushParams env opts name+  normalized <- liftIO $ for inputStorePaths (followLinksToStorePath (pushParamsStore pushParams) . encodeUtf8)   void $     pushClosure       (mapConcurrentlyBounded (numJobs opts))       pushParams-      inputStorePaths+      normalized   putText "All done." push _ _ = do   throwIO $ DeprecatedCommand "DEPRECATED: cachix watch-store has replaced cachix push --watch-store."@@ -168,21 +173,23 @@ watchStore :: Env -> PushOptions -> Text -> IO () watchStore env opts name = do   pushParams <- getPushParams env opts name-  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 = do   pushParams <- getPushParams env pushOpts name-  let watch = WatchStore.startWorkers (numJobs pushOpts) pushParams-  (_, exitCode) <- concurrently watch run+  stdoutOriginal <- hDuplicate stdout+  let process = (System.Process.proc (toS cmd) (toS <$> args)) {System.Process.std_out = System.Process.UseHandle stdoutOriginal}+      watch = do+        hDuplicateTo stderr stdout -- redirect all stdout to stderr+        WatchStore.startWorkers (pushParamsStore pushParams) (numJobs pushOpts) pushParams++  (_, exitCode) <- concurrently watch $ do+    (_, _, _, processHandle) <- System.Process.createProcess process+    exitCode <- System.Process.waitForProcess processHandle+    Signals.raiseSignal Signals.sigINT+    return exitCode   exitWith exitCode-  where-    process = System.Process.proc (toS cmd) (toS <$> args)-    run = do-      (_, _, _, processHandle) <- System.Process.createProcess process-      exitCode <- System.Process.waitForProcess processHandle-      Signals.raiseSignal Signals.sigINT-      return exitCode  retryText :: RetryStatus -> Text retryText retrystatus =@@ -190,8 +197,8 @@     then ""     else "(retry #" <> show (rsIterNumber retrystatus) <> ") " -pushStrategy :: Env -> PushOptions -> Text -> Text -> PushStrategy IO ()-pushStrategy env opts name storePath =+pushStrategy :: Store -> Env -> PushOptions -> Text -> StorePath -> PushStrategy IO ()+pushStrategy store env opts name storePath =   PushStrategy     { onAlreadyPresent = pass,       on401 =@@ -199,9 +206,10 @@           then throwM $ accessDeniedBinaryCache name           else throwM $ notAuthenticatedBinaryCache name,       onError = throwM,-      onAttempt = \retrystatus size ->+      onAttempt = \retrystatus size -> do+        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 and pushing " <> storePath <> " (" <> humanSize (fromIntegral size) <> ")\n",+        putStr $ retryText retrystatus <> "compressing and pushing " <> path <> " (" <> humanSize (fromIntegral size) <> ")\n",       onDone = pass,       withXzipCompressor = defaultWithXzipCompressorWithLevel (compressionLevel opts),       Cachix.Client.Push.omitDeriver = Cachix.Client.OptionsParser.omitDeriver opts@@ -216,6 +224,6 @@       { pushParamsName = name,         pushParamsSecret = pushSecret,         pushParamsClientEnv = clientenv env,-        pushParamsStrategy = pushStrategy env pushOpts name,+        pushParamsStrategy = pushStrategy store env pushOpts name,         pushParamsStore = store       }

@@ -40,18 +40,16 @@     unionFileModes,   ) -data BinaryCacheConfig-  = BinaryCacheConfig-      { name :: Text,-        secretKey :: Text-      }+data BinaryCacheConfig = BinaryCacheConfig+  { name :: Text,+    secretKey :: Text+  }   deriving (Show, Generic, Interpret, Inject) -data Config-  = Config-      { authToken :: Token,-        binaryCaches :: [BinaryCacheConfig]-      }+data Config = Config+  { authToken :: Token,+    binaryCaches :: [BinaryCacheConfig]+  }   deriving (Show, Generic, Interpret, Inject)  mkConfig :: Text -> Config@@ -67,7 +65,7 @@ readConfig filename = do   doesExist <- doesFileExist filename   if doesExist-    then Just <$> input auto (toS filename)+    then Just <$> inputFile auto filename     else return Nothing  getDefaultFilename :: IO FilePath

@@ -8,9 +8,9 @@  import Cachix.Client.Config (Config, readConfig) import Cachix.Client.OptionsParser (CachixOptions (..))-import Cachix.Client.Store (Store, openStore) import Cachix.Client.URI (getBaseUrl) import Data.Version (showVersion)+import Hercules.CNix.Store (Store, openStore) import Network.HTTP.Client   ( ManagerSettings,     managerModifyRequest,@@ -25,13 +25,12 @@ import Servant.Client (ClientEnv, mkClientEnv) import System.Directory (canonicalizePath) -data Env-  = Env-      { config :: Maybe Config,-        clientenv :: ClientEnv,-        cachixoptions :: CachixOptions,-        storeAsync :: Async Store-      }+data Env = Env+  { config :: Maybe Config,+    clientenv :: ClientEnv,+    cachixoptions :: CachixOptions,+    storeAsync :: Async Store+  }  mkEnv :: CachixOptions -> IO Env mkEnv rawcachixoptions = do

@@ -25,16 +25,15 @@ import Protolude import System.Directory (Permissions, createDirectoryIfMissing, getPermissions, writable) import System.Environment (lookupEnv)-import System.FilePath ((</>), replaceFileName)+import System.FilePath (replaceFileName, (</>)) import System.Process (readProcessWithExitCode) import Prelude (String) -data NixEnv-  = NixEnv-      { isTrusted :: Bool,-        isRoot :: Bool,-        isNixOS :: Bool-      }+data NixEnv = NixEnv+  { isTrusted :: Bool,+    isRoot :: Bool,+    isNixOS :: Bool+  }  -- NOTE: update the list of options for --mode argument in OptionsParser.hs data InstallationMode@@ -44,12 +43,11 @@   | UntrustedNixOS   deriving (Show, Eq) -data UseOptions-  = UseOptions-      { useMode :: Maybe InstallationMode,-        useNixOSFolder :: FilePath,-        useOutputDirectory :: Maybe FilePath-      }+data UseOptions = UseOptions+  { useMode :: Maybe InstallationMode,+    useNixOSFolder :: FilePath,+    useOutputDirectory :: Maybe FilePath+  }   deriving (Show)  fromString :: String -> Maybe InstallationMode@@ -94,7 +92,7 @@    nix.trustedUsers = [ "root" "${user}" ]; -    |]+|] addBinaryCache _ _ _ UntrustedRequiresSudo = do   user <- getUser   throwIO $@@ -109,7 +107,7 @@    and then try again:    echo "trusted-users = root ${user}" | sudo tee -a /etc/nix/nix.conf && sudo pkill nix-daemon-    |]+|] addBinaryCache maybeConfig bc useOptions WriteNixOS =   nixosBinaryCache maybeConfig bc useOptions addBinaryCache maybeConfig bc _ (Install ncl) = do@@ -168,7 +166,7 @@ Could not install NixOS configuration to ${dir} due to lack of write permissions.  Pass `--nixos-folder /etc/mynixos/` as an alternative location with write permissions.-      |]+|]     instructions :: Text     instructions =       [iTrim|@@ -182,7 +180,7 @@ Then run:      $ sudo nixos-rebuild switch-    |]+|]     glueModule :: Text     glueModule =       [i|@@ -198,7 +196,7 @@   inherit imports;   nix.binaryCaches = ["https://cache.nixos.org/"]; }-    |]+|]     cacheModule :: Text     cacheModule =       [i|@@ -212,7 +210,7 @@     ];   }; }-    |]+|]  -- TODO: allow overriding netrc location addPrivateBinaryCacheNetRC :: Maybe Config -> BinaryCache.BinaryCache -> NixConf.NixConfLoc -> IO FilePath@@ -233,7 +231,7 @@   return $ writable permissions || user `elem` users || isInAGroup   where     groups :: [Text]-    groups = map T.tail $ filter (\u -> T.head u == '@') users+    groups = map T.tail $ filter (\u -> (fst <$> T.uncons u) == Just '@') users     userInAnyGroup :: Text -> IO Bool     userInAnyGroup user = do       isIn <- for groups $ checkUserInGroup user

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Cachix.Client.NixVersion   ( assertNixVersion,     parseNixVersion,@@ -25,5 +27,15 @@         Left _ -> Left err         Right ver           | verStr == "" -> Left err-          | ver < Ideal (SemVer 2 0 1 [] []) -> Left "Nix 2.0.2 or lower is not supported. Please upgrade: https://nixos.org/nix/"+          | ver < Ideal minimalVersion -> Left "Nix 2.0.2 or lower is not supported. Please upgrade: https://nixos.org/nix/"           | otherwise -> Right ()++minimalVersion :: SemVer+minimalVersion =+  SemVer 2 0 1 []++#if MIN_VERSION_versions(0,5,0)+    Nothing+#else+    []+#endif

@@ -22,12 +22,11 @@     strictURIParserOptions,   ) -data CachixOptions-  = CachixOptions-      { host :: URIRef Absolute,-        configPath :: Config.ConfigPath,-        verbose :: Bool-      }+data CachixOptions = CachixOptions+  { host :: URIRef Absolute,+    configPath :: Config.ConfigPath,+    verbose :: Bool+  }   deriving (Show)  parserCachixOptions :: Config.ConfigPath -> Parser CachixOptions@@ -62,7 +61,7 @@ type BinaryCacheName = Text  data CachixCommand-  = AuthToken Text+  = AuthToken (Maybe Text)   | GenerateKeypair BinaryCacheName   | Push PushArguments   | WatchStore PushOptions Text@@ -76,12 +75,11 @@   | PushWatchStore PushOptions Text   deriving (Show) -data PushOptions-  = PushOptions-      { compressionLevel :: Int,-        numJobs :: Int,-        omitDeriver :: Bool-      }+data PushOptions = PushOptions+  { compressionLevel :: Int,+    numJobs :: Int,+    omitDeriver :: Bool+  }   deriving (Show)  parserCachixCommand :: Parser CachixCommand@@ -95,7 +93,10 @@       <> command "use" (infoH use (progDesc "Configure a binary cache by writing nix.conf and netrc files"))   where     nameArg = strArgument (metavar "CACHE-NAME")-    authtoken = AuthToken <$> strArgument (metavar "AUTH-TOKEN")+    authtoken = AuthToken <$> (stdinFlag <|> (Just <$> authTokenArg))+      where+        stdinFlag = flag' Nothing (long "stdin" <> help "Read the token from stdin rather than accepting it as an argument.")+        authTokenArg = strArgument (metavar "AUTH-TOKEN")     generateKeypair = GenerateKeypair <$> nameArg     validatedLevel l =       l <$ unless (l `elem` [0 .. 9]) (readerError $ "value " <> show l <> " not in expected range: [0..9]")

@@ -31,8 +31,6 @@ import Cachix.Client.Retry (retryAll) import Cachix.Client.Secrets import Cachix.Client.Servant-import Cachix.Client.Store (Store)-import qualified Cachix.Client.Store as Store import qualified Cachix.Types.ByteStringStreaming import qualified Cachix.Types.NarInfoCreate as Api import qualified Cachix.Types.NarInfoHash as NarInfoHash@@ -51,6 +49,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@@ -66,28 +68,26 @@   = PushToken Token   | PushSigningKey Token SigningKey -data PushParams m r-  = PushParams-      { pushParamsName :: Text,-        pushParamsSecret :: PushSecret,-        -- | how to report results, (some) errors, and do some things-        pushParamsStrategy :: Text -> PushStrategy m r,-        -- | cachix base url, connection manager, see 'Cachix.Client.URI.defaultCachixBaseUrl', 'Servant.Client.mkClientEnv'-        pushParamsClientEnv :: ClientEnv,-        pushParamsStore :: Store-      }+data PushParams m r = PushParams+  { pushParamsName :: Text,+    pushParamsSecret :: PushSecret,+    -- | how to report results, (some) errors, and do some things+    pushParamsStrategy :: StorePath -> PushStrategy m r,+    -- | cachix base url, connection manager, see 'Cachix.Client.URI.defaultCachixBaseUrl', 'Servant.Client.mkClientEnv'+    pushParamsClientEnv :: ClientEnv,+    pushParamsStore :: Store+  } -data PushStrategy m r-  = PushStrategy-      { -- | Called when a path is already in the cache.-        onAlreadyPresent :: m r,-        onAttempt :: RetryStatus -> Int64 -> m (),-        on401 :: m r,-        onError :: ClientError -> m r,-        onDone :: m r,-        withXzipCompressor :: forall a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a,-        omitDeriver :: Bool-      }+data PushStrategy m r = PushStrategy+  { -- | Called when a path is already in the cache.+    onAlreadyPresent :: m r,+    onAttempt :: RetryStatus -> Int64 -> m (),+    on401 :: m r,+    onError :: ClientError -> m r,+    onDone :: m r,+    withXzipCompressor :: forall a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a,+    omitDeriver :: Bool+  }  defaultWithXzipCompressor :: forall m a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a defaultWithXzipCompressor = ($ compress (Just 2))@@ -100,21 +100,22 @@   -- | details for pushing to cache   PushParams m r ->   -- | store path-  Text ->+  StorePath ->   -- | r is determined by the 'PushStrategy'   m r pushSingleStorePath cache storePath = retryAll $ \retrystatus -> do-  let storeHash = fst $ splitStorePath $ toS storePath-      name = pushParamsName cache+  storeHash <- liftIO $ Store.getStorePathHash storePath+  let name = pushParamsName cache       strategy = pushParamsStrategy cache storePath   -- Check if narinfo already exists   res <--    liftIO $ (`runClientM` pushParamsClientEnv cache) $-      API.narinfoHead-        cachixClient-        (getCacheAuthToken (pushParamsSecret cache))-        name-        (NarInfoHash.NarInfoHash storeHash)+    liftIO $+      (`runClientM` pushParamsClientEnv cache) $+        API.narinfoHead+          cachixClient+          (getCacheAuthToken (pushParamsSecret cache))+          name+          (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@@ -130,24 +131,27 @@   (MonadMask m, MonadIO m) =>   -- | details for pushing to cache   PushParams m r ->-  Text ->+  StorePath ->   RetryStatus ->   -- | r is determined by the 'PushStrategy'   m r uploadStorePath cache storePath retrystatus = do-  let (storeHash, storeSuffix) = splitStorePath $ toS storePath+  let store = pushParamsStore cache+  -- TODO: storePathText is redundant. Use storePath directly.+  storePathText <- liftIO $ Store.storePathToPath store storePath+  let (storeHash, storeSuffix) = splitStorePath $ toS storePathText       name = pushParamsName cache-      store = pushParamsStore cache       clientEnv = pushParamsClientEnv cache       strategy = pushParamsStrategy cache storePath   narSizeRef <- liftIO $ newIORef 0   fileSizeRef <- liftIO $ newIORef 0   narHashRef <- liftIO $ newIORef ("" :: ByteString)   fileHashRef <- liftIO $ newIORef ("" :: ByteString)-  normalized <- liftIO $ Store.followLinksToStorePath store $ toS storePath+  -- This should be a noop because storePathText came from a StorePath+  normalized <- liftIO $ Store.followLinksToStorePath store $ toS storePathText   pathinfo <- liftIO $ Store.queryPathInfo store normalized   -- stream store path as xz compressed nar file-  let cmd = proc "nix-store" ["--dump", toS storePath]+  let cmd = proc "nix-store" ["--dump", toS storePathText]       storePathSize :: Int64       storePathSize = Store.validPathInfoNarSize pathinfo   onAttempt strategy retrystatus storePathSize@@ -172,28 +176,30 @@             { baseUrl = (baseUrl clientEnv) {baseUrlHost = subdomain <> "." <> baseUrlHost (baseUrl clientEnv)}             }     (_ :: NoContent) <--      liftIO-        $ (`withClientM` newClientEnv)+      liftIO $+        (`withClientM` newClientEnv)           (API.createNar cachixClient (getCacheAuthToken (pushParamsSecret cache)) name (mapOutput coerce stream'))-        $ escalate-          >=> \NoContent -> do-            exitcode <- waitForStreamingProcess cph-            when (exitcode /= ExitSuccess) $ throwM $ NarStreamingError exitcode $ show cmd-            return NoContent+          $ escalate+            >=> \NoContent -> do+              exitcode <- waitForStreamingProcess cph+              when (exitcode /= ExitSuccess) $ throwM $ NarStreamingError exitcode $ show cmd+              return NoContent     (_ :: NoContent) <- liftIO $ do       narSize <- readIORef narSizeRef       narHash <- ("sha256:" <>) . System.Nix.Base32.encode <$> readIORef narHashRef-      narHashNix <- Store.validPathInfoNarHash pathinfo-      when (narHash /= toS narHashNix) $ throwM $ NarHashMismatch "Nar hash mismatch between nix-store --dump and nix db"+      narHashNix <- Store.validPathInfoNarHash32 pathinfo+      when (narHash /= toS narHashNix) $ throwM $ NarHashMismatch "Nar hash mismatch between nix-store --dump and nix db. You can repair db metadata by running as root: $ nix-store --verify --repair"       fileHash <- readIORef fileHashRef       fileSize <- readIORef fileSizeRef-      deriver <-+      deriverPath <-         if omitDeriver strategy-          then pure Store.unknownDeriver-          else toS <$> Store.validPathInfoDeriver pathinfo-      referencesPathSet <- Store.validPathInfoReferences pathinfo-      references <- sort <$> Store.traversePathSet (pure . toS) referencesPathSet-      let fp = fingerprint storePath narHash narSize references+          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, authToken) = case pushParamsSecret cache of             PushToken token -> (Nothing, token)             PushSigningKey token signKey -> (Just $ toS $ B64.encode $ unSignature $ dsign (signingSecretKey signKey) fp, token)@@ -205,11 +211,8 @@                 Api.cNarSize = narSize,                 Api.cFileSize = fileSize,                 Api.cFileHash = toS fileHash,-                Api.cReferences = fmap (T.drop 11) references,-                Api.cDeriver =-                  if deriver == Store.unknownDeriver-                    then deriver-                    else T.drop 11 deriver,+                Api.cReferences = references,+                Api.cDeriver = maybe "unknown-deriver" (decodeUtf8With lenientDecode) deriver,                 Api.cSig = sig               }       escalate $ Api.isNarInfoCreateValid nic@@ -234,26 +237,26 @@   (forall a b. (a -> m b) -> [a] -> m [b]) ->   PushParams m r ->   -- | Initial store paths-  [Text] ->+  [StorePath] ->   -- | Every @r@ per store path of the entire closure of store paths   m [r] pushClosure traversal pushParams inputStorePaths = do   missingPaths <- getMissingPathsForClosure pushParams inputStorePaths   traversal (\path -> retryAll $ \retrystatus -> uploadStorePath pushParams path retrystatus) missingPaths -getMissingPathsForClosure :: (MonadIO m, MonadMask m) => PushParams m r -> [Text] -> m [Text]-getMissingPathsForClosure pushParams inputStorePaths = do+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 <-+  (paths :: [Store.StorePath]) <-     liftIO $ do-      inputs <- Store.newEmptyPathSet-      for_ inputStorePaths $ \path -> do-        normalized <- Store.followLinksToStorePath store (encodeUtf8 path)-        Store.addToPathSet normalized inputs+      inputs <- Std.Set.new+      for_ inputPaths $ \path -> do+        Std.Set.insertFP inputs path       closure <- Store.computeFSClosure store Store.defaultClosureParams inputs-      Store.traversePathSet (pure . toSL) closure+      Std.Set.toListFP closure+  hashes <- for paths (liftIO . fmap (decodeUtf8With lenientDecode) . Store.getStorePathHash)   -- Check what store paths are missing   missingHashesList <-     retryAll $ \_ ->@@ -264,9 +267,14 @@                 cachixClient                 (getCacheAuthToken (pushParamsSecret pushParams))                 (pushParamsName pushParams)-                (fst . splitStorePath <$> paths)+                hashes           )-  return $ filter (\path -> Set.member (fst (splitStorePath path)) (Set.fromList missingHashesList)) paths+  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 

@@ -19,32 +19,29 @@ 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 -type StorePath = Text- type Queue = TBQueue.TBQueue StorePath -data PushWorkerState-  = PushWorkerState-      { pushQueue :: Queue,-        inProgress :: TVar Int-      }+data PushWorkerState = PushWorkerState+  { pushQueue :: Queue,+    inProgress :: TVar Int+  } -data QueryWorkerState-  = QueryWorkerState-      { queryQueue :: Queue,-        alreadyQueued :: S.Set StorePath,-        lock :: Lock.Lock-      }+data QueryWorkerState = QueryWorkerState+  { queryQueue :: Queue,+    alreadyQueued :: S.Set StorePath,+    lock :: Lock.Lock+  }  worker :: Push.PushParams IO () -> PushWorkerState -> IO () worker pushParams workerState = forever $ do   storePath <- atomically $ TBQueue.readTBQueue $ pushQueue workerState-  bracket_ (inProgresModify (+ 1)) (inProgresModify (\x -> x - 1))-    $ retryAll-    $ Push.uploadStorePath pushParams storePath+  bracket_ (inProgresModify (+ 1)) (inProgresModify (\x -> x - 1)) $+    retryAll $+      Push.uploadStorePath pushParams storePath   where     inProgresModify f =       atomically $ modifyTVar' (inProgress workerState) f

@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -O0 #-} 

@@ -1,250 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module Cachix.Client.Store-  ( Store,--    -- * Getting a Store-    openStore,-    releaseStore,--    -- * Query a path-    followLinksToStorePath,-    queryPathInfo,-    validPathInfoNarSize,-    validPathInfoNarHash,-    validPathInfoDeriver,-    unknownDeriver,-    validPathInfoReferences,--    -- * Get closures-    computeFSClosure,-    ClosureParams (..),-    defaultClosureParams,-    PathSet,-    newEmptyPathSet,-    addToPathSet,-    traversePathSet,--    -- * Miscellaneous-    storeUri,-  )-where--import Cachix.Client.Store.Context (NixStore, Ref, ValidPathInfo, context)-import qualified Cachix.Client.Store.Context as C hiding (context)-import Data.ByteString.Unsafe (unsafePackMallocCString)-import Data.Coerce-import Foreign.ForeignPtr-import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Inline.Cpp.Exceptions as C-import Protolude-import System.IO.Unsafe (unsafePerformIO)--C.context context--C.include "<cstring>"--C.include "<nix/config.h>"--C.include "<nix/shared.hh>"--C.include "<nix/store-api.hh>"--C.include "<nix/get-drvs.hh>"--C.include "<nix/derivations.hh>"--C.include "<nix/affinity.hh>"--C.include "<nix/globals.hh>"--C.include "aliases.h"--C.using "namespace nix"---- | TODO: foreignptr-newtype Store = Store (Ptr (Ref NixStore))--openStore :: IO Store-openStore =-  coerce-    [C.throwBlock| refStore* {-      refStore s = openStore();-      return new refStore(s);-    } |]--releaseStore :: Store -> IO ()-releaseStore (Store store) = [C.exp| void { delete $(refStore* store) } |]---- | Follow symlinks to the store and chop off the parts after the top-level store name-followLinksToStorePath :: Store -> ByteString -> IO ByteString-followLinksToStorePath (Store store) bs =-  unsafePackMallocCString-    =<< [C.throwBlock| const char *{-    return strdup((*$(refStore* store))->followLinksToStorePath(std::string($bs-ptr:bs, $bs-len:bs)).c_str());-  }|]--storeUri :: Store -> IO ByteString-storeUri (Store store) =-  unsafePackMallocCString-    =<< [C.throwBlock| const char* {-             std::string uri = (*$(refStore* store))->getUri();-             return strdup(uri.c_str());-           } |]--queryPathInfo ::-  Store ->-  -- | Exact store path, not a subpath-  ByteString ->-  -- | ValidPathInfo or exception-  IO (ForeignPtr (Ref ValidPathInfo))-queryPathInfo (Store store) path = do-  vpi <--    [C.throwBlock| refValidPathInfo*-      {-        return new refValidPathInfo((*$(refStore* store))->queryPathInfo($bs-cstr:path));-      } |]-  newForeignPtr finalizeRefValidPathInfo vpi--finalizeRefValidPathInfo :: FinalizerPtr (Ref ValidPathInfo)-{-# NOINLINE finalizeRefValidPathInfo #-}-finalizeRefValidPathInfo =-  unsafePerformIO-    [C.exp|-  void (*)(refValidPathInfo *) {-    [](refValidPathInfo *v){ delete v; }-  } |]---- | The narSize field of a ValidPathInfo struct. Source: store-api.hh-validPathInfoNarSize :: ForeignPtr (Ref ValidPathInfo) -> Int64-validPathInfoNarSize vpi =-  fromIntegral $-    toInteger-      [C.pure| long-        { (*$fptr-ptr:(refValidPathInfo* vpi))->narSize }-      |]---- | Copy the narHash field of a ValidPathInfo struct. Source: store-api.hh-validPathInfoNarHash :: ForeignPtr (Ref ValidPathInfo) -> IO ByteString-validPathInfoNarHash vpi =-  unsafePackMallocCString-    =<< [C.exp| const char-        *{ strdup((*$fptr-ptr:(refValidPathInfo* vpi))->narHash.to_string().c_str()) }-      |]---- | Deriver field of a ValidPathInfo struct. Source: store-api.hh------ Returns 'unknownDeriver' when missing.-validPathInfoDeriver :: ForeignPtr (Ref ValidPathInfo) -> IO ByteString-validPathInfoDeriver vpi =-  unsafePackMallocCString-    =<< [C.throwBlock| const char*-        {-          std::optional<Path> deriver = (*$fptr-ptr:(refValidPathInfo* vpi))->deriver;-          return strdup((deriver == "" ? "unknown-deriver" : deriver->c_str()));-        }-      |]---- | String constant representing the case when the deriver of a store path does--- not exist or is not known. Value: @unknown-deriver@-unknownDeriver :: Text-unknownDeriver = "unknown-deriver"---- | References field of a ValidPathInfo struct. Source: store-api.hh-validPathInfoReferences :: ForeignPtr (Ref ValidPathInfo) -> IO PathSet-validPathInfoReferences vpi = do-  ptr <--    [C.exp| const PathSet*-            { new PathSet((*$fptr-ptr:(refValidPathInfo* vpi))->references) }-        |]-  fptr <- newForeignPtr finalizePathSet ptr-  pure $ PathSet fptr------- PathSet ------newtype PathSet = PathSet (ForeignPtr (C.Set C.CxxString))--finalizePathSet :: FinalizerPtr C.PathSet-{-# NOINLINE finalizePathSet #-}-finalizePathSet =-  unsafePerformIO-    [C.exp|-  void (*)(PathSet *) {-    [](PathSet *v){-      delete v;-    }-  } |]--newEmptyPathSet :: IO PathSet-newEmptyPathSet = do-  ptr <- [C.exp| PathSet *{ new PathSet() }|]-  fptr <- newForeignPtr finalizePathSet ptr-  pure $ PathSet fptr--addToPathSet :: ByteString -> PathSet -> IO ()-addToPathSet bs pathSet_ = withPathSet pathSet_ $ \pathSet ->-  [C.throwBlock| void { -    $(PathSet *pathSet)->insert(std::string($bs-ptr:bs, $bs-len:bs));-  }|]--withPathSet :: PathSet -> (Ptr C.PathSet -> IO b) -> IO b-withPathSet (PathSet pathSetFptr) = withForeignPtr pathSetFptr--traversePathSet :: forall a. (ByteString -> IO a) -> PathSet -> IO [a]-traversePathSet f pathSet_ = withPathSet pathSet_ $ \pathSet -> do-  i <- [C.exp| PathSetIterator *{ new PathSetIterator($(PathSet *pathSet)->begin()) }|]-  end <- [C.exp| PathSetIterator *{ new PathSetIterator ($(PathSet *pathSet)->end()) }|]-  let cleanup =-        [C.throwBlock| void {-          delete $(PathSetIterator *i);-          delete $(PathSetIterator *end);-        }|]-  flip finally cleanup $-    let go :: ([a] -> [a]) -> IO [a]-        go acc = do-          isDone <--            [C.exp| int {-            *$(PathSetIterator *i) == *$(PathSetIterator *end)-          }|]-          if isDone /= 0-            then pure $ acc []-            else do-              somePath <- unsafePackMallocCString =<< [C.exp| const char *{ strdup((*$(PathSetIterator *i))->c_str()) } |]-              a <- f somePath-              [C.throwBlock| void { (*$(PathSetIterator *i))++; } |]-              go (acc . (a :))-     in go identity------- computeFSClosure ------data ClosureParams-  = ClosureParams-      { flipDirection :: Bool,-        includeOutputs :: Bool,-        includeDerivers :: Bool-      }--defaultClosureParams :: ClosureParams-defaultClosureParams =-  ClosureParams-    { flipDirection = False,-      includeOutputs = False,-      includeDerivers = False-    }--computeFSClosure :: Store -> ClosureParams -> PathSet -> IO PathSet-computeFSClosure (Store store) params startingSet_ = withPathSet startingSet_ $ \startingSet -> do-  let countTrue :: Bool -> C.CInt-      countTrue True = 1-      countTrue False = 0-      flipDir = countTrue $ flipDirection params-      inclOut = countTrue $ includeOutputs params-      inclDrv = countTrue $ includeDerivers params-  ps <--    [C.throwBlock| PathSet* {-             PathSet *r = new PathSet();-             (*$(refStore* store))->computeFSClosure(*$(PathSet *startingSet), *r, $(int flipDir), $(int inclOut), $(int inclDrv));-             return r;-           } |]-  fp <- newForeignPtr finalizePathSet ps-  pure $ PathSet fp

@@ -1,42 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Cachix.Client.Store.Context where--import qualified Data.Map as M-import qualified Language.C.Inline.Context as C-import qualified Language.C.Inline.Cpp as C-import qualified Language.C.Types as C-import Protolude hiding (Set)---- | A Nix @ref@-data Ref a---- | A Nix @PathSet@ aka @std::set<Path>@ aka @std::set<std::string>>@-type PathSet = Set CxxString--data NixStore--data ValidPathInfo---- | An STL @set@-data Set a---- | An STL @::iterator@-data Iterator a---- | An @std::string@-data CxxString--context :: C.Context-context =-  C.cppCtx <> C.fptrCtx <> C.bsCtx-    <> mempty-      { C.ctxTypesTable =-          M.singleton (C.TypeName "refStore") [t|Ref NixStore|]-            <> M.singleton-              (C.TypeName "refValidPathInfo")-              [t|Ref ValidPathInfo|]-            <> M.singleton (C.TypeName "PathSet") [t|PathSet|]-            <> M.singleton (C.TypeName "PathSetIterator") [t|Iterator PathSet|]-      }

@@ -11,8 +11,8 @@ import Protolude hiding (toS) import Protolude.Conv import Servant.Client-import qualified URI.ByteString as UBS import URI.ByteString hiding (Scheme)+import qualified URI.ByteString as UBS import URI.ByteString.QQ  -- TODO: make getBaseUrl internal

@@ -7,21 +7,25 @@ import qualified Cachix.Client.PushQueue as PushQueue import qualified Control.Concurrent.STM.TBQueue as TBQueue import Data.List (isSuffixOf)+import Hercules.CNix.Store (Store)+import qualified Hercules.CNix.Store as Store import Protolude import System.FSNotify -startWorkers :: Int -> PushParams IO () -> IO ()-startWorkers numWorkers pushParams = do-  withManager $ \mgr -> PushQueue.startWorkers numWorkers (producer mgr) pushParams+startWorkers :: Store -> Int -> PushParams IO () -> IO ()+startWorkers store numWorkers pushParams = do+  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   putText "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 _ _) = atomically $ TBQueue.writeTBQueue queue (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