cachix 1.3.3 → 1.4
raw patch · 14 files changed
+259/−177 lines, 14 filesdep +direct-sqlitedep −hercules-ci-cnix-storedep −inline-c-cpp
Dependencies added: direct-sqlite
Dependencies removed: hercules-ci-cnix-store, inline-c-cpp
Files
- CHANGELOG.md +7/−0
- cachix.cabal +8/−12
- src/Cachix/Client/CNix.hs +0/−19
- src/Cachix/Client/Commands.hs +8/−10
- src/Cachix/Client/Env.hs +4/−16
- src/Cachix/Client/OptionsParser.hs +2/−1
- src/Cachix/Client/ProcessGraph.hs +32/−0
- src/Cachix/Client/Push.hs +28/−47
- src/Cachix/Client/PushQueue.hs +2/−5
- src/Cachix/Client/Store.hs +142/−0
- src/Cachix/Client/WatchStore.hs +9/−11
- src/Cachix/Deploy/ActivateCommand.hs +8/−8
- src/Data/Conduit/ByteString.hs +9/−9
- src/System/Nix/Base32.hs +0/−39
CHANGELOG.md view
@@ -5,6 +5,13 @@ 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.4] - 2023-03-26++### Changed++- Rewrote C++ bindings to Nix in Haskell, reducing the closure and making it easy to+statically compile Cachix.+ ## [1.3.3] - 2023-03-18 ### Fixed
cachix.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: cachix-version: 1.3.3+version: 1.4 license: Apache-2.0 license-file: LICENSE copyright: 2018 Domen Kozar@@ -45,10 +45,9 @@ 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@@ -60,12 +59,14 @@ 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@@ -80,11 +81,10 @@ 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,20 +102,19 @@ , 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@@ -153,9 +152,6 @@ , 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/CNix.hs
@@ -1,19 +0,0 @@-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
@@ -15,9 +15,9 @@ 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@@ -34,6 +34,7 @@ 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.SigningKeyCreate as SigningKeyCreate@@ -46,7 +47,6 @@ 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,14 +167,12 @@ normalized <- liftIO $ for inputStorePaths $- \path -> do- storePath <- followLinksToStorePath (pushParamsStore pushParams) (encodeUtf8 path)- filterInvalidStorePath (pushParamsStore pushParams) storePath+ \path -> Store.followLinksToStorePath (pushParamsStore pushParams) (toS path) pushedPaths <- pushClosure (mapConcurrentlyBounded (numJobs opts)) pushParams- (catMaybes normalized)+ (Store.StorePath . toS <$> normalized) case (length normalized, length pushedPaths) of (0, _) -> putTextError "Nothing to push." (_, 0) -> putTextError "Nothing to push - all store paths are already on Cachix."@@ -231,14 +229,14 @@ then "" else "(retry #" <> show (rsIterNumber retrystatus) <> ") " -pushStrategy :: Store -> Maybe Token -> PushOptions -> Text -> BinaryCache.CompressionMethod -> StorePath -> PushStrategy IO ()-pushStrategy store authToken opts name compressionMethod storePath =+pushStrategy :: Store.Store -> Maybe Token -> PushOptions -> Text -> BinaryCache.CompressionMethod -> Store.StorePath -> PushStrategy IO ()+pushStrategy _ authToken opts name compressionMethod storePath = PushStrategy { onAlreadyPresent = pass, on401 = handleCacheResponse name authToken, onError = throwM, onAttempt = \retrystatus size -> do- path <- decodeUtf8With lenientDecode <$> storePathToPath store storePath+ let path = Store.getPath 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,@@ -260,7 +258,7 @@ 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])- withStore $ \store ->+ Store.withStore (Env.storePrefix env) $ \store -> m PushParams { pushParamsName = name,
src/Cachix/Client/Env.hs view
@@ -11,8 +11,6 @@ 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,@@ -25,27 +23,16 @@ 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+ config :: Config,+ storePrefix :: Text } 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@@ -60,7 +47,8 @@ Env { cachixoptions = cachixOptions, clientenv = clientEnv,- config = cfg+ config = cfg,+ storePrefix = "/nix" -- https://github.com/cachix/cachix/issues/85 } customManagerSettings :: ManagerSettings
src/Cachix/Client/OptionsParser.hs view
@@ -170,7 +170,8 @@ <> help "DEPRECATED: use watch-store command instead." ) use =- Use <$> nameArg+ Use+ <$> nameArg <*> ( InstallationMode.UseOptions <$> optional ( option
+ src/Cachix/Client/ProcessGraph.hs view
@@ -0,0 +1,32 @@+{-# 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,6 +34,7 @@ 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@@ -44,7 +45,7 @@ import Control.Monad.Trans.Resource (ResourceT) import Control.Retry (RetryStatus) import Crypto.Sign.Ed25519-import qualified Data.ByteString.Base64 as B64+import Data.ByteArray.Encoding (Base (..), convertToBase) import Data.Conduit import qualified Data.Conduit.Lzma as Lzma (compress) import qualified Data.Conduit.Zstd as Zstd (compress)@@ -52,10 +53,6 @@ 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@@ -76,10 +73,10 @@ { pushParamsName :: Text, pushParamsSecret :: PushSecret, -- | how to report results, (some) errors, and do some things- pushParamsStrategy :: StorePath -> PushStrategy m r,+ pushParamsStrategy :: Store.StorePath -> PushStrategy m r, -- | cachix base url, connection manager, see 'Cachix.Client.URI.defaultCachixBaseUrl', 'Servant.Client.mkClientEnv' pushParamsClientEnv :: ClientEnv,- pushParamsStore :: Store+ pushParamsStore :: Store.Store } data PushStrategy m r = PushStrategy@@ -111,12 +108,12 @@ -- | details for pushing to cache PushParams m r -> -- | store path- StorePath ->+ Store.StorePath -> -- | r is determined by the 'PushStrategy' m r pushSingleStorePath cache storePath = retryAll $ \retrystatus -> do- storeHash <- liftIO $ Store.getStorePathHash storePath let name = pushParamsName cache+ store = pushParamsStore cache strategy = pushParamsStrategy cache storePath -- Check if narinfo already exists res <-@@ -126,7 +123,7 @@ cachixClient (getCacheAuthToken (pushParamsSecret cache)) name- (NarInfoHash.NarInfoHash (decodeUtf8With lenientDecode storeHash))+ (NarInfoHash.NarInfoHash (Store.getStorePathHash store storePath)) case res of Right NoContent -> onAlreadyPresent strategy -- we're done as store path is already in the cache Left err@@ -142,14 +139,13 @@ (MonadIO m) => -- | details for pushing to cache PushParams m r ->- StorePath ->+ Store.StorePath -> RetryStatus -> -- | r is determined by the 'PushStrategy' m r uploadStorePath cache storePath retrystatus = do let store = pushParamsStore cache- -- TODO: storePathText is redundant. Use storePath directly.- storePathText <- liftIO $ Store.storePathToPath store storePath+ storePathText = Store.getPath storePath let (storeHash, storeSuffix) = splitStorePath $ toS storePathText cacheName = pushParamsName cache authToken = getCacheAuthToken (pushParamsSecret cache)@@ -168,10 +164,9 @@ narHashRef <- liftIO $ newIORef ("" :: ByteString) fileHashRef <- liftIO $ newIORef ("" :: ByteString) - -- 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+ pathinfo <- liftIO $ escalateAs FatalError =<< Store.queryPathInfo store (toS normalized)+ let storePathSize = Store.narSize pathinfo onAttempt strategy retrystatus storePathSize withCompressor $ \compressor -> liftIO $ do@@ -190,22 +185,19 @@ Right (narId, uploadId, parts) -> do narSize <- readIORef narSizeRef narHash <- ("sha256:" <>) . System.Nix.Base32.encode <$> readIORef narHashRef- 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"+ 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" fileHash <- readIORef fileHashRef fileSize <- readIORef fileSizeRef- 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+ 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 sig = case pushParamsSecret cache of PushToken _ -> Nothing- PushSigningKey _ signKey -> Just $ toS $ B64.encode $ unSignature $ dsign (signingSecretKey signKey) fp+ PushSigningKey _ signKey -> Just $ (toS :: ByteString -> Text) $ convertToBase Base64 $ unSignature $ dsign (signingSecretKey signKey) fp nic = Api.NarInfoCreate { Api.cStoreHash = storeHash,@@ -214,8 +206,8 @@ Api.cNarSize = narSize, Api.cFileSize = fileSize, Api.cFileHash = toS fileHash,- Api.cReferences = references,- Api.cDeriver = maybe "unknown-deriver" (decodeUtf8With lenientDecode) deriver,+ Api.cReferences = Store.getStorePathBaseName store . Store.StorePath <$> references,+ Api.cDeriver = fromMaybe "unknown-deriver" deriver, Api.cSig = sig } escalate $ Api.isNarInfoCreateValid nic@@ -242,26 +234,20 @@ (forall a b. (a -> m b) -> [a] -> m [b]) -> PushParams m r -> -- | Initial store paths- [StorePath] ->+ [Store.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 -> [StorePath] -> m [StorePath]+getMissingPathsForClosure :: (MonadIO m, MonadMask m) => PushParams m r -> [Store.StorePath] -> m [Store.StorePath] getMissingPathsForClosure pushParams inputPaths = do let store = pushParamsStore pushParams clientEnv = pushParamsClientEnv pushParams -- Get the transitive closure of dependencies- (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)+ paths <- liftIO $ Store.computeClosure store inputPaths+ let pathsAndHashes = (\path -> (,) (Store.getStorePathHash store path) path) <$> paths -- Check what store paths are missing missingHashesList <- retryAll $ \_ ->@@ -272,14 +258,9 @@ cachixClient (getCacheAuthToken (pushParamsSecret pushParams)) (pushParamsName pushParams)- hashes+ (map fst pathsAndHashes) )- let missingHashes = Set.fromList (encodeUtf8 <$> missingHashesList)- pathsAndHashes <- liftIO $- for paths $- \path -> do- hash_ <- Store.getStorePathHash path- pure (hash_, path)+ let missingHashes = Set.fromList missingHashesList 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,16 +12,15 @@ ) 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@@ -45,9 +44,7 @@ bracket_ (inProgressModify (+ 1)) (inProgressModify (\x -> x - 1)) $ retryAll $ \retrystatus -> do- maybeStorePath <- filterInvalidStorePath (Push.pushParamsStore pushParams) storePath- for_ maybeStorePath $ \validatedStorePath ->- Push.uploadStorePath pushParams validatedStorePath retrystatus+ Push.uploadStorePath pushParams storePath retrystatus where inProgressModify f = atomically $ modifyTVar' (inProgress workerState) f
+ src/Cachix/Client/Store.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}++module Cachix.Client.Store (withStore, Store, PathInfo (..), StorePath (..), 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 :: Store -> FilePath -> IO FilePath+followLinksToStorePath (Store 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')++withStore :: Text -> (Store -> IO ()) -> IO ()+withStore storePrefix =+ bracket open close+ where+ uri = "file:" <> toS storePrefix <> "/var/nix/db/db.sqlite?immutable=1"+ flags = [SQLite.SQLOpenReadOnly, SQLite.SQLOpenURI]+ close (Store _ db) = SQLite.close db+ open = do+ (_, out, _) <- readProcessWithExitCode "nix" ["show-config", "--extra-experimental-features", "nix-command"] mempty+ let vfs =+ if "use-sqlite-wal = false" `T.isInfixOf` toS out+ then SQLite.SQLVFSUnixDotFile+ else SQLite.SQLVFSDefault+ conn <- SQLite.open2 uri flags vfs+ return $ Store storePrefix conn++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,28 +5,26 @@ 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 :: Store -> Int -> PushParams IO () -> IO ()+startWorkers :: Store.Store -> Int -> PushParams IO () -> IO () startWorkers store numWorkers pushParams = do void Systemd.notifyReady withManager $ \mgr -> PushQueue.startWorkers numWorkers (producer store mgr) pushParams -producer :: Store -> WatchManager -> PushQueue.Queue -> IO (IO ())-producer store mgr queue = do+producer :: Store.Store -> WatchManager -> PushQueue.Queue -> IO (IO ())+producer _ mgr queue = do putTextError "Watching /nix/store for new store paths ..."- watchDir mgr "/nix/store" filterOnlyStorePaths (queueStorePathAction store queue)+ watchDir mgr "/nix/store" filterOnlyStorePaths (queueStorePathAction queue) -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 ()+queueStorePathAction :: PushQueue.Queue -> Event -> IO ()+queueStorePathAction queue (Removed lockFile _ _) = do+ atomically $ TBQueue.writeTBQueue queue $ Store.StorePath (toS $ dropLast 5 lockFile)+queueStorePathAction _ _ = return () dropLast :: Int -> [a] -> [a] dropLast index xs = take (length xs - index) xs
src/Cachix/Deploy/ActivateCommand.hs view
@@ -151,18 +151,18 @@ renderOverview :: [(Text, DeployResponse.Details)] -> Text renderOverview agents = Text.intercalate "\n" $- "Deploying agents:" :- [ inBrackets agentName <> " " <> DeployResponse.url details- | (agentName, details) <- agents- ]+ "Deploying agents:"+ : [ inBrackets agentName <> " " <> DeployResponse.url details+ | (agentName, details) <- agents+ ] renderSummary :: [(Text, Deployment.Deployment)] -> Text renderSummary results = Text.intercalate "\n" $- "Deployment summary:" :- [ inBrackets agentName <> " " <> renderStatus (Deployment.status deployment)- | (agentName, deployment) <- results- ]+ "Deployment summary:"+ : [ inBrackets agentName <> " " <> renderStatus (Deployment.status deployment)+ | (agentName, deployment) <- results+ ] where renderStatus = \case Deployment.Succeeded -> "Deployed successfully"
src/Data/Conduit/ByteString.hs view
@@ -47,15 +47,15 @@ loop front idxIn s@(S fptr ptr idxOut) | idxIn >= BS.length input = return (front [], s) | otherwise = do- pokeByteOff ptr idxOut (unsafeIndex input idxIn)- let idxOut' = idxOut + 1- idxIn' = idxIn + 1- if idxOut' >= chunkSize- then do- let bs = PS fptr 0 idxOut'- s' <- newS chunkSize- loop (front . (bs :)) idxIn' s'- else loop front idxIn' (S fptr ptr idxOut')+ pokeByteOff ptr idxOut (unsafeIndex input idxIn)+ let idxOut' = idxOut + 1+ idxIn' = idxIn + 1+ if idxOut' >= chunkSize+ then do+ let bs = PS fptr 0 idxOut'+ s' <- newS chunkSize+ loop (front . (bs :)) idxIn' s'+ else loop front idxIn' (S fptr ptr idxOut') processAndChunkOutputRaw :: MonadIO m => ChunkSize -> ConduitT ByteString ByteString m () processAndChunkOutputRaw chunkSize =
− src/System/Nix/Base32.hs
@@ -1,39 +0,0 @@-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