diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,26 @@ ## Unreleased +## [0.2.1] - 2019-07-05 + +### Added + +- #180 support servant 0.16 @domenkozar +- #200 add `cachix push --compression-level` and default to 2 @roberth + This should cut pushing time by a significant factor. + +### Changed + +- #194 remove shadowed -h option @roberth +- #180 reduce retries limit to 3 @domenkozar +- #192 extract `cachix push` into a proper library module @roberth + +### Fixed + +- #187 create possibly missing directories for netrc @domenkozar +- #185 fix command line completions @roberth +- #196 improve build time by working around a GHC bug @roberth + ## [0.2.0] - 2019-03-04 ### Added @@ -16,6 +36,7 @@ - #24 #168 Private binary cache support @domenkozar @roberth ### Changed + - #158 #160 #166 #91 Improve NixOS experience by writing out nixos modules @domenkozar - #170 Get rid of amazonka dependency @domenkozar 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: 0.2.0 +version: 0.2.1 synopsis: Command line client for Nix binary cache hosting https://cachix.org homepage: https://github.com/cachix/cachix#readme bug-reports: https://github.com/cachix/cachix/issues @@ -38,6 +38,8 @@ Cachix.Client.NixConf Cachix.Client.NixVersion Cachix.Client.OptionsParser + Cachix.Client.Push + Cachix.Client.Secrets Cachix.Client.Servant Cachix.Client.URI other-modules: @@ -57,7 +59,6 @@ , conduit-extra , cookie , cryptonite - , data-default , dhall , directory , ed25519 @@ -76,6 +77,7 @@ , optparse-applicative , process , protolude + , resourcet , retry , safe-exceptions , servant >=0.15 diff --git a/cachix/Main.hs b/cachix/Main.hs --- a/cachix/Main.hs +++ b/cachix/Main.hs @@ -1,8 +1,9 @@ module Main (main) where -import Control.Exception (handle, SomeException) +import Prelude +import Control.Exception (handle, SomeException, fromException) import System.IO -import System.Exit (exitFailure) +import System.Exit (exitFailure, exitWith) import GHC.IO.Encoding import qualified Cachix.Client as CC @@ -19,6 +20,7 @@ handleExceptions = handle handler where handler :: SomeException -> IO a + handler e | (Just ee) <- fromException e = exitWith ee handler e = do hPutStrLn stderr "" -- TODO: pretty print the record once fixed https://github.com/haskell-servant/servant/issues/807 diff --git a/src/Cachix/Client.hs b/src/Cachix/Client.hs --- a/src/Cachix/Client.hs +++ b/src/Cachix/Client.hs @@ -17,6 +17,6 @@ AuthToken token -> Commands.authtoken env token Create name -> Commands.create env name GenerateKeypair name -> Commands.generateKeypair env name - Push name paths watchStore -> Commands.push env name paths watchStore + Push pushArgs -> Commands.push env pushArgs Use name useOptions -> Commands.use env name useOptions Version -> putText cachixVersion 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 @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} module Cachix.Client.Commands ( authtoken , create @@ -12,41 +13,26 @@ import Crypto.Sign.Ed25519 import Control.Concurrent (threadDelay) -import qualified Control.Concurrent.QSem as QSem -import Control.Concurrent.Async (mapConcurrently) -import Control.Monad (forever, (>=>)) -import Control.Exception.Safe (MonadThrow, throwM) -import Control.Retry (recoverAll, RetryStatus(rsIterNumber)) +import Control.Exception.Safe (throwM) +import Control.Retry (RetryStatus(rsIterNumber)) import qualified Data.ByteString.Base64 as B64 -import Data.Conduit -import Data.Default (def) -import Data.Conduit.Process -import Data.Conduit.Lzma ( compress ) -import Data.IORef import Data.List ( isSuffixOf ) import Data.Maybe ( fromJust ) import Data.String.Here import qualified Data.Text as T import Network.HTTP.Types (status404, status401) import Protolude -import Servant.API -import Servant.Auth () import Servant.Auth.Client -import Servant.API.Generic -import Servant.Client.Generic +import Servant.API ( NoContent ) import Servant.Client.Streaming import Servant.Conduit () import System.Directory ( doesFileExist ) import System.FSNotify import System.IO ( stdin, hIsTerminalDevice ) -import System.Process ( readProcess ) import System.Environment ( lookupEnv ) import qualified Cachix.Api as Api import Cachix.Api.Error -import Cachix.Api.Signing (fingerprint, passthroughSizeSink, passthroughHashSink) -import qualified Cachix.Types.NarInfoCreate as Api -import qualified Cachix.Types.BinaryCacheCreate as Api import qualified Cachix.Types.SigningKeyCreate as SigningKeyCreate import Cachix.Client.Config ( Config(..) , BinaryCacheConfig(..) @@ -56,22 +42,20 @@ import qualified Cachix.Client.Config as Config import Cachix.Client.Env ( Env(..) ) import Cachix.Client.Exception ( CachixException(..) ) -import Cachix.Client.OptionsParser ( CachixOptions(..), UseOptions(..) ) +import Cachix.Client.OptionsParser ( CachixOptions(..), UseOptions(..) + , PushArguments(..), PushOptions(..) + ) import Cachix.Client.InstallationMode import Cachix.Client.NixVersion ( getNixVersion ) import qualified Cachix.Client.NixConf as NixConf +import Cachix.Client.Push +import Cachix.Client.Secrets ( SigningKey(SigningKey) + , parseSigningKeyLenient + , exportSigningKey + ) import Cachix.Client.Servant -cachixClient :: Api.CachixAPI (AsClientT ClientM) -cachixClient = fromServant $ client Api.servantApi - -cachixBCClient :: Text -> Api.BinaryCacheAPI (AsClientT ClientM) -cachixBCClient name = fromServant $ Api.cache cachixClient name - -cachixBCStreamingClient :: Text -> Api.BinaryCacheStreamingAPI (AsClientT ClientM) -cachixBCStreamingClient name = fromServant $ client (Proxy :: Proxy Api.BinaryCachStreamingServantAPI) name - authtoken :: Env -> Text -> IO () authtoken env token = do -- TODO: check that token actually authenticates! @@ -89,14 +73,16 @@ generateKeypair :: Env -> Text -> IO () generateKeypair Env { config = Nothing } _ = throwIO $ NoConfig "Start with visiting https://cachix.org and copying the token to $ cachix authtoken " generateKeypair env@Env { config = Just config } name = do - (PublicKey pk, SecretKey sk) <- createKeypair + (PublicKey pk, sk) <- createKeypair - let signingKey = toS $ B64.encode sk + let signingKey = exportSigningKey $ SigningKey sk signingKeyCreate = SigningKeyCreate.SigningKeyCreate (toS $ B64.encode pk) bcc = BinaryCacheConfig name signingKey -- we first validate if key can be added to the binary cache - escalate =<< ((`runClientM` clientenv env) $ Api.createKey (cachixBCClient name) (authToken config) signingKeyCreate) + (_ :: NoContent) <- escalate + =<< ((`runClientM` clientenv env) + $ Api.createKey (cachixBCClient name) (authToken config) signingKeyCreate) -- if key was successfully added, write it to the config -- TODO: this breaks if more than one key is added, see #27 @@ -161,8 +147,8 @@ -- TODO: lots of room for perfomance improvements -push :: Env -> Text -> [Text] -> Bool -> IO () -push env name rawPaths False = do +push :: Env -> PushArguments -> IO () +push env (PushPaths opts name rawPaths) = do hasNoStdin <- hIsTerminalDevice stdin when (not hasNoStdin && not (null rawPaths)) $ throwIO $ AmbiguousInput "You provided both stdin and store path arguments, pick only one to proceed." inputStorePaths <- @@ -172,15 +158,21 @@ -- TODO: if empty, take whole nix store and warn: nix store-path --all when (null inputStorePaths) $ throwIO $ NoInput "You need to specify store paths either as stdin or as a cli argument" - - -- Query list of paths - -- TODO: split args if too big - paths <- T.lines . toS <$> readProcess "nix-store" (fmap toS (["-qR"] <> inputStorePaths)) mempty + sk <- findSigningKey env name - -- TODO: make pool size configurable, on beefier machines this could be doubled - _ <- mapConcurrentlyBounded 4 (pushStorePath env name) paths + void $ pushClosure + (mapConcurrentlyBounded 4) + (clientenv env) + PushCache + { pushCacheToken = envToToken env + , pushCacheName = name + , pushCacheSigningKey = sk + } + (pushStrategy env opts name) + inputStorePaths putText "All done." -push env name _ True = withManager $ \mgr -> do + +push env (PushWatchStore opts name) = withManager $ \mgr -> do _ <- watchDir mgr "/nix/store" filterF action putText "Watching /nix/store for new builds ..." forever $ threadDelay 1000000 @@ -191,7 +183,7 @@ #else action (Removed fp _) = #endif - pushStorePath env name $ toS $ dropEnd 5 fp + pushStorePath env opts name $ toS $ dropEnd 5 fp action _ = return () filterF :: ActionPredicate @@ -206,121 +198,52 @@ dropEnd :: Int -> [a] -> [a] dropEnd index xs = take (length xs - index) xs -pushStorePath :: Env -> Text -> Text -> IO () -pushStorePath env name storePath = retryPath $ \retrystatus -> do - -- use secret key from config or env - -- TODO: this shouldn't happen for each store path +-- | Find a secret key in the 'Config' or environment variable +findSigningKey + :: Env + -> Text -- ^ Cache name + -> IO SigningKey -- ^ Secret key or exception +findSigningKey env name = do maybeEnvSK <- lookupEnv "CACHIX_SIGNING_KEY" let matches Config{..} = filter (\bc -> Config.name bc == name) binaryCaches maybeBCSK = case config env of Nothing -> Nothing Just c -> Config.secretKey <$> head (matches c) -- TODO: better error msg - sk = SecretKey $ toS $ B64.decodeLenient $ toS $ fromJust $ maybeBCSK <|> toS <$> maybeEnvSK <|> panic "You need to: export CACHIX_SIGNING_KEY=XXX" - (storeHash, _) = splitStorePath $ toS storePath - -- Check if narinfo already exists - -- TODO: query also cache.nixos.org? server-side? - res <- (`runClientM` clientenv env) $ Api.narinfoHead - (cachixBCClient name) - (envToToken env) - (Api.NarInfoC storeHash) - case res of - Right NoContent -> pass -- we're done as store path is already in the cache - Left err | isErr err status404 -> go sk retrystatus - | isErr err status401 && isJust (config env) -> throwM $ accessDeniedBinaryCache name - | isErr err status401 -> throwM notAuthenticatedBinaryCache - | otherwise -> throwM err - where - retryText :: RetryStatus -> Text - retryText retrystatus = - if rsIterNumber retrystatus == 0 - then "" - else "(retry #" <> show (rsIterNumber retrystatus) <> ") " - go sk retrystatus = do - let (storeHash, storeSuffix) = splitStorePath $ toS storePath - -- we append newline instead of putStrLn due to https://github.com/haskell/text/issues/242 - putStr $ "pushing " <> retryText retrystatus <> storePath <> "\n" - - narSizeRef <- liftIO $ newIORef 0 - fileSizeRef <- liftIO $ newIORef 0 - narHashRef <- liftIO $ newIORef ("" :: Text) - fileHashRef <- liftIO $ newIORef ("" :: Text) - - -- stream store path as xz compressed nar file - let cmd = proc "nix-store" ["--dump", toS storePath] - (ClosedStream, (stdoutStream, closeStdout), ClosedStream, cph) <- streamingProcess cmd - let stream' - = stdoutStream - .| passthroughSizeSink narSizeRef - .| passthroughHashSink narHashRef - .| compress Nothing - .| passthroughSizeSink fileSizeRef - .| passthroughHashSink fileHashRef - - -- for now we need to use letsencrypt domain instead of cloudflare due to its upload limits - let newClientEnv = (clientenv env) { - baseUrl = (baseUrl (clientenv env)) { baseUrlHost = toS name <> "." <> baseUrlHost (baseUrl (clientenv env))} - } - void $ (`withClientM` newClientEnv) - (Api.createNar (cachixBCStreamingClient name) stream') - $ escalate >=> \NoContent -> do - closeStdout - exitcode <- waitForStreamingProcess cph - -- TODO: print process stderr? - when (exitcode /= ExitSuccess) $ throwM $ NarStreamingError exitcode $ show cmd - - narSize <- readIORef narSizeRef - narHashB16 <- readIORef narHashRef - fileHash <- readIORef fileHashRef - fileSize <- readIORef fileSizeRef - - -- TODO: #3: implement using pure haskell - narHash <- ("sha256:" <>) . T.strip . toS <$> readProcess "nix-hash" ["--type", "sha256", "--to-base32", toS narHashB16] mempty - - deriverRaw <- T.strip . toS <$> readProcess "nix-store" ["-q", "--deriver", toS storePath] mempty - let deriver = if deriverRaw == "unknown-deriver" - then deriverRaw - else T.drop 11 deriverRaw - - references <- sort . T.lines . T.strip . toS <$> readProcess "nix-store" ["-q", "--references", toS storePath] mempty - - let - fp = fingerprint storePath narHash narSize references - sig = dsign sk fp - nic = Api.NarInfoCreate - { cStoreHash = storeHash - , cStoreSuffix = storeSuffix - , cNarHash = narHash - , cNarSize = narSize - , cFileSize = fileSize - , cFileHash = fileHash - , cReferences = fmap (T.drop 11) references - , cDeriver = deriver - , cSig = toS $ B64.encode $ unSignature sig - } - - escalate $ Api.isNarInfoCreateValid nic - - -- Upload narinfo with signature - escalate <=< (`runClientM` clientenv env) $ Api.createNarinfo - (cachixBCClient name) - (Api.NarInfoC storeHash) - nic - + escalateAs FatalError $ parseSigningKeyLenient $ fromJust $ maybeBCSK <|> toS <$> maybeEnvSK <|> panic "You need to: export CACHIX_SIGNING_KEY=XXX" --- Utils +retryText :: RetryStatus -> Text +retryText retrystatus = + if rsIterNumber retrystatus == 0 + then "" + else "(retry #" <> show (rsIterNumber retrystatus) <> ") " --- Retry up to 5 times for each store path. --- Catches all exceptions except skipAsyncExceptions -retryPath :: (RetryStatus -> IO a) -> IO a -retryPath = recoverAll def +pushStrategy :: Env -> PushOptions -> Text -> Text -> PushStrategy IO () +pushStrategy env opts name storePath = PushStrategy + { onAlreadyPresent = pass + , on401 = if isJust (config env) + then throwM $ accessDeniedBinaryCache name + else throwM notAuthenticatedBinaryCache + , onError = throwM + , onAttempt = \retrystatus -> + -- we append newline instead of putStrLn due to https://github.com/haskell/text/issues/242 + putStr $ "pushing " <> retryText retrystatus <> storePath <> "\n" + , onDone = pass + , withXzipCompressor = defaultWithXzipCompressorWithLevel (compressionLevel opts) + } -mapConcurrentlyBounded :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) -mapConcurrentlyBounded bound action items = do - qs <- QSem.newQSem bound - let wrapped x = bracket_ (QSem.waitQSem qs) (QSem.signalQSem qs) (action x) - mapConcurrently wrapped items +pushStorePath :: Env -> PushOptions -> Text -> Text -> IO () +pushStorePath env opts name storePath = do + sk <- findSigningKey env name + -- use secret key from config or env + -- TODO: this shouldn't happen for each store path -splitStorePath :: Text -> (Text, Text) -splitStorePath storePath = - (T.take 32 (T.drop 11 storePath), T.drop 44 storePath) + pushSingleStorePath + (clientenv env) + PushCache + { pushCacheToken = envToToken env + , pushCacheName = name + , pushCacheSigningKey = sk + } + (pushStrategy env opts name storePath) + storePath diff --git a/src/Cachix/Client/NetRc.hs b/src/Cachix/Client/NetRc.hs --- a/src/Cachix/Client/NetRc.hs +++ b/src/Cachix/Client/NetRc.hs @@ -8,7 +8,8 @@ import qualified Data.Text as T import Network.NetRc import Protolude -import System.Directory ( doesFileExist ) +import System.FilePath ( takeDirectory ) +import System.Directory ( doesFileExist, createDirectoryIfMissing ) import Servant.Auth.Client (getToken) import qualified Cachix.Api as Api @@ -29,6 +30,7 @@ netrc <- if doesExist then BS.readFile filename >>= parse else return $ NetRc [] [] + createDirectoryIfMissing True (takeDirectory filename) BS.writeFile filename $ netRcToByteString $ uniqueAppend netrc where parse :: ByteString -> IO NetRc 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 @@ -1,8 +1,9 @@ -{-# LANGUAGE QuasiQuotes #-} module Cachix.Client.OptionsParser ( CachixCommand(..) , CachixOptions(..) , UseOptions(..) + , PushArguments(..) + , PushOptions(..) , BinaryCacheName , getOpts ) where @@ -11,10 +12,10 @@ import Protolude hiding (option) import URI.ByteString (URIRef, Absolute, parseURI, strictURIParserOptions , serializeURIRef') -import URI.ByteString.QQ import Options.Applicative import qualified Cachix.Client.Config as Config +import Cachix.Client.URI (defaultCachixURI) data CachixOptions = CachixOptions { host :: URIRef Absolute @@ -25,8 +26,7 @@ parserCachixOptions :: Config.ConfigPath -> Parser CachixOptions parserCachixOptions defaultConfigPath = CachixOptions <$> option uriOption ( long "host" - <> short 'h' - <> value [uri|https://cachix.org|] + <> value defaultCachixURI <> metavar "URI" <> showDefaultWith (toS . serializeURIRef') <> help "Host to connect to" @@ -53,7 +53,7 @@ = AuthToken Text | Create BinaryCacheName | GenerateKeypair BinaryCacheName - | Push BinaryCacheName [Text] Bool -- TODO: refactor to a record + | Push PushArguments | Use BinaryCacheName UseOptions | Version deriving Show @@ -63,11 +63,20 @@ , useNixOSFolder :: FilePath } deriving Show +data PushArguments + = PushPaths PushOptions Text [Text] + | PushWatchStore PushOptions Text + deriving Show + +data PushOptions = PushOptions + { compressionLevel :: Int + } deriving Show + parserCachixCommand :: Parser CachixCommand parserCachixCommand = subparser $ command "authtoken" (infoH authtoken (progDesc "Configure token for authentication to cachix.org")) <> command "create" (infoH create (progDesc "DEPRECATED: Go to https://cachix.org instead")) <> - command "generate-keypair" (infoH generateKeypair (progDesc "Generate keypair for an binary cache")) <> + command "generate-keypair" (infoH generateKeypair (progDesc "Generate keypair for a binary cache")) <> command "push" (infoH push (progDesc "Upload Nix store paths to the binary cache")) <> command "use" (infoH use (progDesc "Configure nix.conf to enable binary cache during builds")) where @@ -75,12 +84,30 @@ authtoken = AuthToken <$> strArgument (metavar "TOKEN") create = Create <$> nameArg generateKeypair = GenerateKeypair <$> nameArg - push = Push <$> nameArg - <*> many (strArgument (metavar "PATHS...")) - <*> switch ( long "watch-store" + + validatedLevel l = + l <$ unless (l `elem` [0 .. 9]) (readerError $ "value " <> show l <> " not in expected range: [0..9]") + + pushOptions :: Parser PushOptions + pushOptions = PushOptions + <$> option (auto >>= validatedLevel) + ( long "compression-level" + <> metavar "[0..9]" + <> help "The compression level for XZ compression.\ + \ Take compressor *and* decompressor memory usage into account before using [7..9]!" + <> showDefault + <> value 2 + ) + + push = (\opts cache f -> Push $ f opts cache) <$> pushOptions <*> nameArg <*> (pushPaths <|> pushWatchStore) + pushPaths = (\paths opts cache -> PushPaths opts cache paths) <$> + many (strArgument (metavar "PATHS...")) + pushWatchStore = (\() opts cache -> PushWatchStore opts cache) <$> + flag' () ( long "watch-store" <> short 'w' <> help "Run in daemon mode and push store paths as they are added to /nix/store" ) + use = Use <$> nameArg <*> (UseOptions <$> switch ( long "nixos" <> short 'n' diff --git a/src/Cachix/Client/Push.hs b/src/Cachix/Client/Push.hs new file mode 100644 --- /dev/null +++ b/src/Cachix/Client/Push.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Cachix.Client.Push + ( -- * Pushing a single path + pushSingleStorePath + , PushCache(..) + , PushStrategy(..) + , defaultWithXzipCompressor + , defaultWithXzipCompressorWithLevel + + -- * Pushing a closure of store paths + , pushClosure + , mapConcurrentlyBounded + ) where + +import Crypto.Sign.Ed25519 +import qualified Control.Concurrent.QSem as QSem +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad ((>=>)) +import Control.Monad.Trans.Resource (ResourceT) +import Control.Exception.Safe (MonadMask, throwM) +import Control.Retry (recoverAll, RetryStatus, RetryPolicy, constantDelay, limitRetries) +import qualified Data.ByteString.Base64 as B64 +import Data.Conduit +import Data.Conduit.Process +import Data.Conduit.Lzma ( compress ) +import Data.IORef +import qualified Data.Text as T +import Network.HTTP.Types (status404, status401) +import Protolude +import Servant.API +import Servant.Auth () +import Servant.Auth.Client +import Servant.Client.Streaming hiding (ClientError) +import Servant.Conduit () +import System.Process ( readProcess ) + +import qualified Cachix.Api as Api +import Cachix.Api.Error +import Cachix.Api.Signing (fingerprint, passthroughSizeSink, passthroughHashSink) +import qualified Cachix.Types.NarInfoCreate as Api +import Cachix.Client.Exception ( CachixException(..) ) +import Cachix.Client.Servant +import Cachix.Client.Secrets + + +data PushCache = PushCache + { pushCacheName :: Text + , pushCacheSigningKey :: SigningKey + , pushCacheToken :: Token + } +data PushStrategy m r = PushStrategy + { onAlreadyPresent :: m r -- ^ Called when a path is already in the cache. + , onAttempt :: RetryStatus -> m () + , on401 :: m r + , onError :: ClientError -> m r + , onDone :: m r + , withXzipCompressor :: forall a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a + } + +defaultWithXzipCompressor :: forall m a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a +defaultWithXzipCompressor = ($ compress (Just 2)) + +defaultWithXzipCompressorWithLevel :: Int -> forall m a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a +defaultWithXzipCompressorWithLevel l = ($ compress (Just l)) + +pushSingleStorePath + :: (MonadMask m, MonadIO m) + => ClientEnv -- ^ cachix base url, connection manager, see 'Cachix.Client.URI.defaultCachixBaseUrl', 'Servant.Client.mkClientEnv' + -> PushCache -- ^ details for pushing to cache + -> PushStrategy m r -- ^ how to report results, (some) errors, and do some things + -> Text -- ^ store path + -> m r -- ^ r is determined by the 'PushStrategy' +pushSingleStorePath ce cache cb storePath = retryPath $ \retrystatus -> do + + let (storeHash, storeSuffix) = splitStorePath $ toS storePath + name = pushCacheName cache + + -- Check if narinfo already exists + -- TODO: query also cache.nixos.org? server-side? + res <- liftIO $ (`runClientM` ce) $ Api.narinfoHead + (cachixBCClient name) + (pushCacheToken cache) + (Api.NarInfoC storeHash) + case res of + Right NoContent -> onAlreadyPresent cb -- we're done as store path is already in the cache + Left err | isErr err status404 -> doUpload + | isErr err status401 -> on401 cb + | otherwise -> onError cb err + where + doUpload = do + onAttempt cb retrystatus + + narSizeRef <- liftIO $ newIORef 0 + fileSizeRef <- liftIO $ newIORef 0 + narHashRef <- liftIO $ newIORef ("" :: Text) + fileHashRef <- liftIO $ newIORef ("" :: Text) + + -- stream store path as xz compressed nar file + let cmd = proc "nix-store" ["--dump", toS storePath] + -- TODO: print process stderr? + (ClosedStream, (stdoutStream, closeStdout), ClosedStream, cph) <- liftIO $ streamingProcess cmd + withXzipCompressor cb $ \xzCompressor -> do + let stream' + = stdoutStream + .| passthroughSizeSink narSizeRef + .| passthroughHashSink narHashRef + .| xzCompressor + .| passthroughSizeSink fileSizeRef + .| passthroughHashSink fileHashRef + + -- for now we need to use letsencrypt domain instead of cloudflare due to its upload limits + let newClientEnv = ce { + baseUrl = (baseUrl ce) { baseUrlHost = toS name <> "." <> baseUrlHost (baseUrl ce)} + } + (_ :: NoContent) <- liftIO $ (`withClientM` newClientEnv) + (Api.createNar (cachixBCStreamingClient name) stream') + $ escalate >=> \NoContent -> do + closeStdout + exitcode <- waitForStreamingProcess cph + when (exitcode /= ExitSuccess) $ throwM $ NarStreamingError exitcode $ show cmd + + -- TODO: we're done, so we can leave withClientM. Doing so + -- will allow more concurrent requests when the number + -- of XZ compressors is limited + narSize <- readIORef narSizeRef + narHashB16 <- readIORef narHashRef + fileHash <- readIORef fileHashRef + fileSize <- readIORef fileSizeRef + + -- TODO: #3: implement using pure haskell + narHash <- ("sha256:" <>) . T.strip . toS <$> readProcess "nix-hash" ["--type", "sha256", "--to-base32", toS narHashB16] mempty + + deriverRaw <- T.strip . toS <$> readProcess "nix-store" ["-q", "--deriver", toS storePath] mempty + let deriver = if deriverRaw == "unknown-deriver" + then deriverRaw + else T.drop 11 deriverRaw + + references <- sort . T.lines . T.strip . toS <$> readProcess "nix-store" ["-q", "--references", toS storePath] mempty + + let + fp = fingerprint storePath narHash narSize references + sig = dsign (signingSecretKey $ pushCacheSigningKey cache) fp + nic = Api.NarInfoCreate + { cStoreHash = storeHash + , cStoreSuffix = storeSuffix + , cNarHash = narHash + , cNarSize = narSize + , cFileSize = fileSize + , cFileHash = fileHash + , cReferences = fmap (T.drop 11) references + , cDeriver = deriver + , cSig = toS $ B64.encode $ unSignature sig + } + + escalate $ Api.isNarInfoCreateValid nic + + -- Upload narinfo with signature + escalate <=< (`runClientM` ce) $ Api.createNarinfo + (cachixBCClient name) + (Api.NarInfoC storeHash) + nic + onDone cb + where + -- Retry up to 5 times for each store path. + -- Catches all exceptions except skipAsyncExceptions + retryPath :: (MonadIO m, MonadMask m) => (RetryStatus -> m a) -> m a + retryPath = recoverAll defaultRetryPolicy + + defaultRetryPolicy :: RetryPolicy + defaultRetryPolicy = + constantDelay 50000 <> limitRetries 3 + +-- | Push an entire closure +-- +-- Note: 'onAlreadyPresent' will be called less often in the future. +pushClosure + :: (MonadIO m, MonadMask m) + => (forall a b. (a -> m b) -> [a] -> m [b]) + -- ^ Traverse paths, responsible for bounding parallel processing of paths + -- + -- For example: @'mapConcurrentlyBounded' 4@ + -> ClientEnv -- ^ See 'pushSingleStorePath' + -> PushCache + -> (Text -> PushStrategy m r) + -> [Text] -- ^ Initial store paths + -> m [r] -- ^ Every @r@ per store path of the entire closure of store paths +pushClosure traversal clientEnv pushCache pushStrategy inputStorePaths = do + + -- Get the transitive closure of dependencies + -- TODO: split args if too big + paths <- liftIO $ T.lines . toS <$> readProcess "nix-store" (fmap toS (["-qR"] <> inputStorePaths)) mempty + + -- TODO: make pool size configurable, on beefier machines this could be doubled + traversal (\path -> pushSingleStorePath clientEnv pushCache (pushStrategy path) path) paths + +mapConcurrentlyBounded :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) +mapConcurrentlyBounded bound action items = do + qs <- QSem.newQSem bound + let wrapped x = bracket_ (QSem.waitQSem qs) (QSem.signalQSem qs) (action x) + mapConcurrently wrapped items + +------------------- +-- Private terms -- + +splitStorePath :: Text -> (Text, Text) +splitStorePath storePath = + (T.take 32 (T.drop 11 storePath), T.drop 44 storePath) diff --git a/src/Cachix/Client/Secrets.hs b/src/Cachix/Client/Secrets.hs new file mode 100644 --- /dev/null +++ b/src/Cachix/Client/Secrets.hs @@ -0,0 +1,44 @@ +-- A facade for working with secrets and their representations, without delving +-- into cryptography libraries. +module Cachix.Client.Secrets ( + + -- * NAR signing + SigningKey(..) + , parseSigningKeyLenient + , exportSigningKey + + -- TODO: * Auth token + +) where + +import Crypto.Sign.Ed25519 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC +import Data.Char ( isSpace ) +import Protolude + +-- | A secret key for signing nars. +newtype SigningKey = SigningKey { signingSecretKey :: SecretKey } + +parseSigningKeyLenientBS + :: ByteString -- ^ ASCII (Base64) + -> Either Text SigningKey -- ^ Error message or signing key +parseSigningKeyLenientBS raw = + let bcDropWhileEnd f = BC.reverse . BC.dropWhile f . BC.reverse + bcDropAround f = bcDropWhileEnd f . BC.dropWhile f + stripped = bcDropAround isSpace raw + nonNull = if BC.null stripped then Left "A signing key must not be empty" else pure stripped + in SigningKey . SecretKey . B64.decodeLenient <$> nonNull + +parseSigningKeyLenient + :: Text -- ^ Base64 + -> Either Text SigningKey -- ^ Error message or signing key +parseSigningKeyLenient = parseSigningKeyLenientBS . toSL + +exportSigningKeyBS + :: SigningKey + -> ByteString -- ^ ASCII (Base64) +exportSigningKeyBS (SigningKey (SecretKey bs)) = B64.encode bs + +exportSigningKey :: SigningKey -> Text +exportSigningKey = toS . exportSigningKeyBS diff --git a/src/Cachix/Client/Servant.hs b/src/Cachix/Client/Servant.hs --- a/src/Cachix/Client/Servant.hs +++ b/src/Cachix/Client/Servant.hs @@ -1,16 +1,64 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -O0 #-} -- TODO https://github.com/haskell-servant/servant/issues/986 module Cachix.Client.Servant ( isErr + , cachixClient + , cachixBCClient + , cachixBCStreamingClient + , runAuthenticatedClient + , Cachix.Client.Servant.ClientError ) where -import Protolude -import Network.HTTP.Types (Status) -import Servant.Client +import Protolude -isErr :: ServantError -> Status -> Bool -isErr (FailureResponse resp) status | responseStatusCode resp == status = True +import qualified Cachix.Api as Api +import Cachix.Api.Error +import qualified Cachix.Client.Config as Config +import qualified Cachix.Client.Env as Env +import qualified Cachix.Client.Exception as Exception +import Network.HTTP.Types (Status) +import Servant.API.Generic +import Servant.Auth () +import Servant.Auth.Client (Token) +import qualified Servant.Client +import Servant.Client.Generic (AsClientT) +import Servant.Client.Streaming +import Servant.Conduit () + +type ClientError = +#if !MIN_VERSION_servant_client(0,16,0) + Servant.Client.ServantError +#else + Servant.Client.ClientError +#endif + +isErr :: ClientError -> Status -> Bool +#if MIN_VERSION_servant_client(0,16,0) +isErr (Servant.Client.FailureResponse _ resp) status +#else +isErr (Servant.Client.FailureResponse resp) status +#endif + | Servant.Client.responseStatusCode resp == status = True isErr _ _ = False + +cachixClient :: Api.CachixAPI (AsClientT ClientM) +cachixClient = fromServant $ client Api.servantApi + +cachixBCClient :: Text -> Api.BinaryCacheAPI (AsClientT ClientM) +cachixBCClient name = fromServant $ Api.cache cachixClient name + +cachixBCStreamingClient :: Text -> Api.BinaryCacheStreamingAPI (AsClientT ClientM) +cachixBCStreamingClient name = fromServant $ client (Proxy :: Proxy Api.BinaryCachStreamingServantAPI) name + +runAuthenticatedClient :: NFData a => Env.Env -> (Token -> ClientM a) -> IO a +runAuthenticatedClient env m = do + config <- escalate $ maybeToEither (Exception.NoConfig + "Start with visiting https://cachix.org and copying the token to $ cachix authtoken ") (Env.config env) + escalate + =<< ((`runClientM` Env.clientenv env) + $ m (Config.authToken config)) diff --git a/src/Cachix/Client/URI.hs b/src/Cachix/Client/URI.hs --- a/src/Cachix/Client/URI.hs +++ b/src/Cachix/Client/URI.hs @@ -1,16 +1,22 @@ --- | Ugly glue between URI and BaseUrl --- | TODO: mark as Internal module {-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} module Cachix.Client.URI ( getBaseUrl + , defaultCachixURI + , defaultCachixBaseUrl ) where import Protolude import qualified URI.ByteString as UBS import URI.ByteString hiding (Scheme) import Servant.Client +import URI.ByteString.QQ +-- TODO: make getBaseUrl internal + +-- | Partial function from URI to BaseUrl +-- getBaseUrl :: URIRef Absolute -> BaseUrl getBaseUrl URI{..} = case uriAuthority of @@ -35,3 +41,9 @@ defaultPort = case getScheme of Http -> 80 Https -> 443 + +defaultCachixURI :: URIRef Absolute +defaultCachixURI = [uri|https://cachix.org|] + +defaultCachixBaseUrl :: BaseUrl +defaultCachixBaseUrl = getBaseUrl defaultCachixURI