diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 000000000..6d1b1649a --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "haskell/worker/impl"] + path = haskell/worker/impl + url = git@github.com:MercuryTechnologies/ghc-persistent-worker diff --git a/decls/haskell_rules.bzl b/decls/haskell_rules.bzl index 5a6a55e86..c3d9a75eb 100644 --- a/decls/haskell_rules.bzl +++ b/decls/haskell_rules.bzl @@ -14,7 +14,7 @@ load("@prelude//linking:types.bzl", "Linkage") load(":common.bzl", "LinkableDepType", "buck", "prelude_rule") load(":haskell_common.bzl", "haskell_common") load(":native_common.bzl", "native_common") -load("@prelude//haskell/worker/worker.bzl", "worker_libs") +load("@prelude//haskell/worker/worker.bzl", "worker_libs", "worker_srcs", "worker_flags") haskell_binary = prelude_rule( name = "haskell_binary", @@ -67,8 +67,9 @@ haskell_binary = prelude_rule( "linker_flags": attrs.list(attrs.arg(), default = []), "platform": attrs.option(attrs.string(), default = None), "platform_linker_flags": attrs.list(attrs.tuple(attrs.regex(), attrs.list(attrs.arg())), default = []), - "_worker_srcs": attrs.list(attrs.source(), default = ["@prelude//haskell/worker:Main.hs", "@prelude//haskell/worker:Worker.hs"]), - "_worker_deps": attrs.list(attrs.dep(), default = ["@prelude//haskell/worker:{}".format(pkg) for pkg in worker_libs]) + "_worker_srcs": attrs.list(attrs.source(), default = worker_srcs), + "_worker_deps": attrs.list(attrs.dep(), default = ["@prelude//haskell/worker:{}".format(pkg) for pkg in worker_libs]), + "_worker_compiler_flags": attrs.list(attrs.string(), default = worker_flags), } ), ) @@ -191,8 +192,9 @@ haskell_library = prelude_rule( "linker_flags": attrs.list(attrs.arg(), default = []), "platform": attrs.option(attrs.string(), default = None), "platform_linker_flags": attrs.list(attrs.tuple(attrs.regex(), attrs.list(attrs.arg())), default = []), - "_worker_srcs": attrs.list(attrs.source(), default = ["@prelude//haskell/worker:Main.hs", "@prelude//haskell/worker:Worker.hs"]), - "_worker_deps": attrs.list(attrs.dep(), default = ["@prelude//haskell/worker:{}".format(pkg) for pkg in worker_libs]) + "_worker_srcs": attrs.list(attrs.source(), default = worker_srcs), + "_worker_deps": attrs.list(attrs.dep(), default = ["@prelude//haskell/worker:{}".format(pkg) for pkg in worker_libs]), + "_worker_compiler_flags": attrs.list(attrs.string(), default = worker_flags), } ), ) diff --git a/haskell/compile.bzl b/haskell/compile.bzl index c45735ab7..66b2bd76d 100644 --- a/haskell/compile.bzl +++ b/haskell/compile.bzl @@ -441,6 +441,7 @@ def _common_compile_module_args( ) -> CommonCompileModuleArgs: command = cmd_args(ghc_wrapper) command.add("--ghc", haskell_toolchain.compiler) + command.add("--ghc-dir", haskell_toolchain.ghc_dir) # Some rules pass in RTS (e.g. `+RTS ... -RTS`) options for GHC, which can't # be parsed when inside an argsfile. @@ -700,6 +701,7 @@ def _compile_module( compile_cmd.add("-fwrite-if-simplified-core") if enable_th: compile_cmd.add("-fprefer-byte-code") + compile_cmd.add("-fpackage-db-byte-code") compile_cmd.add(cmd_args(dependency_modules.reduce("packagedb_deps").keys(), prepend = "--buck2-package-db")) diff --git a/haskell/haskell.bzl b/haskell/haskell.bzl index 824d0a178..47c937b13 100644 --- a/haskell/haskell.bzl +++ b/haskell/haskell.bzl @@ -1491,7 +1491,7 @@ worker = anon_rule( "enable_profiling": attrs.default_only(attrs.bool(default = False)), "external_tools": attrs.list(attrs.dep(), default = []), "link_group_map": LINK_GROUP_MAP_ATTR, - "linker_flags": attrs.list(attrs.string(), default = ["-threaded", "-rtsopts", "-with-rtsopts=-N", "-O2",]), + "linker_flags": attrs.list(attrs.string(), default = []), "platform_deps": attrs.list(attrs.dep(), default = []), "srcs": attrs.list(attrs.source()), "srcs_deps": attrs.dict(attrs.string(), attrs.dep(), default = {}), @@ -1521,9 +1521,19 @@ def _persistent_worker(ctx: AnalysisContext) -> WorkerInfo | None: "_ghc_wrapper": ctx.attrs._ghc_wrapper, "_haskell_toolchain": ctx.attrs._haskell_toolchain, "deps": ctx.attrs._worker_deps, - "link_style": "static", + "link_style": "shared", "name": "prelude//haskell:worker", "srcs": ctx.attrs._worker_srcs, + "compiler_flags": ctx.attrs._worker_compiler_flags + [ + "-O2", + ], + "linker_flags": ctx.attrs._worker_compiler_flags + [ + "-dynamic", + "-rtsopts=all", + "-with-rtsopts=-K512M -H -I5 -T", + "-threaded", + "-O2", + ], }, ) return WorkerInfo(worker_target.artifact("worker")) diff --git a/haskell/toolchain.bzl b/haskell/toolchain.bzl index 4a46d55fd..d4a3eae5b 100644 --- a/haskell/toolchain.bzl +++ b/haskell/toolchain.bzl @@ -41,6 +41,7 @@ HaskellToolchainInfo = provider( "script_template_processor": provider_field(typing.Any, default = None), "packages": provider_field(typing.Any, default = None), "use_worker": provider_field(bool, default = False), + "ghc_dir": provider_field(typing.Any, default = None), }, ) diff --git a/haskell/tools/ghc_wrapper.py b/haskell/tools/ghc_wrapper.py index 0a1c20f2d..6a255a6a7 100755 --- a/haskell/tools/ghc_wrapper.py +++ b/haskell/tools/ghc_wrapper.py @@ -39,6 +39,9 @@ def main(): parser.add_argument( "--ghc", required=True, type=str, help="Path to the Haskell compiler GHC." ) + parser.add_argument( + "--ghc-dir", type=str, help="Worker option" + ) parser.add_argument( "--abi-out", required=True, diff --git a/haskell/worker/BUCK b/haskell/worker/BUCK index 46ecbc10a..232b24429 100644 --- a/haskell/worker/BUCK +++ b/haskell/worker/BUCK @@ -1,6 +1,3 @@ load(":worker.bzl", "worker_libs") -export_file("Main.hs", visibility = ["PUBLIC"]) -export_file("Worker.hs", visibility = ["PUBLIC"]) - [haskell_toolchain_library(name = pkg, visibility = ["PUBLIC"]) for pkg in worker_libs] diff --git a/haskell/worker/Main.hs b/haskell/worker/Main.hs deleted file mode 100644 index 4e7b24415..000000000 --- a/haskell/worker/Main.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# options_ghc -Wall -Werror -Wno-error=unused-local-binds -Wno-error=unused-matches -Wno-error=unused-imports -fno-show-error-context #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GHC2021 #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE PatternSynonyms #-} - -module Main where - -import Control.Exception (AsyncException (..), Exception (..), IOException, throwIO) -import qualified Control.Monad.Catch as MC -import Control.Monad.IO.Class (liftIO) -import Data.ByteString (ByteString) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Int (Int32) -import Data.List (isPrefixOf, partition) -import Data.String (fromString) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8Lenient) -import Data.Foldable (for_) -import qualified Data.Vector as V -import qualified GHC -import GHC (DynFlags, Ghc, GhcException (..), Phase, parseTargetFiles) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Env (HscEnv (..)) -import GHC.Driver.Errors (printOrThrowDiagnostics) -import GHC.Driver.Errors.Types (DriverMessages, GhcMessage (GhcDriverMessage)) -import GHC.Driver.Main (initHscEnv) -import GHC.Driver.Monad (Session (..)) -import GHC.Driver.Phases (StopPhase (NoStop)) -import GHC.Driver.Pipeline (oneShot) -import GHC.Driver.Session ( - FlushOut (..), - defaultFatalMessager, - defaultFlushOut, - initialUnique, - targetProfile, - uniqueIncrement, - ) -import GHC.Iface.Binary (CheckHiWay (IgnoreHiWay), TraceBinIFace (QuietBinIFace), readBinIface) -import GHC.Runtime.Loader (initializeSessionPlugins) -import GHC.Types.SourceError (SourceError) -import GHC.Types.SrcLoc (Located, mkGeneralLocated, unLoc) -import GHC.Types.Unique.Supply (initUniqSupply) -import GHC.Unit.Module.ModIface (mi_final_exts, mi_mod_hash) -import GHC.Utils.Logger (Logger, getLogger, log_default_dump_context, setLogFlags) -import GHC.Utils.Outputable (ppr, renderWithContext) -import Network.GRPC.HighLevel.Generated -import System.Environment (getProgName, lookupEnv) -import System.Exit (ExitCode) -import System.FilePath (dropExtension, takeDirectory) -import System.IO (BufferMode (LineBuffering), hPutStrLn, hSetBuffering, stderr, stdout) -import Worker - -options :: ServiceOptions -options = defaultServiceOptions - -handlers :: IORef (Maybe Session) -> Worker ServerRequest ServerResponse -handlers session = - Worker - { workerExecute = executeHandler session, - workerExec = execHandler - } - -data Args = - Args { - abiOut :: Maybe String, - binPaths :: [String], - buck2Dep :: Maybe String, - buck2PackageDb :: [String], - buck2PackageDbDep :: Maybe String, - ghcDir :: Maybe String, - ghcOptions :: [String] - } - deriving stock (Eq, Show) - -emptyArgs :: Args -emptyArgs = - Args { - abiOut = Nothing, - binPaths = [], - buck2Dep = Nothing, - buck2PackageDb = [], - buck2PackageDbDep = Nothing, - ghcDir = Nothing, - ghcOptions = [] - } - -parseBuckArgs :: V.Vector ByteString -> Either String Args -parseBuckArgs = - spin emptyArgs . - fmap (T.unpack . decodeUtf8Lenient) . - V.toList - where - spin Args {..} = \case - "--abi-out" : rest -> takeArg "--abi-out" rest \ v -> Args {abiOut = Just v, ..} - "--buck2-dep" : rest -> takeArg "--buck2-dep" rest \ v -> Args {buck2Dep = Just v, ..} - "--buck2-packagedb" : rest -> takeArg "--buck2-packagedb" rest \ v -> Args {buck2PackageDb = v : buck2PackageDb, ..} - "--buck2-packagedb-dep" : rest -> takeArg "--buck2-packagedb-dep" rest \ v -> Args {buck2PackageDbDep = Just v, ..} - "--ghc" : rest -> takeArg "--ghc" rest \ ghc -> Args {ghcOptions = [], ghcDir = Just (takeDirectory (takeDirectory ghc)), ..} - "--bin-path" : rest -> takeArg "--bin-path" rest \ path -> Args {binPaths = path : binPaths, ..} - "-c" : rest -> spin Args {ghcOptions = "-no-link" : ghcOptions, ..} rest - arg : rest -> spin Args {ghcOptions = arg : ghcOptions, ..} rest - [] -> Right Args {ghcOptions = reverse ghcOptions, ..} - - takeArg name argv store = case argv of - [] -> Left (name ++ " needs an argument") - arg : rest -> spin (store arg) rest - -handleExceptions :: ∀ a . a -> Ghc a -> Ghc a -handleExceptions errResult = - MC.handle \ e -> do - liftIO flushOut - handler e - pure errResult - where - handler exception - | Just (se :: SourceError) <- fromException exception - = GHC.printException se - - | Just (ioe :: IOException) <- fromException exception - = fm (show ioe) - - | Just UserInterrupt <- fromException exception - = liftIO $ throwIO UserInterrupt - - | Just StackOverflow <- fromException exception - = fm "stack overflow: use +RTS -K to increase it" - - | Just (ex :: ExitCode) <- fromException exception - = liftIO $ throwIO ex - - | Just ge <- fromException exception - = case ge of - Signal _ -> pure () - ProgramError _ -> fm (show ge) - CmdLineError _ -> fm (": " ++ show ge) - _ -> do - progName <- liftIO getProgName - fm (progName ++ ": " ++ show ge) - - | otherwise - = fm (show (Panic (show exception))) - - fm = liftIO . defaultFatalMessager - FlushOut flushOut = defaultFlushOut - -data CompileResult = - CompileResult { - abiHash :: Maybe (String, String) - } - deriving stock (Eq, Show) - -runSession :: Args -> ([Located String] -> Ghc (Maybe a)) -> IO (Maybe a) -runSession args prog = - GHC.runGhc mbMinusB (handleExceptions Nothing (prog argv2)) - where - argv0 = foldMap (\ d -> ["-B" ++ d ++ "/lib/ghc-9.8.2/lib"]) args.ghcDir ++ args.ghcOptions - (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 - mbMinusB | null minusB_args = Nothing - | otherwise = Just (drop 2 (last minusB_args)) - argv2 = map (mkGeneralLocated "on the commandline") argv1 - -parseFlags :: [Located String] -> Ghc (DynFlags, Logger, [Located String], DriverMessages) -parseFlags argv = do - dflags0 <- GHC.getSessionDynFlags - logger1 <- getLogger - let logger2 = setLogFlags logger1 (initLogFlags dflags0) - (dflags, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags logger2 dflags0 argv - pure (dflags, setLogFlags logger2 (initLogFlags dflags), fileish_args, dynamicFlagWarnings) - -withGhc :: Args -> ([(String, Maybe Phase)] -> Ghc (Maybe a)) -> IO (Maybe a) -withGhc args prog = - runSession args \ argv -> do - (dflags0, logger, fileish_args, dynamicFlagWarnings) <- parseFlags argv - GHC.prettyPrintGhcErrors logger do - let flagWarnings' = GhcDriverMessage <$> dynamicFlagWarnings - liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags0) (initDiagOpts dflags0) flagWarnings' - let (dflags1, srcs, _objs) = parseTargetFiles dflags0 (map unLoc fileish_args) - GHC.setSessionDynFlags dflags1 - dflags <- GHC.getSessionDynFlags - liftIO $ initUniqSupply (initialUnique dflags) (uniqueIncrement dflags) - initializeSessionPlugins - prog srcs - -compile :: Args -> [(String, Maybe Phase)] -> Ghc (Maybe CompileResult) -compile args srcs = do - hsc_env <- GHC.getSession - liftIO (oneShot hsc_env NoStop srcs) - abiHash <- readAbiHash hsc_env args.abiOut - pure (Just CompileResult {abiHash}) - where - readAbiHash HscEnv {hsc_dflags, hsc_NC} (Just out) = do - let hi_file = dropExtension out - iface <- liftIO $ readBinIface (targetProfile hsc_dflags) hsc_NC IgnoreHiWay QuietBinIFace hi_file - pure (Just (out, dump hsc_dflags (mi_mod_hash (mi_final_exts iface)))) - - readAbiHash _ _ = pure Nothing - - dump dflags = renderWithContext (log_default_dump_context (initLogFlags dflags)) . ppr - -writeResult :: Args -> Maybe CompileResult -> IO Int32 -writeResult args = \case - Nothing -> pure 1 - Just CompileResult {abiHash} -> do - for_ abiHash \ (path, hash) -> writeFile path hash - for_ args.buck2Dep \ path -> writeFile path "\n" - for_ args.buck2PackageDbDep \ path -> - case args.buck2PackageDb of - [] -> writeFile path "\n" - dbs -> writeFile path (unlines dbs) - pure 0 - -executeHandler :: - IORef (Maybe Session) -> - ServerRequest Normal ExecuteCommand ExecuteResponse -> - IO (ServerResponse Normal ExecuteResponse) -executeHandler state (ServerNormalRequest _metadata (ExecuteCommand {executeCommandArgv, executeCommandEnv})) = do - hPutStrLn stderr (show executeCommandArgv) - print executeCommandArgv - print executeCommandEnv - -- session <- ensureSession - args <- either (throwIO . userError) pure (parseBuckArgs executeCommandArgv) - result <- withGhc args (compile args) - hPutStrLn stderr ("compiled: " ++ show result) - exitCode <- writeResult args result - pure (ServerNormalResponse (ExecuteResponse exitCode "") [] StatusOk "") - where - _ensureSession = - readIORef state >>= \case - Just s -> pure s - Nothing -> do - env0 <- initHscEnv Nothing - session <- Session <$> newIORef env0 - writeIORef state (Just session) - pure session - -execHandler :: - ServerRequest ClientStreaming ExecuteEvent ExecuteResponse -> - IO (ServerResponse ClientStreaming ExecuteResponse) -execHandler (ServerReaderRequest _metadata _recv) = do - hPutStrLn stderr "Received Exec" - error "not implemented" - -main :: IO () -main = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - socket <- lookupEnv "WORKER_SOCKET" - hPutStrLn stderr $ "using worker socket: " <> show socket - state <- newIORef Nothing - let activeOptions = - maybe - options - ( \s -> - options {serverHost = fromString $ "unix://" <> s <> "\x00", serverPort = 0} - ) - socket - workerServer (handlers state) activeOptions diff --git a/haskell/worker/Worker.hs b/haskell/worker/Worker.hs deleted file mode 100644 index bd4c8185f..000000000 --- a/haskell/worker/Worker.hs +++ /dev/null @@ -1,614 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} - --- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! -module Worker where -import qualified Prelude as Hs -import qualified Proto3.Suite.Class as HsProtobuf -import qualified Proto3.Suite.DotProto as HsProtobufAST -import qualified Proto3.Suite.JSONPB as HsJSONPB -import Proto3.Suite.JSONPB ((.=), (.:)) -import qualified Proto3.Suite.Types as HsProtobuf -import qualified Proto3.Wire as HsProtobuf -import qualified Proto3.Wire.Decode as HsProtobuf - (Parser, RawField) -import qualified Control.Applicative as Hs -import Control.Applicative ((<*>), (<|>), (<$>)) -import qualified Control.DeepSeq as Hs -import qualified Control.Monad as Hs -import qualified Data.ByteString as Hs -import qualified Data.Coerce as Hs -import qualified Data.Int as Hs (Int16, Int32, Int64) -import qualified Data.List.NonEmpty as Hs (NonEmpty(..)) -import qualified Data.Map as Hs (Map, mapKeysMonotonic) -import qualified Data.Proxy as Proxy -import qualified Data.String as Hs (fromString) -import qualified Data.Text.Lazy as Hs (Text) -import qualified Data.Vector as Hs (Vector) -import qualified Data.Word as Hs (Word16, Word32, Word64) -import qualified GHC.Enum as Hs -import qualified GHC.Generics as Hs -import qualified Google.Protobuf.Wrappers.Polymorphic as HsProtobuf - (Wrapped(..)) -import qualified Unsafe.Coerce as Hs -import Network.GRPC.HighLevel.Generated as HsGRPC -import Network.GRPC.HighLevel.Client as HsGRPC -import Network.GRPC.HighLevel.Server as HsGRPC hiding (serverLoop) -import Network.GRPC.HighLevel.Server.Unregistered as HsGRPC - (serverLoop) - -data ExecuteCommand = ExecuteCommand{executeCommandArgv :: - Hs.Vector Hs.ByteString, - executeCommandEnv :: - Hs.Vector Worker.ExecuteCommand_EnvironmentEntry} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - -instance Hs.NFData ExecuteCommand - -instance HsProtobuf.Named ExecuteCommand where - nameOf _ = (Hs.fromString "ExecuteCommand") - -instance HsProtobuf.HasDefault ExecuteCommand - -instance HsProtobuf.Message ExecuteCommand where - encodeMessage _ - ExecuteCommand{executeCommandArgv = executeCommandArgv, - executeCommandEnv = executeCommandEnv} - = (Hs.mconcat - [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (Hs.coerce @(Hs.Vector Hs.ByteString) - @(HsProtobuf.UnpackedVec (HsProtobuf.Bytes Hs.ByteString)) - (executeCommandArgv))), - (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (Hs.coerce @(Hs.Vector Worker.ExecuteCommand_EnvironmentEntry) - @(HsProtobuf.NestedVec Worker.ExecuteCommand_EnvironmentEntry) - (executeCommandEnv)))]) - decodeMessage _ - = (Hs.pure ExecuteCommand) <*> - (HsProtobuf.coerceOver - @(HsProtobuf.UnpackedVec (HsProtobuf.Bytes Hs.ByteString)) - @(Hs.Vector Hs.ByteString) - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 1))) - <*> - (HsProtobuf.coerceOver - @(HsProtobuf.NestedVec Worker.ExecuteCommand_EnvironmentEntry) - @(Hs.Vector Worker.ExecuteCommand_EnvironmentEntry) - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 2))) - dotProto _ - = [(HsProtobufAST.DotProtoField (HsProtobuf.FieldNumber 1) - (HsProtobufAST.Repeated HsProtobufAST.Bytes) - (HsProtobufAST.Single "argv") - [] - ""), - (HsProtobufAST.DotProtoField (HsProtobuf.FieldNumber 2) - (HsProtobufAST.Repeated - (HsProtobufAST.Named (HsProtobufAST.Single "EnvironmentEntry"))) - (HsProtobufAST.Single "env") - [] - "")] - -instance HsJSONPB.ToJSONPB ExecuteCommand where - toJSONPB (ExecuteCommand f1 f2) - = (HsJSONPB.object - ["argv" .= - (Hs.coerce @(Hs.Vector Hs.ByteString) - @(HsProtobuf.UnpackedVec (HsProtobuf.Bytes Hs.ByteString)) - (f1)), - "env" .= - (Hs.coerce @(Hs.Vector Worker.ExecuteCommand_EnvironmentEntry) - @(HsProtobuf.NestedVec Worker.ExecuteCommand_EnvironmentEntry) - (f2))]) - toEncodingPB (ExecuteCommand f1 f2) - = (HsJSONPB.pairs - ["argv" .= - (Hs.coerce @(Hs.Vector Hs.ByteString) - @(HsProtobuf.UnpackedVec (HsProtobuf.Bytes Hs.ByteString)) - (f1)), - "env" .= - (Hs.coerce @(Hs.Vector Worker.ExecuteCommand_EnvironmentEntry) - @(HsProtobuf.NestedVec Worker.ExecuteCommand_EnvironmentEntry) - (f2))]) - -instance HsJSONPB.FromJSONPB ExecuteCommand where - parseJSONPB - = (HsJSONPB.withObject "ExecuteCommand" - (\ obj -> - (Hs.pure ExecuteCommand) <*> - (HsProtobuf.coerceOver - @(HsProtobuf.UnpackedVec (HsProtobuf.Bytes Hs.ByteString)) - @(Hs.Vector Hs.ByteString) - (obj .: "argv")) - <*> - (HsProtobuf.coerceOver - @(HsProtobuf.NestedVec Worker.ExecuteCommand_EnvironmentEntry) - @(Hs.Vector Worker.ExecuteCommand_EnvironmentEntry) - (obj .: "env")))) - -instance HsJSONPB.ToJSON ExecuteCommand where - toJSON = HsJSONPB.toAesonValue - toEncoding = HsJSONPB.toAesonEncoding - -instance HsJSONPB.FromJSON ExecuteCommand where - parseJSON = HsJSONPB.parseJSONPB - -instance HsJSONPB.ToSchema ExecuteCommand where - declareNamedSchema _ - = do let declare_argv = HsJSONPB.declareSchemaRef - executeCommandArgv <- declare_argv Proxy.Proxy - let declare_env = HsJSONPB.declareSchemaRef - executeCommandEnv <- declare_env Proxy.Proxy - let _ = Hs.pure ExecuteCommand <*> - (HsProtobuf.coerceOver - @(HsProtobuf.UnpackedVec (HsProtobuf.Bytes Hs.ByteString)) - @(Hs.Vector Hs.ByteString) - (HsJSONPB.asProxy declare_argv)) - <*> - (HsProtobuf.coerceOver - @(HsProtobuf.NestedVec Worker.ExecuteCommand_EnvironmentEntry) - @(Hs.Vector Worker.ExecuteCommand_EnvironmentEntry) - (HsJSONPB.asProxy declare_env)) - Hs.return - (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = - Hs.Just "ExecuteCommand", - HsJSONPB._namedSchemaSchema = - Hs.mempty{HsJSONPB._schemaParamSchema = - Hs.mempty{HsJSONPB._paramSchemaType = - Hs.Just HsJSONPB.SwaggerObject}, - HsJSONPB._schemaProperties = - HsJSONPB.insOrdFromList - [("argv", executeCommandArgv), - ("env", executeCommandEnv)]}}) - -data ExecuteCommand_EnvironmentEntry = ExecuteCommand_EnvironmentEntry{executeCommand_EnvironmentEntryKey - :: Hs.ByteString, - executeCommand_EnvironmentEntryValue - :: Hs.ByteString} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - -instance Hs.NFData ExecuteCommand_EnvironmentEntry - -instance HsProtobuf.Named ExecuteCommand_EnvironmentEntry where - nameOf _ = (Hs.fromString "ExecuteCommand_EnvironmentEntry") - -instance HsProtobuf.HasDefault ExecuteCommand_EnvironmentEntry - -instance HsProtobuf.Message ExecuteCommand_EnvironmentEntry where - encodeMessage _ - ExecuteCommand_EnvironmentEntry{executeCommand_EnvironmentEntryKey - = executeCommand_EnvironmentEntryKey, - executeCommand_EnvironmentEntryValue = - executeCommand_EnvironmentEntryValue} - = (Hs.mconcat - [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (Hs.coerce @(Hs.ByteString) @(HsProtobuf.Bytes Hs.ByteString) - (executeCommand_EnvironmentEntryKey))), - (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (Hs.coerce @(Hs.ByteString) @(HsProtobuf.Bytes Hs.ByteString) - (executeCommand_EnvironmentEntryValue)))]) - decodeMessage _ - = (Hs.pure ExecuteCommand_EnvironmentEntry) <*> - (HsProtobuf.coerceOver @(HsProtobuf.Bytes Hs.ByteString) - @(Hs.ByteString) - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 1))) - <*> - (HsProtobuf.coerceOver @(HsProtobuf.Bytes Hs.ByteString) - @(Hs.ByteString) - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 2))) - dotProto _ - = [(HsProtobufAST.DotProtoField (HsProtobuf.FieldNumber 1) - (HsProtobufAST.Prim HsProtobufAST.Bytes) - (HsProtobufAST.Single "key") - [] - ""), - (HsProtobufAST.DotProtoField (HsProtobuf.FieldNumber 2) - (HsProtobufAST.Prim HsProtobufAST.Bytes) - (HsProtobufAST.Single "value") - [] - "")] - -instance HsJSONPB.ToJSONPB ExecuteCommand_EnvironmentEntry where - toJSONPB (ExecuteCommand_EnvironmentEntry f1 f2) - = (HsJSONPB.object - ["key" .= - (Hs.coerce @(Hs.ByteString) @(HsProtobuf.Bytes Hs.ByteString) - (f1)), - "value" .= - (Hs.coerce @(Hs.ByteString) @(HsProtobuf.Bytes Hs.ByteString) - (f2))]) - toEncodingPB (ExecuteCommand_EnvironmentEntry f1 f2) - = (HsJSONPB.pairs - ["key" .= - (Hs.coerce @(Hs.ByteString) @(HsProtobuf.Bytes Hs.ByteString) - (f1)), - "value" .= - (Hs.coerce @(Hs.ByteString) @(HsProtobuf.Bytes Hs.ByteString) - (f2))]) - -instance HsJSONPB.FromJSONPB ExecuteCommand_EnvironmentEntry where - parseJSONPB - = (HsJSONPB.withObject "ExecuteCommand_EnvironmentEntry" - (\ obj -> - (Hs.pure ExecuteCommand_EnvironmentEntry) <*> - (HsProtobuf.coerceOver @(HsProtobuf.Bytes Hs.ByteString) - @(Hs.ByteString) - (obj .: "key")) - <*> - (HsProtobuf.coerceOver @(HsProtobuf.Bytes Hs.ByteString) - @(Hs.ByteString) - (obj .: "value")))) - -instance HsJSONPB.ToJSON ExecuteCommand_EnvironmentEntry where - toJSON = HsJSONPB.toAesonValue - toEncoding = HsJSONPB.toAesonEncoding - -instance HsJSONPB.FromJSON ExecuteCommand_EnvironmentEntry where - parseJSON = HsJSONPB.parseJSONPB - -instance HsJSONPB.ToSchema ExecuteCommand_EnvironmentEntry where - declareNamedSchema _ - = do let declare_key = HsJSONPB.declareSchemaRef - executeCommand_EnvironmentEntryKey <- declare_key Proxy.Proxy - let declare_value = HsJSONPB.declareSchemaRef - executeCommand_EnvironmentEntryValue <- declare_value Proxy.Proxy - let _ = Hs.pure ExecuteCommand_EnvironmentEntry <*> - (HsProtobuf.coerceOver @(HsProtobuf.Bytes Hs.ByteString) - @(Hs.ByteString) - (HsJSONPB.asProxy declare_key)) - <*> - (HsProtobuf.coerceOver @(HsProtobuf.Bytes Hs.ByteString) - @(Hs.ByteString) - (HsJSONPB.asProxy declare_value)) - Hs.return - (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = - Hs.Just "ExecuteCommand_EnvironmentEntry", - HsJSONPB._namedSchemaSchema = - Hs.mempty{HsJSONPB._schemaParamSchema = - Hs.mempty{HsJSONPB._paramSchemaType = - Hs.Just HsJSONPB.SwaggerObject}, - HsJSONPB._schemaProperties = - HsJSONPB.insOrdFromList - [("key", executeCommand_EnvironmentEntryKey), - ("value", - executeCommand_EnvironmentEntryValue)]}}) - -data ExecuteResponse = ExecuteResponse{executeResponseExitCode :: - Hs.Int32, - executeResponseStderr :: Hs.Text} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - -instance Hs.NFData ExecuteResponse - -instance HsProtobuf.Named ExecuteResponse where - nameOf _ = (Hs.fromString "ExecuteResponse") - -instance HsProtobuf.HasDefault ExecuteResponse - -instance HsProtobuf.Message ExecuteResponse where - encodeMessage _ - ExecuteResponse{executeResponseExitCode = executeResponseExitCode, - executeResponseStderr = executeResponseStderr} - = (Hs.mconcat - [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - executeResponseExitCode), - (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (Hs.coerce @(Hs.Text) @(HsProtobuf.String Hs.Text) - (executeResponseStderr)))]) - decodeMessage _ - = (Hs.pure ExecuteResponse) <*> - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 1)) - <*> - (HsProtobuf.coerceOver @(HsProtobuf.String Hs.Text) @(Hs.Text) - (HsProtobuf.at HsProtobuf.decodeMessageField - (HsProtobuf.FieldNumber 2))) - dotProto _ - = [(HsProtobufAST.DotProtoField (HsProtobuf.FieldNumber 1) - (HsProtobufAST.Prim HsProtobufAST.Int32) - (HsProtobufAST.Single "exit_code") - [] - ""), - (HsProtobufAST.DotProtoField (HsProtobuf.FieldNumber 2) - (HsProtobufAST.Prim HsProtobufAST.String) - (HsProtobufAST.Single "stderr") - [] - "")] - -instance HsJSONPB.ToJSONPB ExecuteResponse where - toJSONPB (ExecuteResponse f1 f2) - = (HsJSONPB.object - ["exit_code" .= f1, - "stderr" .= - (Hs.coerce @(Hs.Text) @(HsProtobuf.String Hs.Text) (f2))]) - toEncodingPB (ExecuteResponse f1 f2) - = (HsJSONPB.pairs - ["exit_code" .= f1, - "stderr" .= - (Hs.coerce @(Hs.Text) @(HsProtobuf.String Hs.Text) (f2))]) - -instance HsJSONPB.FromJSONPB ExecuteResponse where - parseJSONPB - = (HsJSONPB.withObject "ExecuteResponse" - (\ obj -> - (Hs.pure ExecuteResponse) <*> obj .: "exit_code" <*> - (HsProtobuf.coerceOver @(HsProtobuf.String Hs.Text) @(Hs.Text) - (obj .: "stderr")))) - -instance HsJSONPB.ToJSON ExecuteResponse where - toJSON = HsJSONPB.toAesonValue - toEncoding = HsJSONPB.toAesonEncoding - -instance HsJSONPB.FromJSON ExecuteResponse where - parseJSON = HsJSONPB.parseJSONPB - -instance HsJSONPB.ToSchema ExecuteResponse where - declareNamedSchema _ - = do let declare_exit_code = HsJSONPB.declareSchemaRef - executeResponseExitCode <- declare_exit_code Proxy.Proxy - let declare_stderr = HsJSONPB.declareSchemaRef - executeResponseStderr <- declare_stderr Proxy.Proxy - let _ = Hs.pure ExecuteResponse <*> - HsJSONPB.asProxy declare_exit_code - <*> - (HsProtobuf.coerceOver @(HsProtobuf.String Hs.Text) @(Hs.Text) - (HsJSONPB.asProxy declare_stderr)) - Hs.return - (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = - Hs.Just "ExecuteResponse", - HsJSONPB._namedSchemaSchema = - Hs.mempty{HsJSONPB._schemaParamSchema = - Hs.mempty{HsJSONPB._paramSchemaType = - Hs.Just HsJSONPB.SwaggerObject}, - HsJSONPB._schemaProperties = - HsJSONPB.insOrdFromList - [("exit_code", executeResponseExitCode), - ("stderr", executeResponseStderr)]}}) - -data ExecuteCancel = ExecuteCancel{} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - -instance Hs.NFData ExecuteCancel - -instance HsProtobuf.Named ExecuteCancel where - nameOf _ = (Hs.fromString "ExecuteCancel") - -instance HsProtobuf.HasDefault ExecuteCancel - -instance HsProtobuf.Message ExecuteCancel where - encodeMessage _ ExecuteCancel{} = (Hs.mconcat []) - decodeMessage _ = (Hs.pure ExecuteCancel) - dotProto _ = [] - -instance HsJSONPB.ToJSONPB ExecuteCancel where - toJSONPB (ExecuteCancel) = (HsJSONPB.object []) - toEncodingPB (ExecuteCancel) = (HsJSONPB.pairs []) - -instance HsJSONPB.FromJSONPB ExecuteCancel where - parseJSONPB - = (HsJSONPB.withObject "ExecuteCancel" - (\ obj -> (Hs.pure ExecuteCancel))) - -instance HsJSONPB.ToJSON ExecuteCancel where - toJSON = HsJSONPB.toAesonValue - toEncoding = HsJSONPB.toAesonEncoding - -instance HsJSONPB.FromJSON ExecuteCancel where - parseJSON = HsJSONPB.parseJSONPB - -instance HsJSONPB.ToSchema ExecuteCancel where - declareNamedSchema _ - = do Hs.return - (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = - Hs.Just "ExecuteCancel", - HsJSONPB._namedSchemaSchema = - Hs.mempty{HsJSONPB._schemaParamSchema = - Hs.mempty{HsJSONPB._paramSchemaType = - Hs.Just HsJSONPB.SwaggerObject}, - HsJSONPB._schemaProperties = - HsJSONPB.insOrdFromList []}}) - -newtype ExecuteEvent = ExecuteEvent{executeEventData :: - Hs.Maybe ExecuteEventData} - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - -instance Hs.NFData ExecuteEvent - -instance HsProtobuf.Named ExecuteEvent where - nameOf _ = (Hs.fromString "ExecuteEvent") - -instance HsProtobuf.HasDefault ExecuteEvent - -instance HsProtobuf.Message ExecuteEvent where - encodeMessage _ ExecuteEvent{executeEventData = executeEventData} - = (Hs.mconcat - [case executeEventData of - Hs.Nothing -> Hs.mempty - Hs.Just x - -> case x of - ExecuteEventDataCommand y - -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) - (Hs.coerce @(Hs.Maybe Worker.ExecuteCommand) - @(HsProtobuf.Nested Worker.ExecuteCommand) - (Hs.Just y))) - ExecuteEventDataCancel y - -> (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) - (Hs.coerce @(Hs.Maybe Worker.ExecuteCancel) - @(HsProtobuf.Nested Worker.ExecuteCancel) - (Hs.Just y)))]) - decodeMessage _ - = (Hs.pure ExecuteEvent) <*> - (HsProtobuf.oneof Hs.Nothing - [((HsProtobuf.FieldNumber 1), - (Hs.pure (Hs.fmap ExecuteEventDataCommand)) <*> - (HsProtobuf.coerceOver @(HsProtobuf.Nested Worker.ExecuteCommand) - @(Hs.Maybe Worker.ExecuteCommand) - (HsProtobuf.decodeMessageField))), - ((HsProtobuf.FieldNumber 2), - (Hs.pure (Hs.fmap ExecuteEventDataCancel)) <*> - (HsProtobuf.coerceOver @(HsProtobuf.Nested Worker.ExecuteCancel) - @(Hs.Maybe Worker.ExecuteCancel) - (HsProtobuf.decodeMessageField)))]) - dotProto _ = [] - -instance HsJSONPB.ToJSONPB ExecuteEvent where - toJSONPB (ExecuteEvent f1_or_f2) - = (HsJSONPB.object - [(let encodeData - = (case f1_or_f2 of - Hs.Just (ExecuteEventDataCommand f1) - -> (HsJSONPB.pair "command" f1) - Hs.Just (ExecuteEventDataCancel f2) -> (HsJSONPB.pair "cancel" f2) - Hs.Nothing -> Hs.mempty) - in - \ options -> - if HsJSONPB.optEmitNamedOneof options then - ("data" .= (HsJSONPB.objectOrNull [encodeData] options)) options - else encodeData options)]) - toEncodingPB (ExecuteEvent f1_or_f2) - = (HsJSONPB.pairs - [(let encodeData - = (case f1_or_f2 of - Hs.Just (ExecuteEventDataCommand f1) - -> (HsJSONPB.pair "command" f1) - Hs.Just (ExecuteEventDataCancel f2) -> (HsJSONPB.pair "cancel" f2) - Hs.Nothing -> Hs.mempty) - in - \ options -> - if HsJSONPB.optEmitNamedOneof options then - ("data" .= (HsJSONPB.pairsOrNull [encodeData] options)) options - else encodeData options)]) - -instance HsJSONPB.FromJSONPB ExecuteEvent where - parseJSONPB - = (HsJSONPB.withObject "ExecuteEvent" - (\ obj -> - (Hs.pure ExecuteEvent) <*> - (let parseData parseObj - = Hs.msum - [Hs.Just Hs.. ExecuteEventDataCommand <$> - (HsJSONPB.parseField parseObj "command"), - Hs.Just Hs.. ExecuteEventDataCancel <$> - (HsJSONPB.parseField parseObj "cancel"), - Hs.pure Hs.Nothing] - in - ((obj .: "data") Hs.>>= (HsJSONPB.withObject "data" parseData)) <|> - (parseData obj)))) - -instance HsJSONPB.ToJSON ExecuteEvent where - toJSON = HsJSONPB.toAesonValue - toEncoding = HsJSONPB.toAesonEncoding - -instance HsJSONPB.FromJSON ExecuteEvent where - parseJSON = HsJSONPB.parseJSONPB - -instance HsJSONPB.ToSchema ExecuteEvent where - declareNamedSchema _ - = do let declare_data = HsJSONPB.declareSchemaRef - executeEventData <- declare_data Proxy.Proxy - let _ = Hs.pure ExecuteEvent <*> HsJSONPB.asProxy declare_data - Hs.return - (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = - Hs.Just "ExecuteEvent", - HsJSONPB._namedSchemaSchema = - Hs.mempty{HsJSONPB._schemaParamSchema = - Hs.mempty{HsJSONPB._paramSchemaType = - Hs.Just HsJSONPB.SwaggerObject}, - HsJSONPB._schemaProperties = - HsJSONPB.insOrdFromList - [("data", executeEventData)]}}) - -data ExecuteEventData = ExecuteEventDataCommand Worker.ExecuteCommand - | ExecuteEventDataCancel Worker.ExecuteCancel - deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic) - -instance Hs.NFData ExecuteEventData - -instance HsProtobuf.Named ExecuteEventData where - nameOf _ = (Hs.fromString "ExecuteEventData") - -instance HsJSONPB.ToSchema ExecuteEventData where - declareNamedSchema _ - = do let declare_command = HsJSONPB.declareSchemaRef - executeEventDataCommand <- declare_command Proxy.Proxy - let _ = Hs.pure ExecuteEventDataCommand <*> - HsJSONPB.asProxy declare_command - let declare_cancel = HsJSONPB.declareSchemaRef - executeEventDataCancel <- declare_cancel Proxy.Proxy - let _ = Hs.pure ExecuteEventDataCancel <*> - HsJSONPB.asProxy declare_cancel - Hs.return - (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = - Hs.Just "ExecuteEventData", - HsJSONPB._namedSchemaSchema = - Hs.mempty{HsJSONPB._schemaParamSchema = - Hs.mempty{HsJSONPB._paramSchemaType = - Hs.Just HsJSONPB.SwaggerObject}, - HsJSONPB._schemaProperties = - HsJSONPB.insOrdFromList - [("command", executeEventDataCommand), - ("cancel", executeEventDataCancel)], - HsJSONPB._schemaMinProperties = Hs.Just 1, - HsJSONPB._schemaMaxProperties = Hs.Just 1}}) - -data Worker request response = Worker{workerExecute :: - request 'HsGRPC.Normal Worker.ExecuteCommand - Worker.ExecuteResponse - -> Hs.IO (response 'HsGRPC.Normal Worker.ExecuteResponse), - workerExec :: - request 'HsGRPC.ClientStreaming Worker.ExecuteEvent - Worker.ExecuteResponse - -> - Hs.IO - (response 'HsGRPC.ClientStreaming Worker.ExecuteResponse)} - deriving Hs.Generic - -workerServer :: - Worker HsGRPC.ServerRequest HsGRPC.ServerResponse -> - HsGRPC.ServiceOptions -> Hs.IO () -workerServer - Worker{workerExecute = workerExecute, workerExec = workerExec} - (ServiceOptions serverHost serverPort useCompression - userAgentPrefix userAgentSuffix initialMetadata sslConfig logger - serverMaxReceiveMessageLength serverMaxMetadataSize) - = (HsGRPC.serverLoop - HsGRPC.defaultOptions{HsGRPC.optNormalHandlers = - [(HsGRPC.UnaryHandler (HsGRPC.MethodName "/worker.Worker/Execute") - (HsGRPC.convertGeneratedServerHandler workerExecute))], - HsGRPC.optClientStreamHandlers = - [(HsGRPC.ClientStreamHandler - (HsGRPC.MethodName "/worker.Worker/Exec") - (HsGRPC.convertGeneratedServerReaderHandler workerExec))], - HsGRPC.optServerStreamHandlers = [], - HsGRPC.optBiDiStreamHandlers = [], optServerHost = serverHost, - optServerPort = serverPort, optUseCompression = useCompression, - optUserAgentPrefix = userAgentPrefix, - optUserAgentSuffix = userAgentSuffix, - optInitialMetadata = initialMetadata, optSSLConfig = sslConfig, - optLogger = logger, - optMaxReceiveMessageLength = serverMaxReceiveMessageLength, - optMaxMetadataSize = serverMaxMetadataSize}) - -workerClient :: - HsGRPC.Client -> - Hs.IO (Worker HsGRPC.ClientRequest HsGRPC.ClientResult) -workerClient client - = (Hs.pure Worker) <*> - ((Hs.pure (HsGRPC.clientRequest client)) <*> - (HsGRPC.clientRegisterMethod client - (HsGRPC.MethodName "/worker.Worker/Execute"))) - <*> - ((Hs.pure (HsGRPC.clientRequest client)) <*> - (HsGRPC.clientRegisterMethod client - (HsGRPC.MethodName "/worker.Worker/Exec"))) - diff --git a/haskell/worker/impl b/haskell/worker/impl new file mode 160000 index 000000000..dadddf43d --- /dev/null +++ b/haskell/worker/impl @@ -0,0 +1 @@ +Subproject commit dadddf43dac15881b203be822c3192c76366bb07 diff --git a/haskell/worker/worker.bzl b/haskell/worker/worker.bzl index 7b7bbcaeb..b02f56854 100644 --- a/haskell/worker/worker.bzl +++ b/haskell/worker/worker.bzl @@ -14,3 +14,28 @@ worker_libs = [ "unix", ] +worker_srcs = [ + "@prelude//haskell/worker/impl/plugin/src:Internal/AbiHash.hs", + "@prelude//haskell/worker/impl/plugin/src:Internal/Args.hs", + "@prelude//haskell/worker/impl/plugin/src:Internal/Cache.hs", + "@prelude//haskell/worker/impl/plugin/src:Internal/Compile.hs", + "@prelude//haskell/worker/impl/plugin/src:Internal/Error.hs", + "@prelude//haskell/worker/impl/plugin/src:Internal/Log.hs", + "@prelude//haskell/worker/impl/plugin/src:Internal/Session.hs", + "@prelude//haskell/worker/impl/buck-worker:Args.hs", + "@prelude//haskell/worker/impl/buck-worker:Main.hs", + "@prelude//haskell/worker/impl/buck-worker:BuckWorker.hs", +] + +worker_flags = [ + "-Wall", + "-XGHC2021", + "-XBlockArguments", + "-XDerivingStrategies", + "-XRecordWildCards", + "-XDuplicateRecordFields", + "-XOverloadedRecordDot", + "-XStrictData", + "-XNoFieldSelectors", + "-XLambdaCase", +] diff --git a/haskell/worker/worker.proto b/haskell/worker/worker.proto deleted file mode 100644 index 0fb4ced50..000000000 --- a/haskell/worker/worker.proto +++ /dev/null @@ -1,47 +0,0 @@ -/* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under both the MIT license found in the - * LICENSE-MIT file in the root directory of this source tree and the Apache - * License, Version 2.0 found in the LICENSE-APACHE file in the root directory - * of this source tree. - */ - -syntax = "proto3"; - -option java_multiple_files = true; -option java_package = "com.facebook.buck.worker.model"; -option java_outer_classname = "WorkerProto"; - -package worker; - -message ExecuteCommand { - message EnvironmentEntry { - bytes key = 1; - bytes value = 2; - } - - repeated bytes argv = 1; - repeated EnvironmentEntry env = 2; -} - -message ExecuteResponse { - int32 exit_code = 1; - string stderr = 2; -} - -message ExecuteCancel {} - -message ExecuteEvent { - oneof data { - ExecuteCommand command = 1; - ExecuteCancel cancel = 2; - } -} - -service Worker { - // TODO(ctolliday) delete once workers switch to Exec - rpc Execute(ExecuteCommand) returns (ExecuteResponse) {}; - - rpc Exec(stream ExecuteEvent) returns (ExecuteResponse) {}; -}