diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016 Heinrich Apfelmus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Heinrich Apfelmus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,188 @@ +{----------------------------------------------------------------------------- + HyperHaskell +------------------------------------------------------------------------------} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTSyntax, ExistentialQuantification, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Concurrent +import Control.DeepSeq +import Control.Monad +import Control.Monad.Catch +import Control.Exception (AsyncException(UserInterrupt), evaluate) +import Data.Typeable +import Text.Read (readMaybe) +import System.Environment as System + +-- Haskell interpreter +import Language.Haskell.Interpreter hiding (eval, setImports) +import qualified Language.Haskell.Interpreter as Hint + +-- web +import Data.Aeson (toJSON, (.=)) +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Data.String (fromString) +import Web.Scotty + +-- Interpreter +import Hyper.Internal + +say = putStrLn + +{----------------------------------------------------------------------------- + Main +------------------------------------------------------------------------------} +defaultPort :: Int +defaultPort = 8024 + +main :: IO () +main = do + 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] + +{- NOTE [MainThread] + +We fork the web server and run GHC in the main thread. +This is because GHC registers handlers for signals like SIGTERM, +but for some reason, these handlers only work correctly if GHC +also has the main thread. + +-} + +{----------------------------------------------------------------------------- + Exported JSON REST API +------------------------------------------------------------------------------} +jsonAPI :: Hint -> ScottyM () +jsonAPI hint = do + post "/cancel" $ do + liftIO $ cancel hint + json $ JSON.object [ "status" .= t "ok" ] + post "/setImports" $ + json . result =<< liftIO . setImports hint =<< param "query" + post "/loadFiles" $ + json . result =<< liftIO . loadFiles hint =<< param "query" + post "/eval" $ do + json . result =<< liftIO . eval hint =<< param "query" + +t s = fromString s :: Text + +result :: JSON.ToJSON a => Result a -> JSON.Value +result (Left e) = JSON.object [ "status" .= t "error", "errors" .= err e] + where + err e = toJSON $ case e of + UnknownError s -> [t s] + WontCompile xs -> map (t . errMsg) xs + NotAllowed s -> [t s] + GhcException s -> [t s] +result (Right x) = JSON.object [ "status" .= t "ok", "value" .= toJSON x ] + +instance JSON.ToJSON Graphic where + toJSON g = JSON.object [ "type" .= t "html", "value" .= gHtml g ] + +{----------------------------------------------------------------------------- + Exported interpreter functions +------------------------------------------------------------------------------} +setImports :: Hint -> [String] -> IO (Result ()) +loadFiles :: Hint -> [FilePath] -> IO (Result ()) +eval :: Hint -> String -> IO (Result Graphic) + + -- NOTE: We implicitely load the Prelude and Hyper modules +setImports hint = run hint . Hint.setImports + . (++ ["Prelude", "Hyper"]) . filter (not . null) + +loadFiles hint = run hint . Hint.loadModules . filter (not . null) + +eval hint expr = run hint $ do + -- NOTE: We wrap results into an implicit call to Hyper.display + m <- Hint.interpret ("Hyper.displayIO " ++ Hint.parens expr) (as :: IO Graphic) + liftIO $ do + g <- m + evaluate (force g) -- See NOTE [EvaluateToNF] + +{- NOTE [EvaluateToNF] + +We evaluate the result in the interpreter thread to full normal form, +because it may be that this evaluation does not terminate, +in which case the user is likely to trigger a `UserInterrupt` asynchronous exception. +But this exception is only delivered to and handled by the interpreter thread. +Otherwise, the web server would be stuck trying to evaluate the result +in order to serialize it, with no way for the user to interrupt this. + +-} + +{----------------------------------------------------------------------------- + Interpreter Backend +------------------------------------------------------------------------------} +type Result a = Either InterpreterError a + +toInterpreterError :: SomeException -> InterpreterError +toInterpreterError e = case fromException e of + Just e -> e + Nothing -> UnknownError (displayException e) + +#if MIN_VERSION_base(4,8,0) +#else +displayException :: SomeException -> String +displayException = show +#endif + +-- | Haskell Interpreter. +data Hint = Hint + { run :: forall a. Interpreter a -> IO (Result a) + , cancel :: IO () + } + +data Action where + Action :: Interpreter a -> MVar (Result a) -> Action + +debug s = liftIO $ putStrLn s + +-- | Create and initialize a Haskell interpreter. +newInterpreter :: IO (Hint, IO ()) -- ^ (send commands, interpreter loop) +newInterpreter = do + vin <- newEmptyMVar + evalThreadId <- newEmptyMVar -- ThreadID of the thread responsible for evaluation + + let + handler :: Interpreter () + handler = do + debug "Waiting for Haskell expression" + Action ma vout <- liftIO $ takeMVar vin + let right = liftIO . putMVar vout . Right =<< ma + let left = liftIO . putMVar vout . Left . toInterpreterError + debug "Got Haskell expression, evaluating" + right `catch` left + debug "Wrote result" + + run :: Interpreter a -> IO (Result a) + run ma = do + vout <- newEmptyMVar + putMVar vin (Action ma vout) + a <- takeMVar vout + case a of + Right _ -> return () + Left e -> debug $ show e + return a + + cancel :: IO () + cancel = do + t <- readMVar evalThreadId + throwTo t UserInterrupt + -- NOTE: `throwTo` may block if the thread `t` has masked asynchronous execptions. + debug "UserInterrupt, evaluation cancelled" + + interpreterLoop :: IO () + interpreterLoop = do + putMVar evalThreadId =<< myThreadId + -- NOTE: The failure branch of `catch` will `mask` asynchronous exceptions. + let go = forever $ handler `catch` (\UserInterrupt -> return ()) + void $ runInterpreter go + + return (Hint run cancel, interpreterLoop) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hyper-haskell-server.cabal b/hyper-haskell-server.cabal new file mode 100644 --- /dev/null +++ b/hyper-haskell-server.cabal @@ -0,0 +1,36 @@ +Name: hyper-haskell-server +Version: 0.1.0.0 +Synopsis: Server back-end for the HyperHaskell graphical Haskell interpreter +Description: + This package is part of the /HyperHaskell/ project and provides + the server back-end. + . +Category: Compilers/Interpreters +License: BSD3 +License-file: LICENSE +Author: Heinrich Apfelmus +Maintainer: Heinrich Apfelmus +Copyright: (c) Heinrich Apfelmus 2016 + +Cabal-version: >= 1.8 +Build-type: Simple + +Source-repository head + type: git + location: git://github.com/HeinrichApfelmus/hyper-haskell.git + subdir: haskell/hyper-haskell-server/ + +Executable hyper-haskell-server + build-depends: base >= 4.6 && < 4.10 + , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.1) + , bytestring >= 0.9 && < 0.11 + , deepseq >= 1.2 && < 1.5 + , exceptions >= 0.6 && < 0.9 + , hint >= 0.4 && < 0.7 + , hyper == 0.1.* + , text >= 0.11 && < 1.3 + , transformers >= 0.3 && < 0.6 + , scotty >= 0.6 && < 0.12 + ghc-options: -threaded + cpp-Options: -DCABAL + main-is: Main.hs