cachix 0.2.0 → 0.2.1
raw patch · 11 files changed
+462/−171 lines, 11 filesdep +resourcetdep −data-defaultdep ~cachix-api
Dependencies added: resourcet
Dependencies removed: data-default
Dependency ranges changed: cachix-api
Files
- CHANGELOG.md +21/−0
- cachix.cabal +4/−2
- cachix/Main.hs +4/−2
- src/Cachix/Client.hs +1/−1
- src/Cachix/Client/Commands.hs +72/−149
- src/Cachix/Client/NetRc.hs +3/−1
- src/Cachix/Client/OptionsParser.hs +36/−9
- src/Cachix/Client/Push.hs +210/−0
- src/Cachix/Client/Secrets.hs +44/−0
- src/Cachix/Client/Servant.hs +53/−5
- src/Cachix/Client/URI.hs +14/−2
CHANGELOG.md view
@@ -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
cachix.cabal view
@@ -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
cachix/Main.hs view
@@ -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
src/Cachix/Client.hs view
@@ -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
src/Cachix/Client/Commands.hs view
@@ -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 <token>" 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
src/Cachix/Client/NetRc.hs view
@@ -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
src/Cachix/Client/OptionsParser.hs view
@@ -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'
+ src/Cachix/Client/Push.hs view
@@ -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)
+ src/Cachix/Client/Secrets.hs view
@@ -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
src/Cachix/Client/Servant.hs view
@@ -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 <token>") (Env.config env)+ escalate+ =<< ((`runClientM` Env.clientenv env)+ $ m (Config.authToken config))
src/Cachix/Client/URI.hs view
@@ -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