{-# LANGUAGE OverloadedStrings #-}

-- | Haskell code for interacting with a Futhark server program (a
-- program compiled with @--server@).
module Futhark.Server
  ( Server,
    withServer,
    CmdFailure (..),
    VarName,
    TypeName,
    EntryName,
    cmdRestore,
    cmdStore,
    cmdCall,
    cmdFree,
    cmdInputs,
    cmdOutputs,
    cmdClear,
    cmdReport,
  )
where

import Control.Exception
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Futhark.Util (isEnvVarAtLeast)
import System.Directory (removeFile)
import System.Exit
import System.IO hiding (stdin, stdout)
import System.IO.Temp
import qualified System.Process as P

-- | A handle to a running server.
data Server = Server
  { Server -> Handle
serverStdin :: Handle,
    Server -> Handle
serverStdout :: Handle,
    Server -> [Char]
serverErrLog :: FilePath,
    Server -> ProcessHandle
serverProc :: P.ProcessHandle,
    Server -> Bool
serverDebug :: Bool
  }

startServer :: FilePath -> [FilePath] -> IO Server
startServer :: [Char] -> [[Char]] -> IO Server
startServer [Char]
prog [[Char]]
options = do
  [Char]
tmpdir <- IO [Char]
getCanonicalTemporaryDirectory
  ([Char]
err_log_f, Handle
err_log_h) <- [Char] -> [Char] -> IO ([Char], Handle)
openTempFile [Char]
tmpdir [Char]
"futhark-server-stderr.log"
  (Just Handle
stdin, Just Handle
stdout, Maybe Handle
Nothing, ProcessHandle
phandle) <-
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess
      ( ([Char] -> [[Char]] -> CreateProcess
P.proc [Char]
prog [[Char]]
options)
          { std_err :: StdStream
P.std_err = Handle -> StdStream
P.UseHandle Handle
err_log_h,
            std_in :: StdStream
P.std_in = StdStream
P.CreatePipe,
            std_out :: StdStream
P.std_out = StdStream
P.CreatePipe
          }
      )

  Maybe ExitCode
code <- ProcessHandle -> IO (Maybe ExitCode)
P.getProcessExitCode ProcessHandle
phandle
  case Maybe ExitCode
code of
    Just (ExitFailure Int
e) ->
      [Char] -> IO Server
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO Server) -> [Char] -> IO Server
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot start " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
prog [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": error " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
e
    Maybe ExitCode
_ -> do
      let server :: Server
server =
            Server :: Handle -> Handle -> [Char] -> ProcessHandle -> Bool -> Server
Server
              { serverStdin :: Handle
serverStdin = Handle
stdin,
                serverStdout :: Handle
serverStdout = Handle
stdout,
                serverProc :: ProcessHandle
serverProc = ProcessHandle
phandle,
                serverDebug :: Bool
serverDebug = [Char] -> Int -> Bool
isEnvVarAtLeast [Char]
"FUTHARK_COMPILER_DEBUGGING" Int
1,
                serverErrLog :: [Char]
serverErrLog = [Char]
err_log_f
              }
      IO [Text] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Server -> IO [Text]
responseLines Server
server) IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` Server -> IOError -> IO ()
forall a. Server -> IOError -> IO a
onStartupError Server
server
      Server -> IO Server
forall (f :: * -> *) a. Applicative f => a -> f a
pure Server
server
  where
    onStartupError :: Server -> IOError -> IO a
    onStartupError :: forall a. Server -> IOError -> IO a
onStartupError Server
s IOError
_ = do
      ExitCode
code <- ProcessHandle -> IO ExitCode
P.waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Server -> ProcessHandle
serverProc Server
s
      [Char]
stderr_s <- [Char] -> IO [Char]
readFile ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Server -> [Char]
serverErrLog Server
s
      [Char] -> IO ()
removeFile ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> [Char]
serverErrLog Server
s
      [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
        [Char]
"Command failed with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ExitCode -> [Char]
forall a. Show a => a -> [Char]
show ExitCode
code [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char]
prog [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
options)
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\nStderr:\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
stderr_s

stopServer :: Server -> IO ()
stopServer :: Server -> IO ()
stopServer Server
s = do
  Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdin Server
s
  IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
P.waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Server -> ProcessHandle
serverProc Server
s
  [Char] -> IO ()
removeFile ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> [Char]
serverErrLog Server
s

-- | Start a server, execute an action, then shut down the server.
withServer :: FilePath -> [FilePath] -> (Server -> IO a) -> IO a
withServer :: forall a. [Char] -> [[Char]] -> (Server -> IO a) -> IO a
withServer [Char]
prog [[Char]]
options = IO Server -> (Server -> IO ()) -> (Server -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ([Char] -> [[Char]] -> IO Server
startServer [Char]
prog [[Char]]
options) Server -> IO ()
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 :: Server -> IO [Text]
responseLines Server
s = do
  Text
l <- Handle -> IO Text
T.hGetLine (Handle -> IO Text) -> Handle -> IO Text
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdout Server
s
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Server -> Bool
serverDebug Server
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"<<< " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l
  case Text
l of
    Text
"%%% OK" -> [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Text
_ -> (Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> IO [Text]
responseLines Server
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 {CmdFailure -> [Text]
failureLog :: [Text], CmdFailure -> [Text]
failureMsg :: [Text]}
  deriving (CmdFailure -> CmdFailure -> Bool
(CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool) -> Eq CmdFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CmdFailure -> CmdFailure -> Bool
$c/= :: CmdFailure -> CmdFailure -> Bool
== :: CmdFailure -> CmdFailure -> Bool
$c== :: CmdFailure -> CmdFailure -> Bool
Eq, Eq CmdFailure
Eq CmdFailure
-> (CmdFailure -> CmdFailure -> Ordering)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> Bool)
-> (CmdFailure -> CmdFailure -> CmdFailure)
-> (CmdFailure -> CmdFailure -> CmdFailure)
-> Ord CmdFailure
CmdFailure -> CmdFailure -> Bool
CmdFailure -> CmdFailure -> Ordering
CmdFailure -> CmdFailure -> CmdFailure
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CmdFailure -> CmdFailure -> CmdFailure
$cmin :: CmdFailure -> CmdFailure -> CmdFailure
max :: CmdFailure -> CmdFailure -> CmdFailure
$cmax :: CmdFailure -> CmdFailure -> CmdFailure
>= :: CmdFailure -> CmdFailure -> Bool
$c>= :: CmdFailure -> CmdFailure -> Bool
> :: CmdFailure -> CmdFailure -> Bool
$c> :: CmdFailure -> CmdFailure -> Bool
<= :: CmdFailure -> CmdFailure -> Bool
$c<= :: CmdFailure -> CmdFailure -> Bool
< :: CmdFailure -> CmdFailure -> Bool
$c< :: CmdFailure -> CmdFailure -> Bool
compare :: CmdFailure -> CmdFailure -> Ordering
$ccompare :: CmdFailure -> CmdFailure -> Ordering
Ord, Int -> CmdFailure -> [Char] -> [Char]
[CmdFailure] -> [Char] -> [Char]
CmdFailure -> [Char]
(Int -> CmdFailure -> [Char] -> [Char])
-> (CmdFailure -> [Char])
-> ([CmdFailure] -> [Char] -> [Char])
-> Show CmdFailure
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [CmdFailure] -> [Char] -> [Char]
$cshowList :: [CmdFailure] -> [Char] -> [Char]
show :: CmdFailure -> [Char]
$cshow :: CmdFailure -> [Char]
showsPrec :: Int -> CmdFailure -> [Char] -> [Char]
$cshowsPrec :: Int -> CmdFailure -> [Char] -> [Char]
Show)

-- Figure out whether the response is a failure, and if so, return the
-- failure message.
checkForFailure :: [Text] -> Either CmdFailure [Text]
checkForFailure :: [Text] -> Either CmdFailure [Text]
checkForFailure [] = [Text] -> Either CmdFailure [Text]
forall a b. b -> Either a b
Right []
checkForFailure (Text
"%%% FAILURE" : [Text]
ls) = CmdFailure -> Either CmdFailure [Text]
forall a b. a -> Either a b
Left (CmdFailure -> Either CmdFailure [Text])
-> CmdFailure -> Either CmdFailure [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> CmdFailure
CmdFailure [Text]
forall a. Monoid a => a
mempty [Text]
ls
checkForFailure (Text
l : [Text]
ls) =
  case [Text] -> Either CmdFailure [Text]
checkForFailure [Text]
ls of
    Left (CmdFailure [Text]
xs [Text]
ys) -> CmdFailure -> Either CmdFailure [Text]
forall a b. a -> Either a b
Left (CmdFailure -> Either CmdFailure [Text])
-> CmdFailure -> Either CmdFailure [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> CmdFailure
CmdFailure (Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs) [Text]
ys
    Right [Text]
ls' -> [Text] -> Either CmdFailure [Text]
forall a b. b -> Either a b
Right ([Text] -> Either CmdFailure [Text])
-> [Text] -> Either CmdFailure [Text]
forall a b. (a -> b) -> a -> b
$ Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ls'

-- Words with spaces in them must be quoted.
quoteWord :: Text -> Text
quoteWord :: Text -> Text
quoteWord Text
t
  | Just Char
_ <- (Char -> Bool) -> Text -> Maybe Char
T.find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
t =
    Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
  | Bool
otherwise = Text
t

sendCommand :: Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand :: Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text]
command = do
  let command' :: Text
command' = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteWord [Text]
command

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Server -> Bool
serverDebug Server
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
">>> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
command'

  Handle -> Text -> IO ()
T.hPutStrLn (Server -> Handle
serverStdin Server
s) Text
command'
  Handle -> IO ()
hFlush (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> Handle
serverStdin Server
s
  [Text] -> Either CmdFailure [Text]
checkForFailure ([Text] -> Either CmdFailure [Text])
-> IO [Text] -> IO (Either CmdFailure [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> IO [Text]
responseLines Server
s IO [Text] -> (IOError -> IO [Text]) -> IO [Text]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO [Text]
forall a. IOError -> IO a
onError
  where
    onError :: IOError -> IO a
    onError :: forall a. IOError -> IO a
onError IOError
e = do
      Maybe ExitCode
code <- ProcessHandle -> IO (Maybe ExitCode)
P.getProcessExitCode (ProcessHandle -> IO (Maybe ExitCode))
-> ProcessHandle -> IO (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ Server -> ProcessHandle
serverProc Server
s
      let code_msg :: [Char]
code_msg =
            case Maybe ExitCode
code of
              Just (ExitFailure Int
x) ->
                [Char]
"\nServer process exited unexpectedly with exit code: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x
              Maybe ExitCode
_ -> [Char]
forall a. Monoid a => a
mempty
      [Char]
stderr_s <- [Char] -> IO [Char]
readFile ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Server -> [Char]
serverErrLog Server
s
      [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
        [Char]
"After sending command " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
command [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to server process:"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
e
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
code_msg
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\nServer stderr:\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 :: Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text]
cmd =
  (CmdFailure -> Maybe CmdFailure)
-> ([Text] -> Maybe CmdFailure)
-> Either CmdFailure [Text]
-> Maybe CmdFailure
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CmdFailure -> Maybe CmdFailure
forall a. a -> Maybe a
Just (Maybe CmdFailure -> [Text] -> Maybe CmdFailure
forall a b. a -> b -> a
const Maybe CmdFailure
forall a. Maybe a
Nothing) (Either CmdFailure [Text] -> Maybe CmdFailure)
-> IO (Either CmdFailure [Text]) -> IO (Maybe CmdFailure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text]
cmd

cmdRestore :: Server -> FilePath -> [(VarName, TypeName)] -> IO (Maybe CmdFailure)
cmdRestore :: Server -> [Char] -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
s [Char]
fname [(Text, Text)]
vars = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Text
"restore" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Char] -> Text
T.pack [Char]
fname Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, Text) -> [Text]) -> [(Text, Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, Text) -> [Text]
forall {a}. (a, a) -> [a]
f [(Text, Text)]
vars
  where
    f :: (a, a) -> [a]
f (a
v, a
t) = [a
v, a
t]

cmdStore :: Server -> FilePath -> [VarName] -> IO (Maybe CmdFailure)
cmdStore :: Server -> [Char] -> [Text] -> IO (Maybe CmdFailure)
cmdStore Server
s [Char]
fname [Text]
vars = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Text
"store" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Char] -> Text
T.pack [Char]
fname Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
vars

cmdCall :: Server -> EntryName -> [VarName] -> [VarName] -> IO (Either CmdFailure [T.Text])
cmdCall :: Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
s Text
entry [Text]
outs [Text]
ins =
  Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s ([Text] -> IO (Either CmdFailure [Text]))
-> [Text] -> IO (Either CmdFailure [Text])
forall a b. (a -> b) -> a -> b
$ Text
"call" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
entry Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
outs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ins

cmdFree :: Server -> [VarName] -> IO (Maybe CmdFailure)
cmdFree :: Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
s [Text]
vs = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s ([Text] -> IO (Maybe CmdFailure))
-> [Text] -> IO (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Text
"free" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
vs

cmdInputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName])
cmdInputs :: Server -> Text -> IO (Either CmdFailure [Text])
cmdInputs Server
s Text
entry =
  Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"inputs", Text
entry]

cmdOutputs :: Server -> EntryName -> IO (Either CmdFailure [TypeName])
cmdOutputs :: Server -> Text -> IO (Either CmdFailure [Text])
cmdOutputs Server
s Text
entry =
  Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"outputs", Text
entry]

cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear :: Server -> IO (Maybe CmdFailure)
cmdClear Server
s = Server -> [Text] -> IO (Maybe CmdFailure)
helpCmd Server
s [Text
"clear"]

cmdReport :: Server -> IO (Either CmdFailure [T.Text])
cmdReport :: Server -> IO (Either CmdFailure [Text])
cmdReport Server
s = Server -> [Text] -> IO (Either CmdFailure [Text])
sendCommand Server
s [Text
"report"]