futhark-server 1.2.4.0 → 1.3.0.0

raw patch · 4 files changed

+89/−45 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• futhark-server.cabal +1/−1
• src/Futhark/Server.hs +73/−42
• src/Futhark/Server/Values.hs +4/−2

@@ -1,5 +1,16 @@ # Revision history for futhark-server +## 1.3.0.0 -- 2026-03-05++* `Futhark.Server.Values.getValue` now detects attempts to retrieve (some)+  non-opaque values instead of silently producing something invalid.++* `cmdSetTuningParam` now has a more precise type.++* Server-related exceptions are now reported with the `ServerException` type.++* `cmdFields` now produces structured information.+ ## 1.2.4.0 -- 2026-02-19  * Report exit code when server terminates with nonzero exit code.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               futhark-server-version:            1.2.4.0+version:            1.3.0.0 synopsis: Client implementation of the Futhark server protocol.  description: Provides an easy way to interact with a running Futhark

@@ -10,26 +10,32 @@ -- functions for loading data into a server. -- -- Error messages produced by the server will be returned as a--- 'CmdFailure'.  However, certain errors (such as if the server+-- t'CmdFailure'.  However, certain errors (such as if the server -- process terminates unexpectedly, or temporary files cannot be -- created) will result in an IO exception. -- -- Many of the functions here are documented only as the server -- protocol command they correspond to.  See the protocol -- documentation for details.+--+-- Type aliases are added for readability, but many of the commands simply+-- accept and produce 'T.Text's. module Futhark.Server   ( -- * Server creation     Server,     ServerCfg (..),     newServerCfg,     withServer,+    ServerException (..),      -- * Commands     Cmd,     CmdFailure (..),+    Field (..),     VarName,     TypeName,     EntryName,+    TuningParamName,     InputType (..),     OutputType (..), @@ -89,9 +95,24 @@ import System.IO.Temp (getCanonicalTemporaryDirectory) import qualified System.Process as P +-- | An unexpected IO exception describing an error related to interacting with+-- the server, such as failing to start it, or the server crashing.+data ServerException+  = -- | Human-readable error message.+    ServerException T.Text+  deriving (Show)++instance Exception ServerException+ -- | The name of a command. type Cmd = Text +-- | A record field+data Field = Field+  { fieldName :: Text,+    fieldType :: TypeName+  }+ -- | A handle to a running server. data Server = Server   { serverStdin :: Handle,@@ -131,11 +152,10 @@       cfgOnLine = \_ _ -> pure ()     } --- | Start up a server.  Make sure that 'stopServer' is eventually--- called on the server.  If this does not happen, then temporary--- files may be left on the file system.  You almost certainly wish to--- use 'bracket' or similar to avoid this.  Calls 'error' if startup--- fails.+-- | Start up a server. Make sure that 'stopServer' is eventually called on the+-- server. If this does not happen, then temporary files may be left on the file+-- system. You almost certainly wish to use 'bracket' or similar to avoid this.+-- Throws 'ServerException' if startup fails. startServer :: ServerCfg -> IO Server startServer (ServerCfg prog options debug on_line_f) = do   tmpdir <- getCanonicalTemporaryDirectory@@ -152,9 +172,11 @@   code <- P.getProcessExitCode phandle   case code of     Just (ExitFailure e) ->-      error $ "Cannot start " ++ prog ++ ": error " ++ show e+      throw . ServerException $+        "Cannot start " <> T.pack prog <> ": error " <> T.pack (show e)     Just ExitSuccess ->-      error $ "Cannot start " ++ prog ++ ": terminated immediately, but reported success."+      throw . ServerException $+        "Cannot start " <> T.pack prog <> ": terminated immediately, but reported success."     Nothing -> do       let server =             Server@@ -171,19 +193,19 @@     onStartupError :: Server -> IOError -> IO a     onStartupError s _ = do       code <- P.waitForProcess $ serverProc s-      stderr_s <- readFile $ serverErrLog s+      stderr_s <- T.readFile $ serverErrLog s       removeFile $ serverErrLog s-      error $+      throw . ServerException $         "Command failed with "-          ++ show code-          ++ ":\n"-          ++ unwords (prog : options)-          ++ "\nStderr:\n"-          ++ stderr_s+          <> T.pack (show code)+          <> ":\n"+          <> T.pack (unwords (prog : options))+          <> "\nStderr:\n"+          <> stderr_s --- | Shut down a server.  It may not be used again.  Calls 'error' if--- the server process terminates with a failing exit code--- (i.e. anything but 'ExitSuccess').+-- | Shut down a server. It may not be used again. Throws 'ServerException' if+-- the server process terminates with a failing exit code (i.e. anything but+-- 'ExitSuccess'). stopServer :: Server -> IO () stopServer s = flip finally (removeFile (serverErrLog s)) $ do   hClose $ serverStdin s@@ -191,10 +213,10 @@   case code of     ExitSuccess -> pure ()     ExitFailure x -> do-      stderr_s <- readFile $ serverErrLog s-      error $+      stderr_s <- T.readFile $ serverErrLog s+      throw . ServerException $         "Server terminated with nonzero exit code "-          <> show x+          <> T.pack (show x)           <> " and stderr:\n"           <> stderr_s @@ -205,7 +227,7 @@ abortServer = P.terminateProcess . serverProc  -- | Start a server, execute an action, then shut down the server.--- The 'Server' may not be returned from the action.+-- The t'Server' may not be returned from the action. withServer :: ServerCfg -> (Server -> IO a) -> IO a withServer cfg m = mask $ \restore -> do   server <- startServer cfg@@ -280,18 +302,18 @@       let code_msg =             case code of               Just (ExitFailure x) ->-                "\nServer process exited unexpectedly with exit code: " ++ show x+                "\nServer process exited unexpectedly with exit code: " <> T.pack (show x)               Just ExitSuccess -> mempty               Nothing -> mempty-      stderr_s <- readFile $ serverErrLog s-      error $+      stderr_s <- T.readFile $ serverErrLog s+      throw . ServerException $         "After sending command "-          ++ show cmd-          ++ " to server process:"-          ++ show e-          ++ code_msg-          ++ "\nServer stderr:\n"-          ++ stderr_s+          <> cmd+          <> " to server process:"+          <> T.pack (show e)+          <> code_msg+          <> "\nServer stderr:\n"+          <> stderr_s  -- | The name of a server-side variable. type VarName = Text@@ -302,6 +324,9 @@ -- | The name of an entry point. type EntryName = Text +-- | The name of a tuning parameter.+type TuningParamName = Text+ -- | The type of an input of an entry point.  If 'inputConsumed', then -- the value passed in a 'cmdCall' must not be used again (nor any of -- its aliases).@@ -381,35 +406,41 @@ cmdUnpauseProfiling s = helpCmd s "unpause_profiling" []  -- | @set_tuning_param param value@-cmdSetTuningParam :: Server -> Text -> Text -> IO (Either CmdFailure [Text])-cmdSetTuningParam s param value = sendCommand s "set_tuning_param" [param, value]+cmdSetTuningParam :: Server -> TuningParamName -> Int -> IO (Maybe CmdFailure)+cmdSetTuningParam s param value = helpCmd s "set_tuning_param" [param, T.pack (show value)] --- | @tuning_params@-cmdTuningParams :: Server -> Text -> IO (Either CmdFailure [Text])+-- | @tuning_params entry_point@+cmdTuningParams :: Server -> EntryName -> IO (Either CmdFailure [TuningParamName]) cmdTuningParams s entry = sendCommand s "tuning_params" [entry]  -- | @tuning_param_class param@-cmdTuningParamClass :: Server -> Text -> IO (Either CmdFailure Text)+cmdTuningParamClass :: Server -> TuningParamName -> IO (Either CmdFailure Text) cmdTuningParamClass s param = fmap mconcat <$> sendCommand s "tuning_param_class" [param]  -- | @types@-cmdTypes :: Server -> IO (Either CmdFailure [Text])+cmdTypes :: Server -> IO (Either CmdFailure [TypeName]) cmdTypes s = sendCommand s "types" []  -- | @entry_points@-cmdEntryPoints :: Server -> IO (Either CmdFailure [Text])+cmdEntryPoints :: Server -> IO (Either CmdFailure [EntryName]) cmdEntryPoints s = sendCommand s "entry_points" []  -- | @fields type@-cmdFields :: Server -> Text -> IO (Either CmdFailure [Text])-cmdFields s t = sendCommand s "fields" [t]+cmdFields :: Server -> TypeName -> IO (Either CmdFailure [Field])+cmdFields s t = fmap (zipWith parseField [1..]) <$> sendCommand s "fields" [t]+  where+    parseField :: Int -> Text -> Field+    parseField l f =+      case T.words f of+        (fn : ft) -> Field fn $ T.unwords ft+        _ -> error $ "Invalid field on line " ++ show l ++ " of `fields` output: \"" ++ T.unpack f ++ "\""  -- | @new var0 type var1...@-cmdNew :: Server -> Text -> Text -> [Text] -> IO (Maybe CmdFailure)+cmdNew :: Server -> VarName -> TypeName -> [VarName] -> IO (Maybe CmdFailure) cmdNew s var0 t vars = helpCmd s "new" $ var0 : t : vars  -- | @project to from field@-cmdProject :: Server -> Text -> Text -> Text -> IO (Maybe CmdFailure)+cmdProject :: Server -> VarName -> VarName -> Text -> IO (Maybe CmdFailure) cmdProject s to from field = helpCmd s "project" [to, from, field]  -- | @shape v@

@@ -27,8 +27,10 @@         case Bin.decodeOrFail bytes of           Left (_, _, e) ->             pure $ Left $ "Cannot load value from generated byte stream:\n" <> T.pack e-          Right (_, _, val) ->-            pure $ Right val+          Right (remnant, _, val)+            | LBS.null remnant -> pure $ Right val+            | otherwise ->+                pure $ Left "Cannot load opaque value."  -- | Store a non-opaque value in the server.  A variable with the -- given name must not already exist (use 'cmdFree' to free it first