Enable smart remote builds
This commit is contained in:
parent
535e7bbaff
commit
8ebea23db8
|
@ -20,7 +20,12 @@
|
||||||
|
|
||||||
services.sshd.enable = true;
|
services.sshd.enable = true;
|
||||||
|
|
||||||
|
environment.etc."nix/machines".source = toString (pkgs.runCommand "nix-machines" {} ''
|
||||||
|
cp $(${pkgs.builders-configurator}/bin/builders-configurator ${config.networking.hostName} --without-connection) $out
|
||||||
|
'');
|
||||||
|
|
||||||
nix = {
|
nix = {
|
||||||
|
distributedBuilds = true;
|
||||||
gc = {
|
gc = {
|
||||||
automatic = false;
|
automatic = false;
|
||||||
options = "-d";
|
options = "-d";
|
||||||
|
|
|
@ -23,15 +23,24 @@ executable builders-configurator
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
default-extensions:
|
default-extensions:
|
||||||
NoImplicitPrelude
|
NoImplicitPrelude
|
||||||
|
BlockArguments
|
||||||
|
DataKinds
|
||||||
|
ExtendedDefaultRules
|
||||||
|
LambdaCase
|
||||||
OverloadedRecordDot
|
OverloadedRecordDot
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
QuasiQuotes
|
QuasiQuotes
|
||||||
|
TemplateHaskell
|
||||||
|
TypeFamilies
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
, base ^>=4.16.3.0
|
, base ^>=4.16.3.0
|
||||||
, containers
|
, containers
|
||||||
|
, effectful
|
||||||
|
, effectful-th
|
||||||
, relude
|
, relude
|
||||||
, say
|
, say
|
||||||
|
, shh
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, witch
|
, witch
|
||||||
|
|
|
@ -1,14 +1,19 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import Control.Exception qualified as Exception
|
||||||
import Data.Foldable qualified as Foldable
|
import Data.Foldable qualified as Foldable
|
||||||
import Data.Map.Strict qualified as Map
|
import Data.Map.Strict qualified as Map
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.Text.IO qualified as TextIO
|
import Data.Text.IO qualified as TextIO
|
||||||
|
import Effectful (Eff, Effect, (:>))
|
||||||
|
import Effectful qualified as Eff
|
||||||
|
import Effectful.Dispatch.Dynamic qualified as Eff
|
||||||
|
import Effectful.TH (makeEffect)
|
||||||
import Relude
|
import Relude
|
||||||
import Say (say)
|
import Say (say)
|
||||||
|
import Shh ((&!>), (&>))
|
||||||
|
import Shh qualified
|
||||||
import System.IO qualified as IO
|
import System.IO qualified as IO
|
||||||
import Witch (into)
|
import Witch (into)
|
||||||
|
|
||||||
|
@ -19,6 +24,32 @@ supportedFeatures = ["benchmark", "big-parallel", "kvm", "nixos-test"]
|
||||||
|
|
||||||
data BuilderTries = FirstOf [Text] | FirstOfFinally [Text] Text | Use Text
|
data BuilderTries = FirstOf [Text] | FirstOfFinally [Text] Text | Use Text
|
||||||
|
|
||||||
|
data Ping :: Effect where
|
||||||
|
CheckConnectivity :: Text -> Ping m Bool
|
||||||
|
|
||||||
|
makeEffect ''Ping
|
||||||
|
|
||||||
|
runWithoutConnectivity :: Eff (Ping : es) a -> Eff es a
|
||||||
|
runWithoutConnectivity = Eff.interpret $ \_ -> \case
|
||||||
|
CheckConnectivity _ -> pure False
|
||||||
|
|
||||||
|
runWithPing :: Eff.IOE :> es => Eff (Ping : es) a -> Eff es a
|
||||||
|
runWithPing = Eff.interpret $ \_ -> \case
|
||||||
|
CheckConnectivity host_name -> do
|
||||||
|
liftIO $ ping `Exception.catch` \(_ :: Shh.Failure) -> pure False
|
||||||
|
where
|
||||||
|
ping = do
|
||||||
|
Shh.exe ["/run/wrappers/bin/ping", into @String (sshHostToDNS host_name), "-c1", "-w1"] &> Shh.devNull &!> Shh.devNull
|
||||||
|
pure True
|
||||||
|
|
||||||
|
sshHostToDNS :: Text -> Text
|
||||||
|
sshHostToDNS = \case
|
||||||
|
"zeus-builder" -> "zeus.vpn.m-0.eu"
|
||||||
|
"fluffy-builder" -> "fluffy.vpn.m-0.eu"
|
||||||
|
"zeus-builder-local" -> "zeus.lo.m-0.eu"
|
||||||
|
"fluffy-builder-local" -> "fluffy.lo.m-0.eu"
|
||||||
|
host -> error [i|No dns name none for ssh host #{host}|]
|
||||||
|
|
||||||
builderInfos :: Map.Map Text Natural
|
builderInfos :: Map.Map Text Natural
|
||||||
builderInfos =
|
builderInfos =
|
||||||
Map.fromList
|
Map.fromList
|
||||||
|
@ -44,15 +75,12 @@ commaList = Text.intercalate ","
|
||||||
builderLine :: (Text, Natural, Natural) -> Text
|
builderLine :: (Text, Natural, Natural) -> Text
|
||||||
builderLine (hostName, maxJobs, speed_factor) = [i|ssh://#{hostName} #{commaList systems} - #{maxJobs} #{speed_factor} #{commaList supportedFeatures} - -|]
|
builderLine (hostName, maxJobs, speed_factor) = [i|ssh://#{hostName} #{commaList systems} - #{maxJobs} #{speed_factor} #{commaList supportedFeatures} - -|]
|
||||||
|
|
||||||
testBuilders :: [BuilderTries] -> IO [Text]
|
testBuilders :: Ping :> es => [BuilderTries] -> Eff es [Text]
|
||||||
testBuilders =
|
testBuilders =
|
||||||
pure
|
fmap catMaybes . mapM \case
|
||||||
. mapMaybe
|
Use host -> pure $ Just host
|
||||||
( \case
|
FirstOf hosts -> listToMaybe <$> filterM checkConnectivity hosts
|
||||||
Use x -> Just x
|
FirstOfFinally hosts fallback -> listToMaybe . (++ [fallback]) <$> filterM checkConnectivity hosts
|
||||||
FirstOf x -> listToMaybe x
|
|
||||||
FirstOfFinally x y -> listToMaybe x <|> pure y
|
|
||||||
)
|
|
||||||
|
|
||||||
printBuilders :: [Text] -> Text
|
printBuilders :: [Text] -> Text
|
||||||
printBuilders = Text.unlines . fmap builderLine . Foldable.foldr' folder []
|
printBuilders = Text.unlines . fmap builderLine . Foldable.foldr' folder []
|
||||||
|
@ -65,8 +93,19 @@ printBuilders = Text.unlines . fmap builderLine . Foldable.foldr' folder []
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
(host : args) <- getArgs
|
host : args <- getArgs
|
||||||
builders <- testBuilders $ fromMaybe (error [i|#{host} not found in builderConfigs.|]) $ Map.lookup (into host) builderConfigs
|
let withoutConnection =
|
||||||
|
args & \case
|
||||||
|
[] -> False
|
||||||
|
["--without-connection"] -> True
|
||||||
|
_ -> error [i|Unknown arguments: #{args}|]
|
||||||
|
let
|
||||||
|
builder_tries :: Ping :> es => Eff es [Text]
|
||||||
|
builder_tries = testBuilders $ fromMaybe (error [i|#{host} not found in builderConfigs.|]) $ Map.lookup (into host) builderConfigs
|
||||||
|
builders <-
|
||||||
|
if withoutConnection
|
||||||
|
then pure $ Eff.runPureEff $ runWithoutConnectivity builder_tries
|
||||||
|
else Eff.runEff $ runWithPing builder_tries
|
||||||
(path, handle) <- IO.openTempFile "/tmp" "machines"
|
(path, handle) <- IO.openTempFile "/tmp" "machines"
|
||||||
TextIO.hPutStr handle (printBuilders builders)
|
TextIO.hPutStr handle (printBuilders builders)
|
||||||
IO.hClose handle
|
IO.hClose handle
|
||||||
|
|
Loading…
Reference in a new issue