diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,17 @@ 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.10.0] - 2026-01-06 + +### Added + +- `cachix doctor`: a new command for diagnostics that validates the configuration, auth token, and cache connectivity +- `cachix daemon doctor`: a new command for daemon-specific diagnostics + +### Fixed + +- Show the actual error message when store path validation fails instead of a generic "is not valid" message + ## [1.9.2] - 2025-12-11 ### Changes 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.9.2 +version: 1.10.0 synopsis: Command-line client for Nix binary cache hosting https://cachix.org @@ -60,6 +60,7 @@ Cachix.Client.Command Cachix.Client.Command.Cache Cachix.Client.Command.Config + Cachix.Client.Command.Doctor Cachix.Client.Command.Import Cachix.Client.Command.Pin Cachix.Client.Command.Push diff --git a/src/Cachix/Client.hs b/src/Cachix/Client.hs --- a/src/Cachix/Client.hs +++ b/src/Cachix/Client.hs @@ -37,12 +37,14 @@ case command of AuthToken token -> Command.authtoken env token Config configCommand -> Config.run cachixOptions configCommand + Daemon (DaemonDoctor daemonOptions) -> Command.daemonDoctor env daemonOptions Daemon (DaemonRun daemonOptions pushOptions mcacheName) -> Daemon.start env daemonOptions pushOptions mcacheName Daemon (DaemonStop daemonOptions) -> Daemon.Client.stop env daemonOptions Daemon (DaemonPushPaths daemonOptions daemonPushOptions storePaths) -> Daemon.Client.push env daemonOptions daemonPushOptions storePaths Daemon (DaemonWatchExec daemonOptions pushOptions cacheName cmd args) -> Command.watchExecDaemon env pushOptions (daemonNarinfoQueryOptions daemonOptions) cacheName cmd args DeployCommand (DeployOptions.Agent opts) -> AgentCommand.run cachixOptions opts DeployCommand (DeployOptions.Activate opts) -> ActivateCommand.run env opts + Doctor doctorOptions -> Command.doctor env doctorOptions GenerateKeypair name -> Command.generateKeypair env name Import pushOptions name uri -> Command.import' env pushOptions name uri Pin pingArgs -> Command.pin env pingArgs diff --git a/src/Cachix/Client/CNix.hs b/src/Cachix/Client/CNix.hs --- a/src/Cachix/Client/CNix.hs +++ b/src/Cachix/Client/CNix.hs @@ -15,13 +15,22 @@ else return Nothing -- | Like 'validateStorePath', but logs a warning when the path is invalid. +-- +-- When validation fails due to an error (e.g., permission denied), +-- the actual error message is logged instead of a generic "is not valid" message. filterInvalidStorePath :: Store -> StorePath -> IO (Maybe StorePath) filterInvalidStorePath store storePath = do - mstorePath <- validateStorePath store storePath - - when (isNothing mstorePath) (logBadStorePath store storePath) - - return mstorePath + result <- tryValidate + case result of + Right True -> return (Just storePath) + Right False -> do + logBadStorePath store storePath + return Nothing + Left err -> do + logStorePathError store storePath err + return Nothing + where + tryValidate = (Right <$> Store.isValidPath store storePath) `catchNixError` (return . Left) filterInvalidStorePaths :: Store -> [StorePath] -> IO [Maybe StorePath] filterInvalidStorePaths store = @@ -70,6 +79,13 @@ logBadStorePath store storePath = do path <- Store.storePathToPath store storePath logBadPath path + +-- | Print a warning with the actual error when accessing a store path fails. +logStorePathError :: Store -> StorePath -> NixError -> IO () +logStorePathError store storePath (NixError {..}) = do + path <- Store.storePathToPath store storePath + let pathText = decodeUtf8With lenientDecode path + putErrText $ color Yellow $ "Warning: " <> pathText <> " - " <> msg <> ", skipping" -- | Print a warning when the path is invalid. -- diff --git a/src/Cachix/Client/Command.hs b/src/Cachix/Client/Command.hs --- a/src/Cachix/Client/Command.hs +++ b/src/Cachix/Client/Command.hs @@ -3,6 +3,8 @@ Cache.remove, Config.authtoken, Config.generateKeypair, + Doctor.daemonDoctor, + Doctor.doctor, Import.import', Pin.pin, Push.push, @@ -15,6 +17,7 @@ import Cachix.Client.Command.Cache qualified as Cache import Cachix.Client.Command.Config qualified as Config +import Cachix.Client.Command.Doctor qualified as Doctor import Cachix.Client.Command.Import qualified as Import import Cachix.Client.Command.Pin qualified as Pin import Cachix.Client.Command.Push qualified as Push diff --git a/src/Cachix/Client/Command/Doctor.hs b/src/Cachix/Client/Command/Doctor.hs new file mode 100644 --- /dev/null +++ b/src/Cachix/Client/Command/Doctor.hs @@ -0,0 +1,454 @@ +module Cachix.Client.Command.Doctor (daemonDoctor, doctor) where + +import Cachix.API qualified as API +import Cachix.Client.Config qualified as Config +import Cachix.Client.Env (Env (..)) +import Cachix.Client.OptionsParser (DaemonOptions (..), DoctorOptions (..)) +import Cachix.Client.Retry (retryHttp) +import Cachix.Client.Servant (cachixClient, isErr) +import Cachix.Daemon.Listen (getSocketPath) +import Cachix.Daemon.Protocol qualified as Protocol +import Cachix.Types.BinaryCache (BinaryCache (..)) +import Cachix.Types.Permission (Permission (..)) +import Control.Exception.Safe qualified as Exception +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS +import Data.Text qualified as T +import Network.HTTP.Types (status401, status404) +import Network.Socket qualified as Socket +import Network.Socket.ByteString qualified as Socket.BS +import Network.Socket.ByteString.Lazy qualified as Socket.LBS +import Protolude hiding (toS) +import Protolude.Conv +import Servant.Auth.Client +import Servant.Client.Streaming (ClientError, runClientM) +import System.Directory (doesFileExist) +import System.Environment (lookupEnv) +import System.Timeout (timeout) + +-- | Result of a single check +data CheckResult + = CheckOK + | CheckFailed Text + | CheckWarning Text + deriving (Show) + +-- | Result of checking a cache +data CacheCheckResult = CacheCheckResult + { cacheResultName :: Text, + cacheResultUri :: Maybe Text, + cacheResultPublic :: Maybe Bool, + cacheResultPermission :: Maybe Permission, + cacheResultHasSigningKey :: Bool, + cacheResultConnectivity :: CheckResult, + cacheResultAuth :: CheckResult + } + +-- | Result of checking daemon +data DaemonCheckResult + = DaemonNotRunning + | DaemonRunning FilePath (Maybe Protocol.DaemonDiagnostics) + | DaemonConnectionFailed Text + deriving (Show) + +doctor :: Env -> DoctorOptions -> IO () +doctor env opts = do + -- Check if CACHIX_DAEMON_SOCKET is set and warn user + envSocketPath <- lookupEnv "CACHIX_DAEMON_SOCKET" + case envSocketPath of + Just _ -> do + putStrLn ("Note: CACHIX_DAEMON_SOCKET is set. Use 'cachix daemon doctor' for daemon-specific diagnostics." :: Text) + putStrLn ("" :: Text) + Nothing -> return () + + putStrLn ("Cachix Doctor" :: Text) + putStrLn ("=============" :: Text) + putStrLn ("" :: Text) + + -- Configuration checks + configResult <- checkConfiguration env + printConfigResult configResult + + -- Auth check + authResult <- checkAuth env + printAuthResult authResult + + -- Cache checks + cacheResults <- checkCaches env opts + printCacheResults cacheResults + + -- Store path check (if provided) + storePathResult <- case doctorStorePath opts of + Just storePath -> do + result <- checkStorePath env opts storePath + printStorePathResult result + return (Just result) + Nothing -> return Nothing + + -- Summary + let allPassed = configPassed configResult && authPassed authResult && cachesPassed cacheResults && storePathOk storePathResult + putStrLn ("" :: Text) + if allPassed + then putStrLn ("All checks passed." :: Text) + else do + putStrLn ("Some checks failed." :: Text) + exitFailure + +-- | Daemon-specific doctor command +daemonDoctor :: Env -> DaemonOptions -> IO () +daemonDoctor _env opts = do + -- Resolve socket path: CLI option takes precedence over environment variable + envSocketPath <- fmap toS <$> lookupEnv "CACHIX_DAEMON_SOCKET" + let socketPath = daemonSocketPath opts <|> envSocketPath + + putStrLn ("Cachix Daemon Doctor" :: Text) + putStrLn ("====================" :: Text) + putStrLn ("" :: Text) + + -- Check daemon status + daemonResult <- checkDaemon socketPath + printDaemonResult daemonResult + + -- Summary + let allPassed = case daemonResult of + DaemonRunning _ (Just diag) -> Protocol.diagAuthOk diag + DaemonRunning _ Nothing -> True + DaemonNotRunning -> False + DaemonConnectionFailed _ -> False + putStrLn ("" :: Text) + if allPassed + then putStrLn ("All checks passed." :: Text) + else do + putStrLn ("Some checks failed." :: Text) + exitFailure + +-- Configuration checks +data ConfigCheckResult = ConfigCheckResult + { configFileResult :: CheckResult, + authTokenResult :: CheckResult, + authTokenSource :: Maybe Text + } + +configPassed :: ConfigCheckResult -> Bool +configPassed ConfigCheckResult {..} = + case (configFileResult, authTokenResult) of + (CheckFailed _, _) -> False + (_, CheckFailed _) -> False + _ -> True -- Warnings are OK for both config file and auth token + +checkConfiguration :: Env -> IO ConfigCheckResult +checkConfiguration env = do + let configPath = Config.configPath (cachixoptions env) + + -- Check config file + configExists <- doesFileExist configPath + let configFileRes = + if configExists + then CheckOK + else CheckWarning "Config file not found (using defaults)" + + -- Check auth token + maybeToken <- Config.getAuthTokenMaybe (config env) + let (authRes, authSource) = case maybeToken of + Just (Token t) | not (T.null (toS t)) -> (CheckOK, Just "from config") + _ -> (CheckWarning "No auth token configured", Nothing) + + return + ConfigCheckResult + { configFileResult = configFileRes, + authTokenResult = authRes, + authTokenSource = authSource + } + +printConfigResult :: ConfigCheckResult -> IO () +printConfigResult ConfigCheckResult {..} = do + putStrLn ("Configuration" :: Text) + printCheck "Config file" configFileResult Nothing + printCheck "Auth token" authTokenResult authTokenSource + +-- Auth validation +authPassed :: CheckResult -> Bool +authPassed CheckOK = True +authPassed (CheckWarning _) = True +authPassed (CheckFailed _) = False + +checkAuth :: Env -> IO CheckResult +checkAuth _env = do + -- Auth is validated per-cache, so just return OK here + -- The actual auth validation happens in checkCaches + return CheckOK + +printAuthResult :: CheckResult -> IO () +printAuthResult _ = return () -- Auth is shown per-cache + +-- Cache checks +cachesPassed :: [CacheCheckResult] -> Bool +cachesPassed = all cacheCheckPassed + where + cacheCheckPassed CacheCheckResult {..} = + case (cacheResultConnectivity, cacheResultAuth) of + (CheckOK, CheckOK) -> True + (CheckOK, CheckWarning _) -> True + _ -> False + +checkCaches :: Env -> DoctorOptions -> IO [CacheCheckResult] +checkCaches env opts = do + let configuredCaches = Config.binaryCaches (config env) + + case doctorCacheName opts of + Just specificCache -> do + -- Check specific cache + result <- checkCache env specificCache configuredCaches + return [result] + Nothing -> + if null configuredCaches + then do + putStrLn ("" :: Text) + putStrLn ("No caches configured." :: Text) + return [] + else do + -- Check all configured caches + forM configuredCaches $ \cacheConfig -> + checkCache env (Config.name cacheConfig) configuredCaches + +checkCache :: Env -> Text -> [Config.BinaryCacheConfig] -> IO CacheCheckResult +checkCache env cacheName configuredCaches = do + maybeToken <- Config.getAuthTokenMaybe (config env) + let token = fromMaybe (Token "") maybeToken + + -- Check if we have a signing key for this cache + let hasSigningKey = any (\c -> Config.name c == cacheName && not (T.null (Config.secretKey c))) configuredCaches + + -- Try to get cache info (validates auth and connectivity) + cacheRes <- retryHttp $ (`runClientM` clientenv env) $ API.getCache cachixClient token cacheName + + case cacheRes of + Right bc -> + return + CacheCheckResult + { cacheResultName = cacheName, + cacheResultUri = Just (uri bc), + cacheResultPublic = Just (isPublic bc), + cacheResultPermission = Just (permission bc), + cacheResultHasSigningKey = hasSigningKey, + cacheResultConnectivity = CheckOK, + cacheResultAuth = CheckOK + } + Left err -> + return + CacheCheckResult + { cacheResultName = cacheName, + cacheResultUri = Nothing, + cacheResultPublic = Nothing, + cacheResultPermission = Nothing, + cacheResultHasSigningKey = hasSigningKey, + cacheResultConnectivity = checkConnectivityError err maybeToken, + cacheResultAuth = checkAuthError err maybeToken + } + +checkConnectivityError :: ClientError -> Maybe Token -> CheckResult +checkConnectivityError err maybeToken + | isErr err status404 = CheckFailed "Cache not found" + | isErr err status401 = case maybeToken of + Just _ -> CheckOK -- Auth error, not connectivity + Nothing -> CheckFailed "Authentication required" + | otherwise = CheckFailed (toS (show err :: [Char])) + +checkAuthError :: ClientError -> Maybe Token -> CheckResult +checkAuthError err maybeToken + | isErr err status401 = case maybeToken of + Just _ -> CheckFailed "Invalid or expired auth token" + Nothing -> CheckWarning "Not authenticated (cache may be private)" + | isErr err status404 = CheckOK -- Not an auth error + | otherwise = CheckOK + +printCacheResults :: [CacheCheckResult] -> IO () +printCacheResults results = do + forM_ results $ \result -> do + putStrLn ("" :: Text) + putStrLn ("Cache: " <> cacheResultName result) + case cacheResultUri result of + Just u -> putStrLn (" URI: " <> u) + Nothing -> return () + case cacheResultPublic result of + Just True -> putStrLn (" Public: yes" :: Text) + Just False -> putStrLn (" Public: no" :: Text) + Nothing -> return () + case cacheResultPermission result of + Just p -> putStrLn (" Permission: " <> T.toLower (show p)) + Nothing -> return () + let signingKeyResult = if cacheResultHasSigningKey result then CheckOK else CheckWarning "not configured" + printCheck "Signing key" signingKeyResult Nothing + printCheck "Connectivity" (cacheResultConnectivity result) Nothing + printCheck "Authentication" (cacheResultAuth result) Nothing + +-- Store path checks +data StorePathCheckResult = StorePathCheckResult + { storePathQuery :: Text, + storePathHash :: Text, + storePathCacheName :: Text, + storePathStatus :: StorePathStatus + } + deriving (Show) + +data StorePathStatus + = InCache + | NotInCache + | StorePathCheckError Text + deriving (Show) + +storePathOk :: Maybe StorePathCheckResult -> Bool +storePathOk Nothing = True +storePathOk (Just StorePathCheckResult {..}) = + case storePathStatus of + InCache -> True + NotInCache -> True -- Not an error, just informational + StorePathCheckError _ -> False + +-- | Extract the hash from a store path +-- Store paths look like: /nix/store/abc123...-name +-- The hash is the 32-character string after /nix/store/ +extractStoreHash :: Text -> Maybe Text +extractStoreHash storePath = + let path = T.strip storePath + -- Handle both full paths and just hashes + normalized = + if "/nix/store/" `T.isPrefixOf` path + then T.drop 11 path -- Drop "/nix/store/" + else path + in if T.length normalized >= 32 + then Just $ T.take 32 normalized + else Nothing + +checkStorePath :: Env -> DoctorOptions -> Text -> IO StorePathCheckResult +checkStorePath env opts storePath = do + maybeToken <- Config.getAuthTokenMaybe (config env) + let token = fromMaybe (Token "") maybeToken + let configuredCaches = Config.binaryCaches (config env) + + -- Determine which cache to check + let cacheName = case doctorCacheName opts of + Just name -> name + Nothing -> case configuredCaches of + (first' : _) -> Config.name first' + [] -> "cachix" -- Default fallback + case extractStoreHash storePath of + Nothing -> + return + StorePathCheckResult + { storePathQuery = storePath, + storePathHash = "", + storePathCacheName = cacheName, + storePathStatus = StorePathCheckError "Invalid store path format" + } + Just storeHash -> do + -- Use narinfoBulk to check if the path exists + result <- retryHttp $ (`runClientM` clientenv env) $ API.narinfoBulk cachixClient token cacheName [storeHash] + case result of + Right missingHashes -> + let status = if storeHash `elem` missingHashes then NotInCache else InCache + in return + StorePathCheckResult + { storePathQuery = storePath, + storePathHash = storeHash, + storePathCacheName = cacheName, + storePathStatus = status + } + Left err -> + return + StorePathCheckResult + { storePathQuery = storePath, + storePathHash = storeHash, + storePathCacheName = cacheName, + storePathStatus = StorePathCheckError (toS (show err :: [Char])) + } + +printStorePathResult :: StorePathCheckResult -> IO () +printStorePathResult StorePathCheckResult {..} = do + putStrLn ("" :: Text) + putStrLn ("Store Path" :: Text) + putStrLn (" Query: " <> storePathQuery) + putStrLn (" Hash: " <> storePathHash) + putStrLn (" Cache: " <> storePathCacheName) + case storePathStatus of + InCache -> + printCheck "Status" CheckOK (Just "found in cache") + NotInCache -> + printCheck "Status" (CheckWarning "not in cache") Nothing + StorePathCheckError err -> + printCheck "Status" (CheckFailed err) Nothing + +-- Daemon checks + +checkDaemon :: Maybe FilePath -> IO DaemonCheckResult +checkDaemon optionalSocketPath = do + socketPath <- maybe getSocketPath pure optionalSocketPath + exists <- doesFileExist socketPath + + if not exists + then return DaemonNotRunning + else do + -- Try to connect and get diagnostics + result <- Exception.try $ queryDaemonDiagnostics socketPath + case result of + Right (Just diag) -> return $ DaemonRunning socketPath (Just diag) + Right Nothing -> return $ DaemonConnectionFailed "No response from daemon" + Left (e :: SomeException) -> return $ DaemonConnectionFailed (toS $ displayException e) + +queryDaemonDiagnostics :: FilePath -> IO (Maybe Protocol.DaemonDiagnostics) +queryDaemonDiagnostics socketPath = + Exception.bracket + (Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol) + Socket.close + ( \sock -> do + Socket.connect sock (Socket.SockAddrUnix socketPath) + -- Send diagnostics request + Socket.LBS.sendAll sock $ Protocol.newMessage Protocol.ClientDiagnosticsRequest + -- Wait for response with timeout (10 seconds - auth check may take time) + result <- timeout 10000000 $ receiveResponse sock + case result of + Just (Just (Protocol.DaemonDiagnosticsResult diag)) -> return (Just diag) + _ -> return Nothing + ) + +receiveResponse :: Socket.Socket -> IO (Maybe Protocol.DaemonMessage) +receiveResponse sock = do + bs <- Socket.BS.recv sock 4096 + if BS.null bs + then return Nothing + else do + let (msgs, _) = Protocol.splitMessages bs + case msgs of + (msg : _) -> return $ decodeMsg msg + [] -> return Nothing + where + decodeMsg msg = case Aeson.eitherDecodeStrict msg of + Right m -> Just m + Left _ -> Nothing + +printDaemonResult :: DaemonCheckResult -> IO () +printDaemonResult result = do + putStrLn ("" :: Text) + putStrLn ("Daemon" :: Text) + case result of + DaemonNotRunning -> + printCheck "Status" (CheckWarning "not running") Nothing + DaemonRunning socketPath _ -> do + printCheck "Status" CheckOK (Just "running") + putStrLn (" Socket: " <> (toS socketPath :: Text)) + DaemonConnectionFailed reason -> + printCheck "Status" (CheckFailed reason) Nothing + +-- Helper to print a check result +printCheck :: Text -> CheckResult -> Maybe Text -> IO () +printCheck name result extra = do + let (symbol, status) = case result of + CheckOK -> ("✓", "") + CheckWarning msg -> ("!", msg) + CheckFailed msg -> ("✗", msg) + extraText = case (extra, status) of + (Just e, "") -> e + (Just e, s) -> s <> " (" <> e <> ")" + (Nothing, s) -> s + statusText = if T.null extraText then "" else " " <> extraText + putStrLn $ " " <> symbol <> " " <> name <> statusText 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 @@ -21,6 +21,9 @@ -- * Pin options PinOptions (..), + -- * Doctor options + DoctorOptions (..), + -- * Global options Flags (..), @@ -79,6 +82,7 @@ = AuthToken (Maybe Text) | Config Config.Command | Daemon DaemonCommand + | Doctor DoctorOptions | GenerateKeypair BinaryCacheName | Push PushArguments | Import PushOptions Text URI @@ -168,6 +172,7 @@ | DaemonRun DaemonOptions PushOptions BinaryCacheName | DaemonStop DaemonOptions | DaemonWatchExec DaemonOptions PushOptions BinaryCacheName Text [Text] + | DaemonDoctor DaemonOptions deriving (Show) data DaemonOptions = DaemonOptions @@ -182,6 +187,12 @@ } deriving (Show) +data DoctorOptions = DoctorOptions + { doctorCacheName :: Maybe BinaryCacheName, + doctorStorePath :: Maybe Text + } + deriving (Show) + -- | CLI parser entry point getOpts :: IO (Flags, CachixCommand) getOpts = do @@ -206,6 +217,7 @@ <|> storePathCommands <|> daemonCommands <|> deployCommands + <|> diagnosticCommands where configCommands = subparser $ @@ -260,6 +272,14 @@ command "deploy" $ infoH deployCommand $ progDesc "Manage remote Nix-based systems with Cachix Deploy" ] + diagnosticCommands = + subparser $ + fold + [ commandGroup "Diagnostic commands:", + hidden, + command "doctor" $ infoH doctorCommand $ progDesc "Check Cachix configuration and connectivity" + ] + flagParser :: Config.ConfigPath -> Parser Flags flagParser defaultConfigPath = Flags <$> configPath <*> (host <|> hostname) <*> verbose @@ -496,12 +516,16 @@ daemonSubCommand = subparser $ fold - [ command "push" $ infoH daemonPush $ progDesc "Push store paths to the daemon", + [ command "doctor" $ infoH daemonDoctorParser $ progDesc "Check daemon health and connectivity", + command "push" $ infoH daemonPush $ progDesc "Push store paths to the daemon", command "run" $ infoH daemonRun $ progDesc "Launch the daemon", command "stop" $ infoH daemonStop $ progDesc "Stop the daemon and wait for any queued paths to be pushed", command "watch-exec" $ infoH daemonWatchExec $ progDesc "Run a command and upload any store paths built during its execution" ] +daemonDoctorParser :: Parser DaemonCommand +daemonDoctorParser = DaemonDoctor <$> daemonOptionsParser + daemonPush :: Parser DaemonCommand daemonPush = DaemonPushPaths @@ -594,6 +618,25 @@ deployCommand :: Parser CachixCommand deployCommand = DeployCommand <$> DeployOptions.parser + +doctorCommand :: Parser CachixCommand +doctorCommand = + Doctor + <$> ( DoctorOptions + <$> cacheOption + <*> storePathArg + ) + where + cacheOption = + optional . strOption $ + long "cache" + <> metavar "CACHE-NAME" + <> help "Binary cache to check" + + storePathArg = + optional . strArgument $ + metavar "STORE-PATH" + <> help "Check if a specific store path or hash exists in the cache" watchExecCommand :: Parser CachixCommand watchExecCommand = diff --git a/src/Cachix/Daemon.hs b/src/Cachix/Daemon.hs --- a/src/Cachix/Daemon.hs +++ b/src/Cachix/Daemon.hs @@ -11,6 +11,7 @@ ) where +import Cachix.API qualified as API import Cachix.Client.Command.Push qualified as Command.Push import Cachix.Client.Config qualified as Config import Cachix.Client.Config.Orphans () @@ -18,6 +19,8 @@ import Cachix.Client.OptionsParser (DaemonOptions, PushOptions, daemonNarinfoQueryOptions) import Cachix.Client.OptionsParser qualified as Options import Cachix.Client.Push +import Cachix.Client.Retry (retryHttp) +import Cachix.Client.Servant (cachixClient) import Cachix.Daemon.EventLoop qualified as EventLoop import Cachix.Daemon.Listen as Listen import Cachix.Daemon.Log qualified as Log @@ -42,6 +45,7 @@ import Network.Socket qualified as Socket import Network.Socket.ByteString qualified as Socket.BS import Protolude hiding (bracket) +import Servant.Client.Streaming (runClientM) import System.Environment (lookupEnv) import System.IO.Error (isResourceVanishedError) import System.Posix.Process (getProcessID) @@ -169,6 +173,32 @@ else do let errorMsg = "Remote stop is disabled on this daemon" SocketStore.sendAll socketId (Protocol.newMessage (Protocol.DaemonError (Protocol.UnsupportedCommand errorMsg))) clients + ClientDiagnosticsRequest -> do + -- Get push secret to check for signing key and auth token + let pushParams = PushManager.pmPushParams daemonPushManager + pushSecret = pushParamsSecret pushParams + hasSigningKey = case pushSecret of + PushSigningKey {} -> True + PushToken {} -> False + maybeToken = getAuthTokenFromPushSecret pushSecret + -- Verify auth by making an API call + authResult <- case maybeToken of + Nothing -> pure $ Left "No auth token configured" + Just token -> do + res <- liftIO $ retryHttp $ (`runClientM` clientenv daemonEnv) $ API.getCache cachixClient token daemonCacheName + pure $ case res of + Right _ -> Right () + Left err -> Left (show err) + let diagnostics = + Protocol.DaemonDiagnostics + { Protocol.diagCacheName = daemonCacheName, + Protocol.diagCacheUri = BinaryCache.uri daemonBinaryCache, + Protocol.diagCachePublic = BinaryCache.isPublic daemonBinaryCache, + Protocol.diagHasSigningKey = hasSigningKey, + Protocol.diagAuthOk = isRight authResult, + Protocol.diagError = either Just (const Nothing) authResult + } + SocketStore.sendAll socketId (Protocol.newMessage (Protocol.DaemonDiagnosticsResult diagnostics)) daemonClients _ -> return () ShutdownGracefully -> do Katip.logFM Katip.InfoS "Shutting down daemon..." diff --git a/src/Cachix/Daemon/Client.hs b/src/Cachix/Daemon/Client.hs --- a/src/Cachix/Daemon/Client.hs +++ b/src/Cachix/Daemon/Client.hs @@ -161,6 +161,7 @@ _ -> loop Protocol.DaemonError err -> handleDaemonError err Protocol.DaemonExit exitStatus -> handleDaemonExit exitStatus + Protocol.DaemonDiagnosticsResult _ -> loop -- | Tell the daemon to stop and wait for it to gracefully exit stop :: Env -> DaemonOptions -> IO () @@ -182,6 +183,7 @@ Protocol.DaemonError err -> handleDaemonError err Protocol.DaemonExit exitStatus -> handleDaemonExit exitStatus Protocol.DaemonPushEvent _ -> loop + Protocol.DaemonDiagnosticsResult _ -> loop withDaemonConn :: Maybe FilePath -> (Socket.Socket -> IO a) -> IO a withDaemonConn optionalSocketPath f = do diff --git a/src/Cachix/Daemon/Protocol.hs b/src/Cachix/Daemon/Protocol.hs --- a/src/Cachix/Daemon/Protocol.hs +++ b/src/Cachix/Daemon/Protocol.hs @@ -3,6 +3,7 @@ DaemonMessage (..), DaemonErrorMessage (..), DaemonExitStatus (..), + DaemonDiagnostics (..), PushRequestId, newPushRequestId, PushRequest (..), @@ -22,6 +23,7 @@ = ClientPushRequest !PushRequest | ClientStop | ClientPing + | ClientDiagnosticsRequest deriving stock (Eq, Generic, Show) deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) @@ -31,6 +33,7 @@ | DaemonExit !DaemonExitStatus | DaemonPushEvent PushEvent | DaemonError !DaemonErrorMessage + | DaemonDiagnosticsResult !DaemonDiagnostics deriving stock (Eq, Generic, Show) deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) @@ -43,6 +46,18 @@ data DaemonExitStatus = DaemonExitStatus { exitCode :: !Int, exitMessage :: !(Maybe Text) + } + deriving stock (Eq, Generic, Show) + deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) + +-- | Diagnostics information about the daemon's cache configuration +data DaemonDiagnostics = DaemonDiagnostics + { diagCacheName :: !Text, + diagCacheUri :: !Text, + diagCachePublic :: !Bool, + diagHasSigningKey :: !Bool, + diagAuthOk :: !Bool, + diagError :: !(Maybe Text) } deriving stock (Eq, Generic, Show) deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) diff --git a/src/Cachix/Daemon/Types/TaskQueue.hs b/src/Cachix/Daemon/Types/TaskQueue.hs --- a/src/Cachix/Daemon/Types/TaskQueue.hs +++ b/src/Cachix/Daemon/Types/TaskQueue.hs @@ -5,7 +5,6 @@ where import Control.Concurrent.STM.TVar -import Data.Int (Int32) import Data.PQueue.Max (MaxQueue) import Protolude @@ -26,9 +25,7 @@ where -- Circular sequence comparison: older (smaller) sequences come first -- Uses signed arithmetic to handle wraparound (works for sequences up to 2^31 apart) - compareSeq s1 s2 = - let diff = s2 - s1 - in compare diff 0 + compareSeq s1 s2 = compare (s2 - s1) 0 -- | A priority queue that maintains TBMQueue-compatible API -- The queue is unbounded and prioritizes items by their Ord instance diff --git a/test/Daemon/NarinfoQuerySpec.hs b/test/Daemon/NarinfoQuerySpec.hs --- a/test/Daemon/NarinfoQuerySpec.hs +++ b/test/Daemon/NarinfoQuerySpec.hs @@ -14,6 +14,7 @@ import Protolude import Test.Hspec import UnliftIO.Async qualified as Async +import UnliftIO.Timeout (timeout) -- Create a mock StorePath for testing mockStorePath :: Store -> Int -> IO StorePath @@ -80,11 +81,16 @@ -- Helper to start batch processor asynchronously with its own Katip context startQueryProcessorAsync :: NarinfoQueryManager requestId -> ([StorePath] -> IO ([StorePath], [StorePath])) -> IO () startQueryProcessorAsync manager batchProcessor = do + started <- newEmptyMVar void $ Async.async $ do handleScribe <- Katip.mkHandleScribe Katip.ColorIfTerminal stderr (Katip.permitItem Katip.InfoS) Katip.V0 let makeLogEnv = Katip.registerScribe "stderr" handleScribe Katip.defaultScribeSettings =<< Katip.initLogEnv "test" "test" bracket makeLogEnv Katip.closeScribes $ \le -> - Katip.runKatipContextT le () mempty $ NarinfoQuery.start manager (liftIO . batchProcessor) + Katip.runKatipContextT le () mempty $ do + liftIO $ putMVar started () + NarinfoQuery.start manager (liftIO . batchProcessor) + -- Wait for the processor to start before returning + takeMVar started -- Test setup helper that encapsulates common initialization withTestManager :: @@ -112,6 +118,16 @@ finally (action testContext) (NarinfoQuery.stop manager) +-- | Wait for an STM condition to be satisfied, with a timeout. +-- Fails with an error if the timeout expires before the condition is met. +waitForSTM :: Int -> STM Bool -> IO () +waitForSTM timeoutMicros condition = do + result <- timeout timeoutMicros $ atomically $ do + satisfied <- condition + unless satisfied retry + when (isNothing result) $ + expectationFailure "Timeout waiting for STM condition" + spec :: Spec spec = do -- Initialize the CNix library @@ -239,19 +255,24 @@ path4 <- mockStorePath store 4 path5 <- mockStorePath store 5 path6 <- mockStorePath store 6 - let config = defaultNarinfoQueryOptions {nqoMaxWaitTime = 0} + -- Use batch size = 5 (exact unique paths count) so batch triggers on request 2 + -- Request 1 adds 3 paths, request 2 adds 2 more unique (5 total), triggering batch + let config = defaultNarinfoQueryOptions {nqoMaxBatchSize = 5, nqoMaxWaitTime = 10} withTestManager config $ \TestContext {..} -> do -- Setup: path1,3,5 exist; path2,4,6 missing let existingPaths = Set.fromList [path1, path3, path5] missingPaths = Set.fromList [path2, path4, path6] atomically $ writeTVar tcResponsesQueue [(existingPaths, missingPaths)] - -- Request 1: paths 1,2,3 + -- Request 1: paths 1,2,3 (3 unique paths, below threshold) NarinfoQuery.submitRequest tcManager (1 :: Int) [path1, path2, path3] - -- Request 2: paths 3,4,5 (path 3 overlaps) + -- Request 2: paths 3,4,5 (path 3 overlaps, adds 2 new → 5 total, triggers batch) NarinfoQuery.submitRequest tcManager (2 :: Int) [path3, path4, path5] - threadDelay 20_000 + -- Wait until both callbacks are received (deterministic, no timing dependency) + waitForSTM 5_000_000 $ do + cbs <- readTVar tcCallbackCalls + return $ length cbs >= 2 callbacks <- readTVarIO tcCallbackCalls length callbacks `shouldBe` 2