feat: attic cache support

hercules-ci-agent/hercules-ci-agent.cabal

@@ -208,6 +208,7 @@ executable hercules-ci-agent
       Data.Map.Extras.Hercules
       Hercules.Agent
       Hercules.Agent.AgentSocket
+      Hercules.Agent.Attic
       Hercules.Agent.Bag
       Hercules.Agent.Build
       Hercules.Agent.CabalInfo
@@ -266,6 +267,7 @@ executable hercules-ci-agent
       -- that support static linking, as they require.
     , cachix <1.4 || >=1.5
     , cachix-api
+    , crypton
     , hercules-ci-cnix-store
     , conduit
     , conduit-extra

hercules-ci-agent/hercules-ci-agent/Hercules/Agent.hs

@@ -60,7 +60,7 @@ import Hercules.Agent.Options qualified as Options
 import Hercules.Agent.STM
 import Hercules.Agent.ServiceInfo qualified
 import Hercules.Agent.Socket qualified as Socket
-import Hercules.Agent.Token (withAgentToken)
+import Hercules.Agent.Token (pruneContentAddressedSecretStates, withAgentToken)
 import Hercules.CNix.Store qualified as CNix.Store
 import Hercules.Error
   ( cap,
@@ -112,7 +112,7 @@ run env _cfg = do
   Env.runApp env $
     katipAddContext (sl "agent-version" (A.String herculesAgentVersion)) $
       (configureLimits >>) $
-        (configChecks >>) $
+        (configChecks >> pruneContentAddressedSecretStates >>) $
           withAgentToken $
             withLifeCycle \hello -> withTaskState \tasks ->
               withAgentSocket hello tasks \socket ->

hercules-ci-agent/hercules-ci-agent/Hercules/Agent/Attic.hs

@@ -0,0 +1,129 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Hercules.Agent.Attic
+  ( push,
+    substituterURL,
+    toNetrcLines,
+  )
+where
+
+import Crypto.Hash
+import Data.Map (singleton)
+import Data.Map qualified as M
+import Data.Text.IO qualified as T
+import Hercules.Agent.Env (App)
+import Hercules.Agent.Log
+import Hercules.Agent.Token (withContentAddressedSecretState)
+import Hercules.CNix qualified as CNix
+import Hercules.CNix.Store (StorePath)
+import Hercules.Formats.AtticCache (AtticCache)
+import Hercules.Formats.AtticCache qualified as AtticCache
+import Network.URI (URIAuth (uriPort, uriRegName), parseURI, uriAuthority)
+import Protolude hiding (hash)
+import System.Directory (createDirectoryIfMissing)
+import System.Environment qualified
+import System.FilePath ((</>))
+import System.Process hiding (readCreateProcessWithExitCode)
+import System.Process.ByteString (readCreateProcessWithExitCode)
+import Toml (TomlCodec, (.=))
+import Toml qualified
+
+substituterURL :: AtticCache -> Text
+substituterURL c =
+  AtticCache.serverEndpoint c <> "/" <> AtticCache.cacheName c
+
+-- TODO: Should reject attic caches with the same endpoint, given that
+-- netrc is hostname-based, but attic caches are path-based.
+-- The token leak should not cause any problems here,
+-- but user might encounter authorization failure. Does netrc even works with the
+-- duplicate machine entry?
+toNetrcLines :: Map Text AtticCache -> [Text]
+toNetrcLines = mapMaybe toLine . M.elems
+  where
+    toLine cache = do
+      uri <- parseURI (toS (AtticCache.serverEndpoint cache))
+      auth <- uriAuthority uri
+      let host = toS (uriRegName auth <> uriPort auth) :: Text
+      pure $ "machine " <> host <> " password " <> AtticCache.token cache
+
+sha256 :: ByteString -> Digest SHA256
+sha256 = hash
+
+-- Attic only supports loading the token and cache location from config file,
+-- thus we need to create a synthetic one first.
+-- TODO: Maybe attic can be improved for that?
+push :: CNix.Store -> Text -> AtticCache -> [StorePath] -> App ()
+push store localName cache paths = do
+  pathStrings <-
+    liftIO $
+      mapM
+        ( \p -> do
+            bs <- CNix.storePathToPath store p
+            return (decodeUtf8With lenientDecode bs)
+        )
+        paths
+  logLocM DebugS (logStr ("Pushing to attic cache " <> localName))
+  let configText = renderConfig cache
+      configHash = sha256 $ encodeUtf8 configText
+  (exitCode, _out, err) <-
+    withContentAddressedSecretState
+      "attic-config"
+      configHash
+      ( \tmpCfgDir -> liftIO $ do
+          let atticDir = tmpCfgDir </> "attic"
+          let cfgFile = atticDir </> "config.toml"
+          createDirectoryIfMissing True atticDir
+          T.writeFile cfgFile configText
+      )
+      ( \cfgDir -> liftIO $ do
+          oldEnv <- System.Environment.getEnvironment
+          let isXdg k = k == "XDG_CONFIG_HOME" || k == "XDG_CACHE_HOME"
+          let newEnv =
+                [("XDG_CONFIG_HOME", cfgDir), ("XDG_CACHE_HOME", cfgDir)]
+                  ++ filter (\(k, _) -> not (isXdg k)) oldEnv
+          let args =
+                ["push", toS (AtticCache.cacheName cache)]
+                  ++ map toS pathStrings
+          let p = (proc "attic" args) {env = Just newEnv, close_fds = True}
+          readCreateProcessWithExitCode p ""
+      )
+  case exitCode of
+    ExitSuccess -> pure ()
+    ExitFailure c -> throwIO $ FatalError $ "Attic push failed with exit code " <> show c <> ", stderr: " <> (decodeUtf8With lenientDecode err)
+
+data AtticServer = AtticServer
+  { endpoint :: Text,
+    token :: Text
+  }
+
+data AtticClientConfig = AtticClientConfig
+  { defaultServer :: Text,
+    servers :: Map Text AtticServer
+  }
+
+atticServerCodec :: TomlCodec AtticServer
+atticServerCodec =
+  AtticServer
+    <$> Toml.text "endpoint"
+    .= endpoint
+    <*> Toml.text "token" .= token
+
+atticClientConfigCodec :: TomlCodec AtticClientConfig
+atticClientConfigCodec =
+  AtticClientConfig
+    <$> Toml.text "default-server"
+    .= defaultServer
+    <*> Toml.tableMap Toml._KeyText (Toml.table atticServerCodec) "servers" .= servers
+
+renderConfig :: AtticCache -> Text
+renderConfig c =
+  Toml.encode atticClientConfigCodec $
+    AtticClientConfig
+      { defaultServer = "hercules",
+        servers =
+          singleton "hercules" $
+            AtticServer
+              { endpoint = AtticCache.serverEndpoint c,
+                token = AtticCache.token c
+              }
+      }

hercules-ci-agent/hercules-ci-agent/Hercules/Agent/Cache.hs

@@ -5,6 +5,7 @@ module Hercules.Agent.Cache where
 import Data.Map qualified as M
 import Data.Text qualified as T
 import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
+import Hercules.Agent.Attic qualified as Attic
 import Hercules.Agent.Cachix qualified as Cachix
 import Hercules.Agent.Config.BinaryCaches qualified as Config
 import Hercules.Agent.Env (App)
@@ -17,6 +18,7 @@ import Hercules.CNix.Std.Set qualified as Std.Set
 import Hercules.CNix.Store (StorePath)
 import Hercules.CNix.Store qualified as Store
 import Hercules.Error (defaultRetry)
+import Hercules.Formats.AtticCache qualified as AtticCache
 import Hercules.Formats.NixCache qualified as NixCache
 import Katip
 import Protolude
@@ -27,10 +29,13 @@ withCaches m = do
   csubsts <- Cachix.getSubstituters
   cpubkeys <- Cachix.getTrustedPublicKeys
   nixCaches <- asks (Config.nixCaches . Env.binaryCaches)
-  let substs = nixCaches & toList <&> NixCache.storeURI
-      pubkeys = nixCaches & toList <&> NixCache.publicKeys & join
+  atticCaches <- asks (Config.atticCaches . Env.binaryCaches)
+  let substs = (nixCaches & toList <&> NixCache.storeURI) <> (atticCaches & toList <&> Attic.substituterURL)
+      pubkeys =
+        (nixCaches & toList <&> NixCache.publicKeys & join)
+          <> (atticCaches & toList <&> AtticCache.publicKeys & join)
   netrcFile <- Netrc.getNetrcFile
-  Netrc.appendLines netrcLns
+  Netrc.appendLines (netrcLns <> Attic.toNetrcLines atticCaches)
   Nix.withExtraOptions
     [ ("netrc-file", toS netrcFile),
       ("substituters", T.intercalate " " (substs <> csubsts)),
@@ -41,7 +46,10 @@ withCaches m = do
 getConfiguredSubstituters :: App [Text]
 getConfiguredSubstituters = do
   nixCaches <- asks (Config.nixCaches . Env.binaryCaches)
-  let substs = nixCaches & toList <&> NixCache.storeURI
+  atticCaches <- asks (Config.atticCaches . Env.binaryCaches)
+  let substs =
+        (nixCaches & toList <&> NixCache.storeURI)
+          <> (atticCaches & toList <&> Attic.substituterURL)
   csubsts <- Cachix.getSubstituters
   pure (substs <> csubsts)
 
@@ -63,9 +71,12 @@ push store cacheName paths concurrency = katipAddNamespace "Push" $ katipAddCont
       maybeCachix =
         Config.cachixCaches caches & M.lookup cacheName & fmap \_cache ->
           Cachix.push store cacheName paths concurrency
+      maybeAttic =
+        Config.atticCaches caches & M.lookup cacheName & fmap \cache ->
+          Attic.push store cacheName cache paths
       failNothing =
         throwIO $ FatalError $ "Agent does not have a binary cache named " <> show cacheName <> " in its configuration."
-  fromMaybe failNothing (maybeNix <|> maybeCachix)
+  fromMaybe failNothing (maybeNix <|> maybeCachix <|> maybeAttic)
 
 nixPush :: NixCache.NixCache -> [StorePath] -> Int -> App ()
 nixPush cacheConf paths _concurrency = do

hercules-ci-agent/hercules-ci-agent/Hercules/Agent/Config/BinaryCaches.hs

@@ -15,6 +15,7 @@ import Hercules.Agent.Bag
 import Hercules.Agent.Config
 import Hercules.Agent.Log
 import Hercules.Error
+import Hercules.Formats.AtticCache
 import Hercules.Formats.CachixCache
 import Hercules.Formats.NixCache
 import Protolude hiding (catchJust)
@@ -23,6 +24,7 @@ import System.IO.Error (isDoesNotExistError)
 data BinaryCaches = BinaryCaches
   { cachixCaches :: Map Text CachixCache,
     nixCaches :: Map Text NixCache,
+    atticCaches :: Map Text AtticCache,
     unknownKinds :: Map Text UnknownKind
   }
 
@@ -36,6 +38,7 @@ instance FromJSON BinaryCaches where
       ( BinaryCaches
           <$> part (\_name -> whenKind "CachixCache" $ \v -> Just $ parseJSON v)
           <*> part (\_name -> whenKind "NixCache" $ \v -> Just $ parseJSON v)
+          <*> part (\_name -> whenKind "AtticCache" $ \v -> Just $ parseJSON v)
           <*> part (\_name v -> Just $ parseJSON v)
       )
 
@@ -65,7 +68,7 @@ parseFile cfg = do
 
 validate :: FilePath -> BinaryCaches -> KatipContextT IO ()
 validate fname bcs = do
-  when (null (cachixCaches bcs) && null (nixCaches bcs)) $
+  when (null (cachixCaches bcs) && null (nixCaches bcs) && null (atticCaches bcs)) $
     logLocM
       WarningS
       "You did not configure any caches. This is ok for trying out Hercules CI,\

hercules-ci-agent/hercules-ci-agent/Hercules/Agent/Env.hs

@@ -69,6 +69,7 @@ activePushCaches = do
     M.keys
       ( void (Config.BinaryCaches.cachixCaches bc)
           <> void (Config.BinaryCaches.nixCaches bc)
+          <> void (Config.BinaryCaches.atticCaches bc)
       )
 
 type AgentSocket = Socket ServicePayload AgentPayload

hercules-ci-agent/hercules-ci-agent/Hercules/Agent/Token.hs

@@ -1,6 +1,7 @@
 module Hercules.Agent.Token where
 
 import Control.Lens ((^?))
+import Crypto.Hash
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Lens (key, _String)
 import Data.ByteString.Base64.Lazy qualified as B64L
@@ -18,6 +19,8 @@ import Protolude
 import Servant.Auth.Client (Token (Token))
 import System.Directory qualified
 import System.FilePath ((</>))
+import System.IO.Temp (withTempDirectory)
+import UnliftIO (withRunInIO)
 
 getDir :: App FilePath
 getDir = asks ((</> "secretState") . baseDirectory . config)
@@ -28,6 +31,36 @@ writeAgentSessionKey tok = do
   liftIO $ System.Directory.createDirectoryIfMissing True dir
   liftIO $ writeFile (dir </> "session.key") (toS tok)
 
+withContentAddressedSecretState ::
+  [Char] ->
+  Digest SHA256 ->
+  (FilePath -> App ()) ->
+  (FilePath -> App a) ->
+  App a
+withContentAddressedSecretState desc digest makeDir wither = do
+  parent <- getDir
+  liftIO $ System.Directory.createDirectoryIfMissing True parent
+  let name = show digest :: [Char]
+      caDir = parent </> ("ca-" <> desc <> "-" <> name)
+  liftIO (System.Directory.doesDirectoryExist caDir) >>= \case
+    True -> pure ()
+    False -> withRunInIO $ \run ->
+      withTempDirectory parent "ca-tmp" $ \tmpDir -> run $ do
+        makeDir tmpDir
+        liftIO $ System.Directory.renameDirectory tmpDir caDir
+  wither caDir
+
+pruneContentAddressedSecretStates :: App ()
+pruneContentAddressedSecretStates = do
+  parent <- getDir
+  liftIO (System.Directory.doesDirectoryExist parent) >>= \case
+    False -> pure ()
+    True -> do
+      entries <- liftIO $ System.Directory.listDirectory parent
+      for_ (filter ("ca-" `isPrefixOf`) entries) $ \entry -> do
+        let path = parent </> entry
+        liftIO $ System.Directory.removePathForcibly path
+
 -- | Reads a token file, strips whitespace
 readTokenFile :: (MonadIO m) => FilePath -> m Text
 readTokenFile fp = liftIO $ sanitize <$> readFile fp

hercules-ci-api-agent/hercules-ci-api-agent.cabal

@@ -66,6 +66,7 @@ library
     Hercules.API.Logs.LogMessage
     Hercules.API.Task
     Hercules.API.TaskStatus
+    Hercules.Formats.AtticCache
     Hercules.Formats.CachixCache
     Hercules.Formats.Common
     Hercules.Formats.Mountable

hercules-ci-api-agent/src/Hercules/Formats/AtticCache.hs

@@ -0,0 +1,54 @@
+module Hercules.Formats.AtticCache where
+
+import Data.Aeson
+import Data.Foldable
+import Data.Text (Text)
+import Hercules.Formats.Common
+  ( noVersion,
+    withKind,
+    withVersions,
+  )
+import Prelude
+
+data AtticCache = AtticCache
+  { serverEndpoint :: Text,
+    cacheName :: Text,
+    token :: Text,
+    publicKeys :: [Text]
+  }
+
+instance ToJSON AtticCache where
+  toJSON a =
+    object $
+      [ "kind" .= String "AtticCache",
+        "serverEndpoint" .= serverEndpoint a,
+        "cacheName" .= cacheName a,
+        "token" .= token a
+      ]
+        <> ["publicKeys" .= publicKeys a]
+
+  toEncoding a =
+    pairs
+      ( "kind"
+          .= String "AtticCache"
+          <> "serverEndpoint"
+            .= serverEndpoint a
+          <> "cacheName"
+            .= cacheName a
+          <> "token"
+            .= token a
+          <> "publicKeys"
+            .= publicKeys a
+      )
+
+instance FromJSON AtticCache where
+  parseJSON =
+    withKind "AtticCache" $
+      withVersions
+        [ noVersion $ \o ->
+            AtticCache
+              <$> o .: "serverEndpoint"
+              <*> o .: "cacheName"
+              <*> o .: "token"
+              <*> (fold <$> o .:? "publicKeys")
+        ]