{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

{- This is a standalone module so it shouldn't depend on any CLI state like Env -}
module Cachix.Client.Push
  ( -- * Pushing a single path
    pushSingleStorePath,
    uploadStorePath,
    PushParams (..),
    PushSecret (..),
    PushStrategy (..),
    defaultWithXzipCompressor,
    defaultWithXzipCompressorWithLevel,
    findPushSecret,

    -- * Pushing a closure of store paths
    pushClosure,
    getMissingPathsForClosure,
    mapConcurrentlyBounded,
  )
where

import qualified Cachix.API as API
import Cachix.API.Error
import Cachix.API.Signing (fingerprint, passthroughHashSink, passthroughHashSinkB16, passthroughSizeSink)
import qualified Cachix.Client.Config as Config
import Cachix.Client.Exception (CachixException (..))
import Cachix.Client.Retry (retryAll)
import Cachix.Client.Secrets
import Cachix.Client.Servant
import qualified Cachix.Types.ByteStringStreaming
import qualified Cachix.Types.NarInfoCreate as Api
import qualified Cachix.Types.NarInfoHash as NarInfoHash
import Control.Concurrent.Async (mapConcurrently)
import qualified Control.Concurrent.QSem as QSem
import Control.Exception.Safe (MonadMask, throwM)
import Control.Monad.Trans.Resource (ResourceT)
import Control.Retry (RetryStatus)
import Crypto.Sign.Ed25519
import qualified Data.ByteString.Base64 as B64
import Data.Coerce (coerce)
import Data.Conduit
import Data.Conduit.Lzma (compress)
import Data.Conduit.Process hiding (env)
import Data.IORef
import qualified Data.Set as Set
import Data.String.Here
import qualified Data.Text as T
import Hercules.CNix (StorePath)
import qualified Hercules.CNix.Std.Set as Std.Set
import Hercules.CNix.Store (Store)
import qualified Hercules.CNix.Store as Store
import Network.HTTP.Types (status401, status404)
import Protolude hiding (toS)
import Protolude.Conv
import Servant.API
import Servant.Auth ()
import Servant.Auth.Client
import Servant.Client.Streaming
import Servant.Conduit ()
import System.Environment (lookupEnv)
import qualified System.Nix.Base32

data PushSecret
  = PushToken Token
  | PushSigningKey Token SigningKey

data PushParams m r = PushParams
  { PushParams m r -> Text
pushParamsName :: Text,
    PushParams m r -> PushSecret
pushParamsSecret :: PushSecret,
    -- | how to report results, (some) errors, and do some things
    PushParams m r -> StorePath -> PushStrategy m r
pushParamsStrategy :: StorePath -> PushStrategy m r,
    -- | cachix base url, connection manager, see 'Cachix.Client.URI.defaultCachixBaseUrl', 'Servant.Client.mkClientEnv'
    PushParams m r -> ClientEnv
pushParamsClientEnv :: ClientEnv,
    PushParams m r -> Store
pushParamsStore :: Store
  }

data PushStrategy m r = PushStrategy
  { -- | Called when a path is already in the cache.
    PushStrategy m r -> m r
onAlreadyPresent :: m r,
    PushStrategy m r -> RetryStatus -> Int64 -> m ()
onAttempt :: RetryStatus -> Int64 -> m (),
    PushStrategy m r -> m r
on401 :: m r,
    PushStrategy m r -> ClientError -> m r
onError :: ClientError -> m r,
    PushStrategy m r -> m r
onDone :: m r,
    PushStrategy m r
-> forall a.
   (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
withXzipCompressor :: forall a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a,
    PushStrategy m r -> Bool
omitDeriver :: Bool
  }

defaultWithXzipCompressor :: forall m a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
defaultWithXzipCompressor :: (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
defaultWithXzipCompressor = ((ConduitM ByteString ByteString (ResourceT IO) () -> m a)
-> ConduitM ByteString ByteString (ResourceT IO) () -> m a
forall a b. (a -> b) -> a -> b
$ Maybe Int -> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
Maybe Int -> ConduitM ByteString ByteString m ()
compress (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2))

defaultWithXzipCompressorWithLevel :: Int -> forall m a. (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
defaultWithXzipCompressorWithLevel :: Int
-> forall (m :: * -> *) a.
   (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
defaultWithXzipCompressorWithLevel Int
l = ((ConduitM ByteString ByteString (ResourceT IO) () -> m a)
-> ConduitM ByteString ByteString (ResourceT IO) () -> m a
forall a b. (a -> b) -> a -> b
$ Maybe Int -> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
Maybe Int -> ConduitM ByteString ByteString m ()
compress (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l))

pushSingleStorePath ::
  (MonadMask m, MonadIO m) =>
  -- | details for pushing to cache
  PushParams m r ->
  -- | store path
  StorePath ->
  -- | r is determined by the 'PushStrategy'
  m r
pushSingleStorePath :: PushParams m r -> StorePath -> m r
pushSingleStorePath PushParams m r
cache StorePath
storePath = (RetryStatus -> m r) -> m r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(RetryStatus -> m a) -> m a
retryAll ((RetryStatus -> m r) -> m r) -> (RetryStatus -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \RetryStatus
retrystatus -> do
  ByteString
storeHash <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ StorePath -> IO ByteString
Store.getStorePathHash StorePath
storePath
  let name :: Text
name = PushParams m r -> Text
forall (m :: * -> *) r. PushParams m r -> Text
pushParamsName PushParams m r
cache
      strategy :: PushStrategy m r
strategy = PushParams m r -> StorePath -> PushStrategy m r
forall (m :: * -> *) r.
PushParams m r -> StorePath -> PushStrategy m r
pushParamsStrategy PushParams m r
cache StorePath
storePath
  -- Check if narinfo already exists
  Either ClientError NoContent
res <-
    IO (Either ClientError NoContent)
-> m (Either ClientError NoContent)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError NoContent)
 -> m (Either ClientError NoContent))
-> IO (Either ClientError NoContent)
-> m (Either ClientError NoContent)
forall a b. (a -> b) -> a -> b
$
      (ClientM NoContent -> ClientEnv -> IO (Either ClientError NoContent)
forall a.
NFData a =>
ClientM a -> ClientEnv -> IO (Either ClientError a)
`runClientM` PushParams m r -> ClientEnv
forall (m :: * -> *) r. PushParams m r -> ClientEnv
pushParamsClientEnv PushParams m r
cache) (ClientM NoContent -> IO (Either ClientError NoContent))
-> ClientM NoContent -> IO (Either ClientError NoContent)
forall a b. (a -> b) -> a -> b
$
        BinaryCacheAPI (AsClientT ClientM)
-> Token -> Text -> NarInfoHash -> ClientM NoContent
forall route.
BinaryCacheAPI route
-> route
   :- (CachixAuth
       :> ("cache"
           :> (Capture "name" Text
               :> (Capture "narinfohash" NarInfoHash :> Head))))
API.narinfoHead
          BinaryCacheAPI (AsClientT ClientM)
cachixClient
          (PushSecret -> Token
getCacheAuthToken (PushParams m r -> PushSecret
forall (m :: * -> *) r. PushParams m r -> PushSecret
pushParamsSecret PushParams m r
cache))
          Text
name
          (Text -> NarInfoHash
NarInfoHash.NarInfoHash (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
storeHash))
  case Either ClientError NoContent
res of
    Right NoContent
NoContent -> PushStrategy m r -> m r
forall (m :: * -> *) r. PushStrategy m r -> m r
onAlreadyPresent PushStrategy m r
strategy -- we're done as store path is already in the cache
    Left ClientError
err
      | ClientError -> Status -> Bool
isErr ClientError
err Status
status404 -> PushParams m r -> StorePath -> RetryStatus -> m r
forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
PushParams m r -> StorePath -> RetryStatus -> m r
uploadStorePath PushParams m r
cache StorePath
storePath RetryStatus
retrystatus
      | ClientError -> Status -> Bool
isErr ClientError
err Status
status401 -> PushStrategy m r -> m r
forall (m :: * -> *) r. PushStrategy m r -> m r
on401 PushStrategy m r
strategy
      | Bool
otherwise -> PushStrategy m r -> ClientError -> m r
forall (m :: * -> *) r. PushStrategy m r -> ClientError -> m r
onError PushStrategy m r
strategy ClientError
err

getCacheAuthToken :: PushSecret -> Token
getCacheAuthToken :: PushSecret -> Token
getCacheAuthToken (PushToken Token
token) = Token
token
getCacheAuthToken (PushSigningKey Token
token SigningKey
_) = Token
token

uploadStorePath ::
  (MonadMask m, MonadIO m) =>
  -- | details for pushing to cache
  PushParams m r ->
  StorePath ->
  RetryStatus ->
  -- | r is determined by the 'PushStrategy'
  m r
uploadStorePath :: PushParams m r -> StorePath -> RetryStatus -> m r
uploadStorePath PushParams m r
cache StorePath
storePath RetryStatus
retrystatus = do
  let store :: Store
store = PushParams m r -> Store
forall (m :: * -> *) r. PushParams m r -> Store
pushParamsStore PushParams m r
cache
  -- TODO: storePathText is redundant. Use storePath directly.
  ByteString
storePathText <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Store -> StorePath -> IO ByteString
Store.storePathToPath Store
store StorePath
storePath
  let (Text
storeHash, Text
storeSuffix) = Text -> (Text, Text)
splitStorePath (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
storePathText
      name :: Text
name = PushParams m r -> Text
forall (m :: * -> *) r. PushParams m r -> Text
pushParamsName PushParams m r
cache
      clientEnv :: ClientEnv
clientEnv = PushParams m r -> ClientEnv
forall (m :: * -> *) r. PushParams m r -> ClientEnv
pushParamsClientEnv PushParams m r
cache
      strategy :: PushStrategy m r
strategy = PushParams m r -> StorePath -> PushStrategy m r
forall (m :: * -> *) r.
PushParams m r -> StorePath -> PushStrategy m r
pushParamsStrategy PushParams m r
cache StorePath
storePath
  IORef Integer
narSizeRef <- IO (IORef Integer) -> m (IORef Integer)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Integer) -> m (IORef Integer))
-> IO (IORef Integer) -> m (IORef Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
  IORef Integer
fileSizeRef <- IO (IORef Integer) -> m (IORef Integer)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Integer) -> m (IORef Integer))
-> IO (IORef Integer) -> m (IORef Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
  IORef ByteString
narHashRef <- IO (IORef ByteString) -> m (IORef ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef ByteString) -> m (IORef ByteString))
-> IO (IORef ByteString) -> m (IORef ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef (ByteString
"" :: ByteString)
  IORef ByteString
fileHashRef <- IO (IORef ByteString) -> m (IORef ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef ByteString) -> m (IORef ByteString))
-> IO (IORef ByteString) -> m (IORef ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef (ByteString
"" :: ByteString)
  -- This should be a noop because storePathText came from a StorePath
  StorePath
normalized <- IO StorePath -> m StorePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StorePath -> m StorePath) -> IO StorePath -> m StorePath
forall a b. (a -> b) -> a -> b
$ Store -> ByteString -> IO StorePath
Store.followLinksToStorePath Store
store (ByteString -> IO StorePath) -> ByteString -> IO StorePath
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS ByteString
storePathText
  ForeignPtr (Ref ValidPathInfo)
pathinfo <- IO (ForeignPtr (Ref ValidPathInfo))
-> m (ForeignPtr (Ref ValidPathInfo))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignPtr (Ref ValidPathInfo))
 -> m (ForeignPtr (Ref ValidPathInfo)))
-> IO (ForeignPtr (Ref ValidPathInfo))
-> m (ForeignPtr (Ref ValidPathInfo))
forall a b. (a -> b) -> a -> b
$ Store -> StorePath -> IO (ForeignPtr (Ref ValidPathInfo))
Store.queryPathInfo Store
store StorePath
normalized
  -- stream store path as xz compressed nar file
  let cmd :: CreateProcess
cmd = FilePath -> [FilePath] -> CreateProcess
proc FilePath
"nix-store" [FilePath
"--dump", ByteString -> FilePath
forall a b. StringConv a b => a -> b
toS ByteString
storePathText]
      storePathSize :: Int64
      storePathSize :: Int64
storePathSize = ForeignPtr (Ref ValidPathInfo) -> Int64
Store.validPathInfoNarSize ForeignPtr (Ref ValidPathInfo)
pathinfo
  PushStrategy m r -> RetryStatus -> Int64 -> m ()
forall (m :: * -> *) r.
PushStrategy m r -> RetryStatus -> Int64 -> m ()
onAttempt PushStrategy m r
strategy RetryStatus
retrystatus Int64
storePathSize
  -- create_group makes subprocess ignore signals such as ctrl-c that we handle in haskell main thread
  -- see https://github.com/haskell/process/issues/198
  (ClosedStream
ClosedStream, ConduitM () ByteString (ResourceT IO) ()
stdoutStream, Inherited
Inherited, StreamingProcessHandle
cph) <- IO
  (ClosedStream, ConduitM () ByteString (ResourceT IO) (), Inherited,
   StreamingProcessHandle)
-> m (ClosedStream, ConduitM () ByteString (ResourceT IO) (),
      Inherited, StreamingProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (ClosedStream, ConduitM () ByteString (ResourceT IO) (), Inherited,
    StreamingProcessHandle)
 -> m (ClosedStream, ConduitM () ByteString (ResourceT IO) (),
       Inherited, StreamingProcessHandle))
-> IO
     (ClosedStream, ConduitM () ByteString (ResourceT IO) (), Inherited,
      StreamingProcessHandle)
-> m (ClosedStream, ConduitM () ByteString (ResourceT IO) (),
      Inherited, StreamingProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO
     (ClosedStream, ConduitM () ByteString (ResourceT IO) (), Inherited,
      StreamingProcessHandle)
forall (m :: * -> *) stdin stdout stderr.
(MonadIO m, InputSource stdin, OutputSink stdout,
 OutputSink stderr) =>
CreateProcess -> m (stdin, stdout, stderr, StreamingProcessHandle)
streamingProcess (CreateProcess
cmd {create_group :: Bool
create_group = Bool
True})
  PushStrategy m r
-> forall a.
   (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
forall (m :: * -> *) r.
PushStrategy m r
-> forall a.
   (ConduitM ByteString ByteString (ResourceT IO) () -> m a) -> m a
withXzipCompressor PushStrategy m r
strategy ((ConduitM ByteString ByteString (ResourceT IO) () -> m r) -> m r)
-> (ConduitM ByteString ByteString (ResourceT IO) () -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString ByteString (ResourceT IO) ()
xzCompressor -> do
    let stream' :: ConduitM () ByteString (ResourceT IO) ()
stream' =
          ConduitM () ByteString (ResourceT IO) ()
stdoutStream
            ConduitM () ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM () ByteString (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| IORef Integer -> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
IORef Integer -> ConduitT ByteString ByteString m ()
passthroughSizeSink IORef Integer
narSizeRef
            ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| IORef ByteString
-> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
IORef ByteString -> ConduitT ByteString ByteString m ()
passthroughHashSink IORef ByteString
narHashRef
            ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString ByteString (ResourceT IO) ()
xzCompressor
            ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| IORef Integer -> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
IORef Integer -> ConduitT ByteString ByteString m ()
passthroughSizeSink IORef Integer
fileSizeRef
            ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
-> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| IORef ByteString
-> ConduitM ByteString ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
IORef ByteString -> ConduitT ByteString ByteString m ()
passthroughHashSinkB16 IORef ByteString
fileHashRef
    let subdomain :: FilePath
subdomain =
          -- TODO: multipart
          if (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
storePathSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1024 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1024) :: Double) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
100
            then FilePath
"api"
            else Text -> FilePath
forall a b. StringConv a b => a -> b
toS Text
name
        newClientEnv :: ClientEnv
newClientEnv =
          ClientEnv
clientEnv
            { baseUrl :: BaseUrl
baseUrl = (ClientEnv -> BaseUrl
baseUrl ClientEnv
clientEnv) {baseUrlHost :: FilePath
baseUrlHost = FilePath
subdomain FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> BaseUrl -> FilePath
baseUrlHost (ClientEnv -> BaseUrl
baseUrl ClientEnv
clientEnv)}
            }
    (NoContent
_ :: NoContent) <-
      IO NoContent -> m NoContent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NoContent -> m NoContent) -> IO NoContent -> m NoContent
forall a b. (a -> b) -> a -> b
$
        (ClientM NoContent
-> ClientEnv
-> (Either ClientError NoContent -> IO NoContent)
-> IO NoContent
forall a b.
ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
`withClientM` ClientEnv
newClientEnv)
          (BinaryCacheAPI (AsClientT ClientM)
-> Token
-> Text
-> ConduitT () ByteStringStreaming (ResourceT IO) ()
-> ClientM NoContent
forall route.
BinaryCacheAPI route
-> route
   :- (CachixAuth
       :> ("cache"
           :> (Capture "name" Text
               :> ("nar"
                   :> (StreamBody
                         NoFraming
                         XNixNar
                         (ConduitT () ByteStringStreaming (ResourceT IO) ())
                       :> Post '[JSON] NoContent)))))
API.createNar BinaryCacheAPI (AsClientT ClientM)
cachixClient (PushSecret -> Token
getCacheAuthToken (PushParams m r -> PushSecret
forall (m :: * -> *) r. PushParams m r -> PushSecret
pushParamsSecret PushParams m r
cache)) Text
name ((ByteString -> ByteStringStreaming)
-> ConduitM () ByteString (ResourceT IO) ()
-> ConduitT () ByteStringStreaming (ResourceT IO) ()
forall (m :: * -> *) o1 o2 i r.
Monad m =>
(o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r
mapOutput ByteString -> ByteStringStreaming
coerce ConduitM () ByteString (ResourceT IO) ()
stream'))
          ((Either ClientError NoContent -> IO NoContent) -> IO NoContent)
-> (Either ClientError NoContent -> IO NoContent) -> IO NoContent
forall a b. (a -> b) -> a -> b
$ Either ClientError NoContent -> IO NoContent
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate
            (Either ClientError NoContent -> IO NoContent)
-> (NoContent -> IO NoContent)
-> Either ClientError NoContent
-> IO NoContent
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \NoContent
NoContent -> do
              ExitCode
exitcode <- StreamingProcessHandle -> IO ExitCode
forall (m :: * -> *).
MonadIO m =>
StreamingProcessHandle -> m ExitCode
waitForStreamingProcess StreamingProcessHandle
cph
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CachixException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CachixException -> IO ()) -> CachixException -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> Text -> CachixException
NarStreamingError ExitCode
exitcode (Text -> CachixException) -> Text -> CachixException
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show CreateProcess
cmd
              NoContent -> IO NoContent
forall (m :: * -> *) a. Monad m => a -> m a
return NoContent
NoContent
    (NoContent
_ :: NoContent) <- IO NoContent -> m NoContent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NoContent -> m NoContent) -> IO NoContent -> m NoContent
forall a b. (a -> b) -> a -> b
$ do
      Integer
narSize <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
narSizeRef
      Text
narHash <- (Text
"sha256:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
System.Nix.Base32.encode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
narHashRef
      ByteString
narHashNix <- ForeignPtr (Ref ValidPathInfo) -> IO ByteString
Store.validPathInfoNarHash32 ForeignPtr (Ref ValidPathInfo)
pathinfo
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
narHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
narHashNix) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CachixException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CachixException -> IO ()) -> CachixException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> CachixException
NarHashMismatch Text
"Nar hash mismatch between nix-store --dump and nix db. You can repair db metadata by running as root: $ nix-store --verify --repair"
      ByteString
fileHash <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
fileHashRef
      Integer
fileSize <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
fileSizeRef
      Maybe StorePath
deriverPath <-
        if PushStrategy m r -> Bool
forall (m :: * -> *) r. PushStrategy m r -> Bool
omitDeriver PushStrategy m r
strategy
          then Maybe StorePath -> IO (Maybe StorePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StorePath
forall a. Maybe a
Nothing
          else Store -> ForeignPtr (Ref ValidPathInfo) -> IO (Maybe StorePath)
Store.validPathInfoDeriver Store
store ForeignPtr (Ref ValidPathInfo)
pathinfo
      Maybe ByteString
deriver <- Maybe StorePath
-> (StorePath -> IO ByteString) -> IO (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe StorePath
deriverPath StorePath -> IO ByteString
Store.getStorePathBaseName
      [StorePath]
referencesPathSet <- Store -> ForeignPtr (Ref ValidPathInfo) -> IO [StorePath]
Store.validPathInfoReferences Store
store ForeignPtr (Ref ValidPathInfo)
pathinfo
      [Text]
referencesPaths <- [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text])
-> ([ByteString] -> [Text]) -> [ByteString] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
forall a b. StringConv a b => a -> b
toS ([ByteString] -> [Text]) -> IO [ByteString] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StorePath] -> (StorePath -> IO ByteString) -> IO [ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [StorePath]
referencesPathSet (Store -> StorePath -> IO ByteString
Store.storePathToPath Store
store)
      [Text]
references <- [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text])
-> ([ByteString] -> [Text]) -> [ByteString] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
forall a b. StringConv a b => a -> b
toS ([ByteString] -> [Text]) -> IO [ByteString] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StorePath] -> (StorePath -> IO ByteString) -> IO [ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [StorePath]
referencesPathSet StorePath -> IO ByteString
Store.getStorePathBaseName
      let fp :: ByteString
fp = Text -> Text -> Integer -> [Text] -> ByteString
fingerprint (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
storePathText) Text
narHash Integer
narSize [Text]
referencesPaths
          (Maybe Text
sig, Token
authToken) = case PushParams m r -> PushSecret
forall (m :: * -> *) r. PushParams m r -> PushSecret
pushParamsSecret PushParams m r
cache of
            PushToken Token
token -> (Maybe Text
forall a. Maybe a
Nothing, Token
token)
            PushSigningKey Token
token SigningKey
signKey -> (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Signature -> ByteString
unSignature (Signature -> ByteString) -> Signature -> ByteString
forall a b. (a -> b) -> a -> b
$ SecretKey -> ByteString -> Signature
dsign (SigningKey -> SecretKey
signingSecretKey SigningKey
signKey) ByteString
fp, Token
token)
          nic :: NarInfoCreate
nic =
            NarInfoCreate :: Text
-> Text
-> Text
-> Integer
-> Text
-> Integer
-> [Text]
-> Text
-> Maybe Text
-> NarInfoCreate
Api.NarInfoCreate
              { cStoreHash :: Text
Api.cStoreHash = Text
storeHash,
                cStoreSuffix :: Text
Api.cStoreSuffix = Text
storeSuffix,
                cNarHash :: Text
Api.cNarHash = Text
narHash,
                cNarSize :: Integer
Api.cNarSize = Integer
narSize,
                cFileSize :: Integer
Api.cFileSize = Integer
fileSize,
                cFileHash :: Text
Api.cFileHash = ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
fileHash,
                cReferences :: [Text]
Api.cReferences = [Text]
references,
                cDeriver :: Text
Api.cDeriver = Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"unknown-deriver" (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) Maybe ByteString
deriver,
                cSig :: Maybe Text
Api.cSig = Maybe Text
sig
              }
      Either NarInfoInvalid () -> IO ()
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate (Either NarInfoInvalid () -> IO ())
-> Either NarInfoInvalid () -> IO ()
forall a b. (a -> b) -> a -> b
$ NarInfoCreate -> Either NarInfoInvalid ()
Api.isNarInfoCreateValid NarInfoCreate
nic
      -- Upload narinfo with signature
      Either ClientError NoContent -> IO NoContent
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate (Either ClientError NoContent -> IO NoContent)
-> (ClientM NoContent -> IO (Either ClientError NoContent))
-> ClientM NoContent
-> IO NoContent
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (ClientM NoContent -> ClientEnv -> IO (Either ClientError NoContent)
forall a.
NFData a =>
ClientM a -> ClientEnv -> IO (Either ClientError a)
`runClientM` ClientEnv
clientEnv) (ClientM NoContent -> IO NoContent)
-> ClientM NoContent -> IO NoContent
forall a b. (a -> b) -> a -> b
$
        BinaryCacheAPI (AsClientT ClientM)
-> Token
-> Text
-> NarInfoHash
-> NarInfoCreate
-> ClientM NoContent
forall route.
BinaryCacheAPI route
-> route
   :- (CachixAuth
       :> ("cache"
           :> (Capture "name" Text
               :> (Capture "narinfohash" NarInfoHash
                   :> (ReqBody '[JSON] NarInfoCreate :> Post '[JSON] NoContent)))))
API.createNarinfo
          BinaryCacheAPI (AsClientT ClientM)
cachixClient
          Token
authToken
          Text
name
          (Text -> NarInfoHash
NarInfoHash.NarInfoHash Text
storeHash)
          NarInfoCreate
nic
    PushStrategy m r -> m r
forall (m :: * -> *) r. PushStrategy m r -> m r
onDone PushStrategy m r
strategy

-- | Push an entire closure
--
-- Note: 'onAlreadyPresent' will be called less often in the future.
pushClosure ::
  (MonadIO m, MonadMask m) =>
  -- | Traverse paths, responsible for bounding parallel processing of paths
  --
  -- For example: @'mapConcurrentlyBounded' 4@
  (forall a b. (a -> m b) -> [a] -> m [b]) ->
  PushParams m r ->
  -- | Initial store paths
  [StorePath] ->
  -- | Every @r@ per store path of the entire closure of store paths
  m [r]
pushClosure :: (forall a b. (a -> m b) -> [a] -> m [b])
-> PushParams m r -> [StorePath] -> m [r]
pushClosure forall a b. (a -> m b) -> [a] -> m [b]
traversal PushParams m r
pushParams [StorePath]
inputStorePaths = do
  [StorePath]
missingPaths <- PushParams m r -> [StorePath] -> m [StorePath]
forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
PushParams m r -> [StorePath] -> m [StorePath]
getMissingPathsForClosure PushParams m r
pushParams [StorePath]
inputStorePaths
  (StorePath -> m r) -> [StorePath] -> m [r]
forall a b. (a -> m b) -> [a] -> m [b]
traversal (\StorePath
path -> (RetryStatus -> m r) -> m r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(RetryStatus -> m a) -> m a
retryAll ((RetryStatus -> m r) -> m r) -> (RetryStatus -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \RetryStatus
retrystatus -> PushParams m r -> StorePath -> RetryStatus -> m r
forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
PushParams m r -> StorePath -> RetryStatus -> m r
uploadStorePath PushParams m r
pushParams StorePath
path RetryStatus
retrystatus) [StorePath]
missingPaths

getMissingPathsForClosure :: (MonadIO m, MonadMask m) => PushParams m r -> [StorePath] -> m [StorePath]
getMissingPathsForClosure :: PushParams m r -> [StorePath] -> m [StorePath]
getMissingPathsForClosure PushParams m r
pushParams [StorePath]
inputPaths = do
  let store :: Store
store = PushParams m r -> Store
forall (m :: * -> *) r. PushParams m r -> Store
pushParamsStore PushParams m r
pushParams
      clientEnv :: ClientEnv
clientEnv = PushParams m r -> ClientEnv
forall (m :: * -> *) r. PushParams m r -> ClientEnv
pushParamsClientEnv PushParams m r
pushParams
  -- Get the transitive closure of dependencies
  ([StorePath]
paths :: [Store.StorePath]) <-
    IO [StorePath] -> m [StorePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [StorePath] -> m [StorePath])
-> IO [StorePath] -> m [StorePath]
forall a b. (a -> b) -> a -> b
$ do
      StdSet NixStorePath
inputs <- IO (StdSet NixStorePath)
forall a. HasStdSet a => IO (StdSet a)
Std.Set.new
      [StorePath] -> (StorePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [StorePath]
inputPaths ((StorePath -> IO ()) -> IO ()) -> (StorePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StorePath
path -> do
        StdSet NixStorePath -> StorePath -> IO ()
forall a' a.
(Coercible a' (ForeignPtr a), HasStdSet a) =>
StdSet a -> a' -> IO ()
Std.Set.insertFP StdSet NixStorePath
inputs StorePath
path
      StdSet NixStorePath
closure <- Store
-> ClosureParams -> StdSet NixStorePath -> IO (StdSet NixStorePath)
Store.computeFSClosure Store
store ClosureParams
Store.defaultClosureParams StdSet NixStorePath
inputs
      StdSet NixStorePath -> IO [StorePath]
forall a b.
(HasStdSet a, HasEncapsulation a b) =>
StdSet a -> IO [b]
Std.Set.toListFP StdSet NixStorePath
closure
  [Text]
hashes <- [StorePath] -> (StorePath -> m Text) -> m [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [StorePath]
paths (IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text)
-> (StorePath -> IO Text) -> StorePath -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) (IO ByteString -> IO Text)
-> (StorePath -> IO ByteString) -> StorePath -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> IO ByteString
Store.getStorePathHash)
  -- Check what store paths are missing
  [Text]
missingHashesList <-
    (RetryStatus -> m [Text]) -> m [Text]
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(RetryStatus -> m a) -> m a
retryAll ((RetryStatus -> m [Text]) -> m [Text])
-> (RetryStatus -> m [Text]) -> m [Text]
forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ ->
      Either ClientError [Text] -> m [Text]
forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate
        (Either ClientError [Text] -> m [Text])
-> m (Either ClientError [Text]) -> m [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either ClientError [Text]) -> m (Either ClientError [Text])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          ( (ClientM [Text] -> ClientEnv -> IO (Either ClientError [Text])
forall a.
NFData a =>
ClientM a -> ClientEnv -> IO (Either ClientError a)
`runClientM` ClientEnv
clientEnv) (ClientM [Text] -> IO (Either ClientError [Text]))
-> ClientM [Text] -> IO (Either ClientError [Text])
forall a b. (a -> b) -> a -> b
$
              BinaryCacheAPI (AsClientT ClientM)
-> Token -> Text -> [Text] -> ClientM [Text]
forall route.
BinaryCacheAPI route
-> route
   :- (CachixAuth
       :> ("cache"
           :> (Capture "name" Text
               :> ("narinfo"
                   :> (Summary
                         "Given a list of store hashes, return a list of those that are missing"
                       :> (ReqBody '[JSON] [Text] :> Post '[JSON] [Text]))))))
API.narinfoBulk
                BinaryCacheAPI (AsClientT ClientM)
cachixClient
                (PushSecret -> Token
getCacheAuthToken (PushParams m r -> PushSecret
forall (m :: * -> *) r. PushParams m r -> PushSecret
pushParamsSecret PushParams m r
pushParams))
                (PushParams m r -> Text
forall (m :: * -> *) r. PushParams m r -> Text
pushParamsName PushParams m r
pushParams)
                [Text]
hashes
          )
  let missingHashes :: Set ByteString
missingHashes = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> [Text] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
missingHashesList)
  [(ByteString, StorePath)]
pathsAndHashes <- IO [(ByteString, StorePath)] -> m [(ByteString, StorePath)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(ByteString, StorePath)] -> m [(ByteString, StorePath)])
-> IO [(ByteString, StorePath)] -> m [(ByteString, StorePath)]
forall a b. (a -> b) -> a -> b
$
    [StorePath]
-> (StorePath -> IO (ByteString, StorePath))
-> IO [(ByteString, StorePath)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [StorePath]
paths ((StorePath -> IO (ByteString, StorePath))
 -> IO [(ByteString, StorePath)])
-> (StorePath -> IO (ByteString, StorePath))
-> IO [(ByteString, StorePath)]
forall a b. (a -> b) -> a -> b
$ \StorePath
path -> do
      ByteString
hash_ <- StorePath -> IO ByteString
Store.getStorePathHash StorePath
path
      (ByteString, StorePath) -> IO (ByteString, StorePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
hash_, StorePath
path)
  [StorePath] -> m [StorePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([StorePath] -> m [StorePath]) -> [StorePath] -> m [StorePath]
forall a b. (a -> b) -> a -> b
$ ((ByteString, StorePath) -> StorePath)
-> [(ByteString, StorePath)] -> [StorePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString, StorePath) -> StorePath
forall a b. (a, b) -> b
snd ([(ByteString, StorePath)] -> [StorePath])
-> [(ByteString, StorePath)] -> [StorePath]
forall a b. (a -> b) -> a -> b
$ ((ByteString, StorePath) -> Bool)
-> [(ByteString, StorePath)] -> [(ByteString, StorePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString
hash_, StorePath
_path) -> ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ByteString
hash_ Set ByteString
missingHashes) [(ByteString, StorePath)]
pathsAndHashes

-- TODO: move to a separate module specific to cli

-- | Find auth token or signing key in the 'Config' or environment variable
findPushSecret ::
  Maybe Config.Config ->
  -- | Cache name
  Text ->
  -- | Secret key or exception
  IO PushSecret
findPushSecret :: Maybe Config -> Text -> IO PushSecret
findPushSecret Maybe Config
config Text
name = do
  Maybe Text
maybeSigningKeyEnv <- FilePath -> Text
forall a b. StringConv a b => a -> b
toS (FilePath -> Text) -> IO (Maybe FilePath) -> IO (Maybe Text)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CACHIX_SIGNING_KEY"
  Maybe Token
maybeAuthToken <- Maybe Config -> IO (Maybe Token)
Config.getAuthTokenMaybe Maybe Config
config
  let maybeSigningKeyConfig :: Maybe Text
maybeSigningKeyConfig = case Maybe Config
config of
        Maybe Config
Nothing -> Maybe Text
forall a. Maybe a
Nothing
        Just Config
cfg -> BinaryCacheConfig -> Text
Config.secretKey (BinaryCacheConfig -> Text)
-> Maybe BinaryCacheConfig -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BinaryCacheConfig] -> Maybe BinaryCacheConfig
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head (Config -> [BinaryCacheConfig]
getBinaryCache Config
cfg)
  case Maybe Text
maybeSigningKeyEnv Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
maybeSigningKeyConfig of
    Just Text
signingKey -> (Text -> FatalError) -> Either Text PushSecret -> IO PushSecret
forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs Text -> FatalError
FatalError (Either Text PushSecret -> IO PushSecret)
-> Either Text PushSecret -> IO PushSecret
forall a b. (a -> b) -> a -> b
$ Token -> SigningKey -> PushSecret
PushSigningKey (Token -> Maybe Token -> Token
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Token
Token ByteString
"") Maybe Token
maybeAuthToken) (SigningKey -> PushSecret)
-> Either Text SigningKey -> Either Text PushSecret
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text SigningKey
parseSigningKeyLenient Text
signingKey
    Maybe Text
Nothing -> case Maybe Token
maybeAuthToken of
      Just Token
authToken -> PushSecret -> IO PushSecret
forall (m :: * -> *) a. Monad m => a -> m a
return (PushSecret -> IO PushSecret) -> PushSecret -> IO PushSecret
forall a b. (a -> b) -> a -> b
$ Token -> PushSecret
PushToken Token
authToken
      Maybe Token
Nothing -> CachixException -> IO PushSecret
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CachixException -> IO PushSecret)
-> CachixException -> IO PushSecret
forall a b. (a -> b) -> a -> b
$ Text -> CachixException
NoSigningKey Text
msg
  where
    -- we reverse list of caches to prioritize keys added as last
    getBinaryCache :: Config -> [BinaryCacheConfig]
getBinaryCache Config
c = (BinaryCacheConfig -> Bool)
-> [BinaryCacheConfig] -> [BinaryCacheConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter (\BinaryCacheConfig
bc -> BinaryCacheConfig -> Text
Config.name BinaryCacheConfig
bc Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) ([BinaryCacheConfig] -> [BinaryCacheConfig])
-> [BinaryCacheConfig] -> [BinaryCacheConfig]
forall a b. (a -> b) -> a -> b
$ [BinaryCacheConfig] -> [BinaryCacheConfig]
forall a. [a] -> [a]
reverse ([BinaryCacheConfig] -> [BinaryCacheConfig])
-> [BinaryCacheConfig] -> [BinaryCacheConfig]
forall a b. (a -> b) -> a -> b
$ Config -> [BinaryCacheConfig]
Config.binaryCaches Config
c
    msg :: Text
    msg :: Text
msg =
      [iTrim|
Neither auth token nor signing key are present.

They are looked up via $CACHIX_AUTH_TOKEN and $CACHIX_SIGNING_KEY,
and if missing also looked up from ~/.config/cachix/cachix.dhall

Read https://mycache.cachix.org for instructions how to push to your binary cache.
    |]

mapConcurrentlyBounded :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b)
mapConcurrentlyBounded :: Int -> (a -> IO b) -> t a -> IO (t b)
mapConcurrentlyBounded Int
bound a -> IO b
action t a
items = do
  QSem
qs <- Int -> IO QSem
QSem.newQSem Int
bound
  let wrapped :: a -> IO b
wrapped a
x = IO () -> IO () -> IO b -> IO b
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (QSem -> IO ()
QSem.waitQSem QSem
qs) (QSem -> IO ()
QSem.signalQSem QSem
qs) (a -> IO b
action a
x)
  (a -> IO b) -> t a -> IO (t b)
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently a -> IO b
wrapped t a
items

-------------------
-- Private terms --
splitStorePath :: Text -> (Text, Text)
splitStorePath :: Text -> (Text, Text)
splitStorePath Text
storePath =
  (Int -> Text -> Text
T.take Int
32 (Int -> Text -> Text
T.drop Int
11 Text
storePath), Int -> Text -> Text
T.drop Int
44 Text
storePath)