diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/cachix.cabal b/cachix.cabal --- a/cachix.cabal +++ b/cachix.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cachix -version: 1.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 diff --git a/src/Cachix/Client/CNix.hs b/src/Cachix/Client/CNix.hs deleted file mode 100644 --- a/src/Cachix/Client/CNix.hs +++ /dev/null @@ -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 diff --git a/src/Cachix/Client/Commands.hs b/src/Cachix/Client/Commands.hs --- a/src/Cachix/Client/Commands.hs +++ b/src/Cachix/Client/Commands.hs @@ -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, diff --git a/src/Cachix/Client/Env.hs b/src/Cachix/Client/Env.hs --- a/src/Cachix/Client/Env.hs +++ b/src/Cachix/Client/Env.hs @@ -11,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 diff --git a/src/Cachix/Client/OptionsParser.hs b/src/Cachix/Client/OptionsParser.hs --- a/src/Cachix/Client/OptionsParser.hs +++ b/src/Cachix/Client/OptionsParser.hs @@ -170,7 +170,8 @@ <> help "DEPRECATED: use watch-store command instead." ) use = - Use <$> nameArg + Use + <$> nameArg <*> ( InstallationMode.UseOptions <$> optional ( option diff --git a/src/Cachix/Client/ProcessGraph.hs b/src/Cachix/Client/ProcessGraph.hs new file mode 100644 --- /dev/null +++ b/src/Cachix/Client/ProcessGraph.hs @@ -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 diff --git a/src/Cachix/Client/Push.hs b/src/Cachix/Client/Push.hs --- a/src/Cachix/Client/Push.hs +++ b/src/Cachix/Client/Push.hs @@ -34,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 diff --git a/src/Cachix/Client/PushQueue.hs b/src/Cachix/Client/PushQueue.hs --- a/src/Cachix/Client/PushQueue.hs +++ b/src/Cachix/Client/PushQueue.hs @@ -12,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 diff --git a/src/Cachix/Client/Store.hs b/src/Cachix/Client/Store.hs new file mode 100644 --- /dev/null +++ b/src/Cachix/Client/Store.hs @@ -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 diff --git a/src/Cachix/Client/WatchStore.hs b/src/Cachix/Client/WatchStore.hs --- a/src/Cachix/Client/WatchStore.hs +++ b/src/Cachix/Client/WatchStore.hs @@ -5,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 diff --git a/src/Cachix/Deploy/ActivateCommand.hs b/src/Cachix/Deploy/ActivateCommand.hs --- a/src/Cachix/Deploy/ActivateCommand.hs +++ b/src/Cachix/Deploy/ActivateCommand.hs @@ -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" diff --git a/src/Data/Conduit/ByteString.hs b/src/Data/Conduit/ByteString.hs --- a/src/Data/Conduit/ByteString.hs +++ b/src/Data/Conduit/ByteString.hs @@ -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 = diff --git a/src/System/Nix/Base32.hs b/src/System/Nix/Base32.hs deleted file mode 100644 --- a/src/System/Nix/Base32.hs +++ /dev/null @@ -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