futhark-server (empty) → 1.0.0.0

raw patch · 5 files changed

+374/−0 lines, 5 filesdep +basedep +binarydep +bytestring

Dependencies added: base, binary, bytestring, directory, futhark-data, mtl, process, temporary, text

Files

CHANGELOG.md +5/−0
LICENSE +17/−0
futhark-server.cabal +37/−0
src/Futhark/Server.hs +272/−0
src/Futhark/Server/Values.hs +43/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for futhark-server++## 0.1.0.0 -- 2021-06-17++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,17 @@+ISC License++Copyright (c) 2013-2021. DIKU, University of Copenhagen++Permission to use, copy, modify, and/or distribute this software for+any purpose with or without fee is hereby granted, provided that the+above copyright notice and this permission notice appear in all+copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL+WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE+AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL+DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR+PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.

+ futhark-server.cabal view

@@ -0,0 +1,37 @@+cabal-version:      2.4+name:               futhark-server+version:            1.0.0.0+synopsis: Client implementation of the Futhark server protocol.++description: Provides an easy way to interact with a running Futhark+             server-mode program from a Haskell program.  Provides+             both direct support of the protocol, as well as+             convenience functions for loading and extracting data.++category:           Futhark+author:             Troels Henriksen+maintainer:         athas@sigkill.dk+bug-reports:        https://github.com/diku-dk/futhark-server-haskell/issues+license:            ISC+license-file:       LICENSE+extra-source-files: CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/diku-dk/futhark-server-haskell++library+    exposed-modules:  Futhark.Server+                      Futhark.Server.Values+    build-depends:    base >=4 && < 5+                    , binary+                    , bytestring+                    , directory >=1.3.0.0+                    , futhark-data+                    , text >=1.2.2.2+                    , temporary+                    , process >=1.4.3.0+                    , mtl >=2.2.1+    hs-source-dirs:   src+    ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists+    default-language: Haskell2010

+ src/Futhark/Server.hs view

@@ -0,0 +1,272 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Haskell code for interacting with a Futhark server program.  This+-- module presents a low-level interface.  See+-- <https://futhark.readthedocs.io/en/latest/server-protocol.html the+-- documentation of the server protocol> for the meaning of the+-- commands.  See also "Futhark.Server.Values" for higher-level+-- 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+-- process terminates unexpectedly, or temporary files cannot be+-- created) will result in an IO exception.+module Futhark.Server+  ( -- * Server creation+    Server,+    ServerCfg (..),+    newServerCfg,+    withServer,++    -- * Commands+    CmdFailure (..),+    VarName,+    TypeName,+    EntryName,+    cmdRestore,+    cmdStore,+    cmdCall,+    cmdFree,+    cmdRename,+    cmdInputs,+    cmdOutputs,+    cmdClear,+    cmdReport,++    -- * Utility+    cmdMaybe,+    cmdEither,++    -- * Raw+    startServer,+    stopServer,+    sendCommand,+  )+where++import Control.Exception+import Control.Monad+import Control.Monad.Except+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Directory (removeFile)+import System.Exit+import System.IO hiding (stdin, stdout)+import System.IO.Temp (getCanonicalTemporaryDirectory)+import qualified System.Process as P++-- | A handle to a running server.+data Server = Server+  { serverStdin :: Handle,+    serverStdout :: Handle,+    serverErrLog :: FilePath,+    serverProc :: P.ProcessHandle,+    serverDebug :: Bool+  }++-- | Configuration of the server.  Use 'newServerCfg' to conveniently+-- create a sensible default configuration.+data ServerCfg = ServerCfg+  { -- | Path to the server executable.+    cfgProg :: FilePath,+    -- | Command line options to pass to the+    -- server executable.+    cfgProgOpts :: [String],+    -- | If true, print a running log of server communication to stderr.+    cfgDebug :: Bool+  }+  deriving (Eq, Ord, Show)++-- | Create a server config with the given 'cfgProg' and 'cfgProgOpts'.+newServerCfg :: FilePath -> [String] -> ServerCfg+newServerCfg prog opts =+  ServerCfg+    { cfgProg = prog,+      cfgProgOpts = opts,+      cfgDebug = False+    }++-- | 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.+startServer :: ServerCfg -> IO Server+startServer (ServerCfg prog options debug) = do+  tmpdir <- getCanonicalTemporaryDirectory+  (err_log_f, err_log_h) <- openTempFile tmpdir "futhark-server-stderr.log"+  (Just stdin, Just stdout, Nothing, phandle) <-+    P.createProcess+      ( (P.proc prog options)+          { P.std_err = P.UseHandle err_log_h,+            P.std_in = P.CreatePipe,+            P.std_out = P.CreatePipe+          }+      )++  code <- P.getProcessExitCode phandle+  case code of+    Just (ExitFailure e) ->+      error $ "Cannot start " ++ prog ++ ": error " ++ show e+    _ -> do+      let server =+            Server+              { serverStdin = stdin,+                serverStdout = stdout,+                serverProc = phandle,+                serverDebug = debug,+                serverErrLog = err_log_f+              }+      void (responseLines server) `catch` onStartupError server+      pure server+  where+    onStartupError :: Server -> IOError -> IO a+    onStartupError s _ = do+      code <- P.waitForProcess $ serverProc s+      stderr_s <- readFile $ serverErrLog s+      removeFile $ serverErrLog s+      error $+        "Command failed with " ++ show code ++ ":\n"+          ++ unwords (prog : options)+          ++ "\nStderr:\n"+          ++ stderr_s++-- | Shut down a server.  It may not be used again.+stopServer :: Server -> IO ()+stopServer s = do+  hClose $ serverStdin s+  void $ P.waitForProcess $ serverProc s+  removeFile $ serverErrLog s++-- | Start a server, execute an action, then shut down the server.+-- The 'Server' may not be returned from the action.+withServer :: ServerCfg -> (Server -> IO a) -> IO a+withServer cfg = bracket (startServer cfg) stopServer++-- Read lines of response until the next %%% OK (which is what+-- indicates that the server is ready for new instructions).+responseLines :: Server -> IO [Text]+responseLines s = do+  l <- T.hGetLine $ serverStdout s+  when (serverDebug s) $+    T.hPutStrLn stderr $ "<<< " <> l+  case l of+    "%%% OK" -> pure []+    _ -> (l :) <$> responseLines s++-- | The command failed, and this is why.  The first 'Text' is any+-- output before the failure indincator, and the second Text is the+-- output after the indicator.+data CmdFailure = CmdFailure {failureLog :: [Text], failureMsg :: [Text]}+  deriving (Eq, Ord, Show)++-- Figure out whether the response is a failure, and if so, return the+-- failure message.+checkForFailure :: [Text] -> Either CmdFailure [Text]+checkForFailure [] = Right []+checkForFailure ("%%% FAILURE" : ls) = Left $ CmdFailure mempty ls+checkForFailure (l : ls) =+  case checkForFailure ls of+    Left (CmdFailure xs ys) -> Left $ CmdFailure (l : xs) ys+    Right ls' -> Right $ l : ls'++-- Words with spaces in them must be quoted.+quoteWord :: Text -> Text+quoteWord t+  | Just _ <- T.find (== ' ') t =+    "\"" <> t <> "\""+  | otherwise = t++-- | Send an arbitrary command to the server.  This is only useful+-- when the server protocol has been extended without this module+-- having been similarly extended.  Be careful not to send invalid+-- commands.+sendCommand :: Server -> [Text] -> IO (Either CmdFailure [Text])+sendCommand s command = do+  let command' = T.unwords $ map quoteWord command++  when (serverDebug s) $+    T.hPutStrLn stderr $ ">>> " <> command'++  T.hPutStrLn (serverStdin s) command'+  hFlush $ serverStdin s+  checkForFailure <$> responseLines s `catch` onError+  where+    onError :: IOError -> IO a+    onError e = do+      code <- P.getProcessExitCode $ serverProc s+      let code_msg =+            case code of+              Just (ExitFailure x) ->+                "\nServer process exited unexpectedly with exit code: " ++ show x+              _ -> mempty+      stderr_s <- readFile $ serverErrLog s+      error $+        "After sending command " ++ show command ++ " to server process:"+          ++ show e+          ++ code_msg+          ++ "\nServer stderr:\n"+          ++ stderr_s++-- | The name of a server-side variable.+type VarName = Text++-- | The name of a server-side type.+type TypeName = Text++-- | The name of an entry point.+type EntryName = Text++helpCmd :: Server -> [Text] -> IO (Maybe CmdFailure)+helpCmd s cmd =+  either Just (const Nothing) <$> sendCommand s cmd++-- | @restore filename var0 type0 var1 type1...@.+cmdRestore :: Server -> FilePath -> [(VarName, TypeName)] -> IO (Maybe CmdFailure)+cmdRestore s fname vars = helpCmd s $ "restore" : T.pack fname : concatMap f vars+  where+    f (v, t) = [v, t]++-- | @store filename vars...@.+cmdStore :: Server -> FilePath -> [VarName] -> IO (Maybe CmdFailure)+cmdStore s fname vars = helpCmd s $ "store" : T.pack fname : vars++-- | @call entrypoint outs... ins...@.+cmdCall :: Server -> EntryName -> [VarName] -> [VarName] -> IO (Either CmdFailure [T.Text])+cmdCall s entry outs ins =+  sendCommand s $ "call" : entry : outs ++ ins++-- | @free vars...@.+cmdFree :: Server -> [VarName] -> IO (Maybe CmdFailure)+cmdFree s vs = helpCmd s $ "free" : vs++-- | @rename oldname newname@.+cmdRename :: Server -> VarName -> VarName -> IO (Maybe CmdFailure)+cmdRename s oldname newname = helpCmd s ["rename", oldname, newname]++-- | @inputs entryname@+cmdInputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName])+cmdInputs s entry =+  sendCommand s ["inputs", entry]++-- | @outputs entryname@+cmdOutputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName])+cmdOutputs s entry =+  sendCommand s ["outputs", entry]++-- | @clear@+cmdClear :: Server -> IO (Maybe CmdFailure)+cmdClear s = helpCmd s ["clear"]++-- | @report@+cmdReport :: Server -> IO (Either CmdFailure [T.Text])+cmdReport s = sendCommand s ["report"]++-- | Turn a 'Maybe'-producing command into a monadic action.+cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()+cmdMaybe = maybe (pure ()) (throwError . T.unlines . failureMsg) <=< liftIO++-- | Turn an 'Either'-producing command into a monadic action.+cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a+cmdEither = either (throwError . T.unlines . failureMsg) pure <=< liftIO

+ src/Futhark/Server/Values.hs view

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Convenience functions builds on top of "Futhark.Data" and+-- "Futhark.Server" for passing non-opaque values in and out of a+-- server instance.+module Futhark.Server.Values (getValue, putValue) where++import qualified Data.Binary as Bin+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Futhark.Data (Value, valueType, valueTypeTextNoDims)+import Futhark.Server+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)++-- | Retrieve a non-opaque value from the server.+getValue :: Server -> VarName -> IO (Either T.Text Value)+getValue server vname =+  withSystemTempFile "futhark-server-get" $ \tmpf tmpf_h -> do+    hClose tmpf_h+    store_res <- cmdStore server tmpf [vname]+    case store_res of+      Just (CmdFailure _ err) ->+        pure $ Left $ T.unlines err+      Nothing -> do+        bytes <- LBS.readFile tmpf+        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++-- | Store a non-opaque value in the server.  A variable with the+-- given name must not already exist (use 'cmdFree' to free it first+-- if necessary).+putValue :: Server -> VarName -> Value -> IO (Maybe CmdFailure)+putValue server v val =+  withSystemTempFile "futhark-server-put" $ \tmpf tmpf_h -> do+    LBS.hPutStr tmpf_h $ Bin.encode val+    hClose tmpf_h+    cmdRestore server tmpf [(v, t)]+  where+    t = valueTypeTextNoDims $ valueType val