diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -10,13 +10,26 @@ import Control.DeepSeq import Control.Monad import Control.Monad.Catch -import Control.Exception (AsyncException(UserInterrupt), evaluate) + ( SomeException + , catch + , displayException + , fromException + ) +import Control.Exception + ( AsyncException(UserInterrupt) + , evaluate + ) import Data.List (groupBy) import Data.Maybe (catMaybes) import Data.Typeable import Text.Read (readMaybe) + +-- System environment and Inter-Process-Communication (IPC) +import Foreign.C.Types ( CInt ) +import GHC.IO.Handle.FD ( fdToHandle ) import System.Environment as System import System.FilePath.Posix as System +import System.IO as System -- Haskell interpreter import Language.Haskell.Interpreter hiding (eval, setImports) @@ -31,7 +44,7 @@ import qualified Data.ByteString.Char8 as B import Data.Text as T (Text, concat, pack) import Data.String (fromString) -import Web.Scotty +import qualified Web.Scotty as Web -- Interpreter import Hyper.Internal as Hyper @@ -46,13 +59,31 @@ main :: IO () main = do + -- get port number from environment env <- System.getEnvironment let port = maybe defaultPort id $ readMaybe =<< Prelude.lookup "PORT" env - (hint, interpreterLoop) <- newInterpreter - forkIO $ scotty port (jsonAPI hint) - interpreterLoop -- See NOTE [MainThread] + -- get file descriptor (pipe) from the first argument + args <- System.getArgs + let writeReady = case args of + (x:_) -> maybe (return ()) writeReadyMsgToFD $ readMaybe x + _ -> return () + -- Start interpreter and web server. See NOTE [MainThread] + (hint, interpreterLoop) <- newInterpreter writeReady + forkIO $ Web.scotty port (jsonAPI hint) + interpreterLoop + +-- | Write the message "ready" to the specified file descriptor (pipe). +writeReadyMsgToFD :: CInt -> IO () +writeReadyMsgToFD fd0 = do + handle <- GHC.IO.Handle.FD.fdToHandle (fromIntegral fd0) + System.hSetBinaryMode handle False + System.hSetEncoding handle System.utf8 + System.hSetBuffering handle LineBuffering + System.hPutStr handle "ready" + + {- NOTE [MainThread] We fork the web server and run GHC in the main thread. @@ -65,29 +96,31 @@ {----------------------------------------------------------------------------- Exported JSON REST API ------------------------------------------------------------------------------} -jsonAPI :: Hint -> ScottyM () +jsonAPI :: Hint -> Web.ScottyM () jsonAPI hint = do - post "/cancel" $ do + Web.post "/cancel" $ do liftIO $ cancel hint - json $ JSON.object [ "status" .= t "ok" ] - post "/setExtensions" $ - json . result =<< liftIO . setExtensions hint =<< param "query" - post "/setImports" $ - json . result =<< liftIO . setImports hint =<< param "query" - post "/setSearchPath" $ do - x <- param "query" - y <- param "dir" - json . result =<< (liftIO $ setSearchPath hint x y) - post "/loadFiles" $ - json . result =<< liftIO . loadFiles hint =<< param "query" - post "/eval" $ do - json . result =<< liftIO . eval hint =<< param "query" + Web.json $ JSON.object [ "status" .= t "ok" ] + Web.post "/setExtensions" $ + Web.json . result =<< liftIO . setExtensions hint =<< Web.param "query" + Web.post "/setImports" $ + Web.json . result =<< liftIO . setImports hint =<< Web.param "query" + Web.post "/setSearchPath" $ do + x <- Web.param "query" + y <- Web.param "dir" + Web.json . result =<< (liftIO $ setSearchPath hint x y) + Web.post "/loadFiles" $ + Web.json . result =<< liftIO . loadFiles hint =<< Web.param "query" + Web.post "/eval" $ do + Web.json . result =<< liftIO . eval hint =<< Web.param "query" -t s = fromString s :: Text +t :: String -> Text +t s = fromString s +-- | Convert an interpreter result to JSON. result :: JSON.ToJSON a => Result a -> JSON.Value result (Left e) = JSON.object [ "status" .= t "error", "errors" .= err e] - where + where err e = toJSON $ case e of UnknownError s -> [t s] WontCompile xs -> map (t . errMsg) xs @@ -269,8 +302,10 @@ debug s = liftIO $ putStrLn s -- | Create and initialize a Haskell interpreter. -newInterpreter :: IO (Hint, IO ()) -- ^ (send commands, interpreter loop) -newInterpreter = do +-- Arguments: +-- writeReady = function to call when the interpreter is ready to evaluate expressions. +newInterpreter :: IO () -> IO (Hint, IO ()) -- ^ (send commands, interpreter loop) +newInterpreter writeReady = do vin <- newEmptyMVar evalThreadId <- newEmptyMVar -- ThreadID of the thread responsible for evaluation @@ -307,6 +342,6 @@ putMVar evalThreadId =<< myThreadId -- NOTE: The failure branch of `catch` will `mask` asynchronous exceptions. let go = forever $ handler `catch` (\UserInterrupt -> return ()) - void $ runInterpreter go + void $ runInterpreter $ liftIO writeReady >> go return (Hint run cancel, interpreterLoop) diff --git a/hyper-haskell-server.cabal b/hyper-haskell-server.cabal --- a/hyper-haskell-server.cabal +++ b/hyper-haskell-server.cabal @@ -1,5 +1,5 @@ Name: hyper-haskell-server -Version: 0.2.3.0 +Version: 0.2.3.1 Synopsis: Server back-end for the HyperHaskell graphical Haskell interpreter Description: This package is part of the /HyperHaskell/ project and provides @@ -11,10 +11,21 @@ License-file: LICENSE Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus -Copyright: (c) Heinrich Apfelmus 2016-2020 +Copyright: (c) Heinrich Apfelmus 2016-2024 Cabal-version: >= 1.10 Build-type: Simple +Tested-With: + GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.2.8 + , GHC == 9.4.7 + , GHC == 9.6.4 + , GHC == 9.8.1 Source-repository head type: git @@ -22,18 +33,18 @@ subdir: haskell/hyper-haskell-server/ Executable hyper-haskell-server - build-depends: base >= 4.6 && < 4.15 - , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.6) - , bytestring >= 0.9 && < 0.12 - , deepseq >= 1.2 && < 1.5 + build-depends: base >= 4.6 && < 4.20 + , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.3) + , bytestring >= 0.9 && < 0.13 + , deepseq >= 1.2 && < 1.6 , exceptions >= 0.6 && < 0.11 - , filepath >= 1.0 && < 1.5 + , filepath >= 1.0 && < 1.6 , haskell-src-exts >= 1.17 && < 1.24 , hint >= 0.8 && < 0.10 , hyper == 0.2.* - , text >= 0.11 && < 1.3 - , transformers >= 0.3 && < 0.6 - , scotty >= 0.6 && < 0.13 + , text >= 0.11 && < 2.2 + , transformers >= 0.3 && < 0.7 + , scotty >= 0.6 && < 0.22 ghc-options: -threaded cpp-Options: -DCABAL main-is: Main.hs