diff --git a/IHaskell.cabal b/IHaskell.cabal index c77d6804..e783ba9e 100644 --- a/IHaskell.cabal +++ b/IHaskell.cabal @@ -7,7 +7,7 @@ name: ihaskell -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.5 +version: 0.2.0.6 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project. @@ -76,10 +76,20 @@ library cereal ==0.3.*, text >=0.11, mtl >= 2.1 - exposed-modules: IHaskell.Display, - Paths_ihaskell, - IHaskell.Types, + exposed-modules: IHaskell.Display + IHaskell.Eval.Completion + IHaskell.Eval.Evaluate + IHaskell.Eval.Info + IHaskell.Eval.Lint + IHaskell.Eval.Parser + IHaskell.Eval.Stdin + IHaskell.IPython + IHaskell.Message.Parser IHaskell.Message.UUID + IHaskell.Message.Writer + IHaskell.Types + IHaskell.ZeroMQ + Paths_ihaskell executable IHaskell -- .hs or .lhs file containing the Main module. @@ -95,6 +105,7 @@ executable IHaskell IHaskell.Eval.Info IHaskell.Eval.Evaluate IHaskell.Eval.Parser + IHaskell.Eval.Stdin IHaskell.IPython IHaskell.Message.Parser IHaskell.Message.UUID diff --git a/profile/profile.tar b/profile/profile.tar index f033d9c4..d2ec2f92 100644 Binary files a/profile/profile.tar and b/profile/profile.tar differ diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index f0c640d6..f04d7325 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -83,6 +83,7 @@ type Interpreter = Ghc globalImports :: [String] globalImports = [ "import IHaskell.Display" + , "import qualified IHaskell.Eval.Stdin" , "import Control.Applicative ((<$>))" , "import GHC.IO.Handle (hDuplicateTo, hDuplicate, hClose)" , "import System.Posix.IO" @@ -103,7 +104,7 @@ interpret action = runGhc (Just libdir) $ do -- Close stdin so it can't be used. -- Otherwise it'll block the kernel forever. - runStmt "System.IO.hClose System.IO.stdin" RunToCompletion + runStmt "IHaskell.Eval.Stdin.fixStdin" RunToCompletion initializeItVariable diff --git a/src/IHaskell/Eval/Stdin.hs b/src/IHaskell/Eval/Stdin.hs new file mode 100644 index 00000000..2cd1079b --- /dev/null +++ b/src/IHaskell/Eval/Stdin.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} +module IHaskell.Eval.Stdin (fixStdin, recordParentHeader, recordKernelProfile) where + +import ClassyPrelude hiding (hPutStrLn, readFile, writeFile) + +import Prelude (read) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.Chan +import Control.Monad +import GHC.IO.Handle +import GHC.IO.Handle.Types +import System.IO +import System.Posix.IO +import System.IO.Unsafe +import qualified Data.Map as Map + +import IHaskell.Types +import IHaskell.IPython +import IHaskell.ZeroMQ +import IHaskell.Message.UUID as UUID + +stdinInterface :: MVar ZeroMQStdin +stdinInterface = unsafePerformIO newEmptyMVar + +-- | Manipulate standard input so that it is sourced from the IPython +-- frontend. This function is build on layers of deep magical hackery, so +-- be careful modifying it. +fixStdin :: IO () +fixStdin = do + -- Initialize the stdin interface. + dir <- getIHaskellDir + profile <- read <$> readFile (dir ++ "/.kernel-profile") + interface <- serveStdin profile + putMVar stdinInterface interface + void $ forkIO stdinOnce + +stdinOnce :: IO () +stdinOnce = do + -- Create a pipe using and turn it into handles. + (readEnd, writeEnd) <- createPipe + newStdin <- fdToHandle readEnd + stdinInput <- fdToHandle writeEnd + hSetBuffering newStdin NoBuffering + hSetBuffering stdinInput NoBuffering + + -- Store old stdin and swap in new stdin. + oldStdin <- hDuplicate stdin + hDuplicateTo newStdin stdin + + loop stdinInput oldStdin newStdin + where + loop stdinInput oldStdin newStdin = do + let FileHandle _ mvar = stdin + threadDelay $ 150 * 1000 + empty <- isEmptyMVar mvar + if not empty + then loop stdinInput oldStdin newStdin + else do + line <- getInputLine + hPutStr stdinInput $ line ++ "\n" + loop stdinInput oldStdin newStdin + +-- | Get a line of input from the IPython frontend. +getInputLine :: IO String +getInputLine = do + StdinChannel req rep <- readMVar stdinInterface + + -- Send a request for input. + uuid <- UUID.random + dir <- getIHaskellDir + parentHeader <- read <$> readFile (dir ++ "/.last-req-header") + let header = MessageHeader { + username = username parentHeader, + identifiers = identifiers parentHeader, + parentHeader = Just parentHeader, + messageId = uuid, + sessionId = sessionId parentHeader, + metadata = Map.fromList [], + msgType = InputRequestMessage + } + let msg = RequestInput header "" + writeChan req msg + + -- Get the reply. + InputReply _ value <- readChan rep + hPrint stderr value + return value + +recordParentHeader :: MessageHeader -> IO () +recordParentHeader header = do + dir <- getIHaskellDir + writeFile (dir ++ "/.last-req-header") $ show header + +recordKernelProfile :: Profile -> IO () +recordKernelProfile profile = do + dir <- getIHaskellDir + writeFile (dir ++ "/.kernel-profile") $ show profile diff --git a/src/IHaskell/Message/Parser.hs b/src/IHaskell/Message/Parser.hs index 27b1aca6..ca3997f1 100644 --- a/src/IHaskell/Message/Parser.hs +++ b/src/IHaskell/Message/Parser.hs @@ -77,6 +77,7 @@ parser ExecuteRequestMessage = executeRequestParser parser CompleteRequestMessage = completeRequestParser parser ObjectInfoRequestMessage = objectInfoRequestParser parser ShutdownRequestMessage = shutdownRequestParser +parser InputReplyMessage = inputReplyParser parser other = error $ "Unknown message type " ++ show other -- | Parse a kernel info request. @@ -141,3 +142,12 @@ shutdownRequestParser content = parsed return $ ShutdownRequest noHeader code Just decoded = decode content + +inputReplyParser :: LByteString -> Message +inputReplyParser content = parsed + where + Success parsed = flip parse decoded $ \ obj -> do + value <- obj .: "value" + return $ InputReply noHeader value + + Just decoded = decode content diff --git a/src/IHaskell/Message/UUID.hs b/src/IHaskell/Message/UUID.hs index 38070578..3c4823ed 100644 --- a/src/IHaskell/Message/UUID.hs +++ b/src/IHaskell/Message/UUID.hs @@ -12,6 +12,10 @@ import Control.Monad (mzero) import Data.Aeson import Data.UUID.V4 (nextRandom) +import Text.Read as Read hiding (pfail, String) +import Text.ParserCombinators.ReadP + + -- We use an internal string representation because for the purposes of -- IPython, it matters whether the letters are uppercase or lowercase and -- whether the dashes are present in the correct locations. For the @@ -20,10 +24,7 @@ import Data.UUID.V4 (nextRandom) -- them. -- | A UUID (universally unique identifier). -data UUID = UUID String deriving Eq - -instance Show UUID where - show (UUID s) = s +data UUID = UUID String deriving (Show, Read, Eq) -- | Generate a list of random UUIDs. randoms :: Int -- ^ Number of UUIDs to generate. diff --git a/src/IHaskell/Message/Writer.hs b/src/IHaskell/Message/Writer.hs index f4ab7c5b..095cf524 100644 --- a/src/IHaskell/Message/Writer.hs +++ b/src/IHaskell/Message/Writer.hs @@ -80,6 +80,10 @@ instance ToJSON Message where "wait" .= wait ] + toJSON RequestInput{inputPrompt = prompt} = object [ + "prompt" .= prompt + ] + toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index 08a22e92..f41fcd98 100644 --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -7,7 +7,7 @@ module IHaskell.Types ( MessageHeader (..), MessageType(..), Username, - Metadata, + Metadata(..), Port, replyType, ExecutionState (..), @@ -43,7 +43,7 @@ data Profile = Profile { shellPort :: Port, -- ^ The shell command port. iopubPort :: Port, -- ^ The Iopub port. key :: ByteString -- ^ The HMAC encryption key. - } deriving Show + } deriving (Show, Read) -- Convert the kernel profile to and from JSON. instance FromJSON Profile where @@ -112,7 +112,7 @@ data MessageHeader = MessageHeader { sessionId :: UUID, -- ^ A unique session UUID. username :: Username, -- ^ The user who sent this message. msgType :: MessageType -- ^ The message type. - } deriving Show + } deriving (Show, Read) -- Convert a message header into the JSON field for the header. -- This field does not actually have all the record fields. @@ -121,7 +121,7 @@ instance ToJSON MessageHeader where "msg_id" .= messageId header, "session" .= sessionId header, "username" .= username header, - "msg_type" .= show (msgType header) + "msg_type" .= showMessageType (msgType header) ] -- | A username for the source of a message. @@ -147,24 +147,29 @@ data MessageType = KernelInfoReplyMessage | ShutdownRequestMessage | ShutdownReplyMessage | ClearOutputMessage + | InputRequestMessage + | InputReplyMessage + deriving (Show, Read) -instance Show MessageType where - show KernelInfoReplyMessage = "kernel_info_reply" - show KernelInfoRequestMessage = "kernel_info_request" - show ExecuteReplyMessage = "execute_reply" - show ExecuteRequestMessage = "execute_request" - show StatusMessage = "status" - show StreamMessage = "stream" - show DisplayDataMessage = "display_data" - show OutputMessage = "pyout" - show InputMessage = "pyin" - show CompleteRequestMessage = "complete_request" - show CompleteReplyMessage = "complete_reply" - show ObjectInfoRequestMessage = "object_info_request" - show ObjectInfoReplyMessage = "object_info_reply" - show ShutdownRequestMessage = "shutdown_request" - show ShutdownReplyMessage = "shutdown_reply" - show ClearOutputMessage = "clear_output" +showMessageType :: MessageType -> String +showMessageType KernelInfoReplyMessage = "kernel_info_reply" +showMessageType KernelInfoRequestMessage = "kernel_info_request" +showMessageType ExecuteReplyMessage = "execute_reply" +showMessageType ExecuteRequestMessage = "execute_request" +showMessageType StatusMessage = "status" +showMessageType StreamMessage = "stream" +showMessageType DisplayDataMessage = "display_data" +showMessageType OutputMessage = "pyout" +showMessageType InputMessage = "pyin" +showMessageType CompleteRequestMessage = "complete_request" +showMessageType CompleteReplyMessage = "complete_reply" +showMessageType ObjectInfoRequestMessage = "object_info_request" +showMessageType ObjectInfoReplyMessage = "object_info_reply" +showMessageType ShutdownRequestMessage = "shutdown_request" +showMessageType ShutdownReplyMessage = "shutdown_reply" +showMessageType ClearOutputMessage = "clear_output" +showMessageType InputRequestMessage = "input_request" +showMessageType InputReplyMessage = "input_reply" instance FromJSON MessageType where parseJSON (String s) = case s of @@ -184,6 +189,8 @@ instance FromJSON MessageType where "shutdown_request" -> return ShutdownRequestMessage "shutdown_reply" -> return ShutdownReplyMessage "clear_output" -> return ClearOutputMessage + "input_request" -> return InputRequestMessage + "input_reply" -> return InputReplyMessage _ -> fail ("Unknown message type: " ++ show s) parseJSON _ = fail "Must be a string." @@ -294,6 +301,16 @@ data Message wait :: Bool -- ^ Whether to wait to redraw until there is more output. } + | RequestInput { + header :: MessageHeader, + inputPrompt :: String + } + + | InputReply { + header :: MessageHeader, + inputValue :: String + } + deriving Show -- | Possible statuses in the execution reply messages. diff --git a/src/IHaskell/ZeroMQ.hs b/src/IHaskell/ZeroMQ.hs index d9ceb15e..2f32ec55 100644 --- a/src/IHaskell/ZeroMQ.hs +++ b/src/IHaskell/ZeroMQ.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} -- | Description : Low-level ZeroMQ communication wrapper. -- -- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, @@ -6,7 +6,9 @@ -- takes a IPython profile specification and returns the channel interface to use. module IHaskell.ZeroMQ ( ZeroMQInterface (..), - serveProfile + ZeroMQStdin(..), + serveProfile, + serveStdin, ) where import ClassyPrelude hiding (stdin) @@ -20,6 +22,8 @@ import IHaskell.Types import IHaskell.Message.Parser import IHaskell.Message.Writer +import System.IO.Unsafe + -- | The channel interface to the ZeroMQ sockets. All communication is done via -- Messages, which are encoded and decoded into a lower level form before being -- transmitted to IPython. These channels should functionally serve as @@ -34,6 +38,11 @@ data ZeroMQInterface = Channels { iopubChannel :: Chan Message -- ^ Writing to this channel sends an iopub message to the frontend. } +data ZeroMQStdin = StdinChannel { + stdinRequestChannel :: Chan Message, + stdinReplyChannel :: Chan Message + } + -- | Start responding on all ZeroMQ channels used to communicate with IPython -- | via the provided profile. Return a set of channels which can be used to -- | communicate with IPython in a more structured manner. @@ -55,7 +64,6 @@ serveProfile profile = do forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels forkIO $ serveSocket context Router (controlPort profile) $ control channels forkIO $ serveSocket context Router (shellPort profile) $ shell channels - forkIO $ serveSocket context Router (stdinPort profile) $ stdin channels -- The context is reference counted in this thread only. Thus, the last -- serveSocket cannot be asynchronous, because otherwise context would @@ -65,6 +73,24 @@ serveProfile profile = do return channels +serveStdin :: Profile -> IO ZeroMQStdin +serveStdin profile = do + reqChannel <- newChan + repChannel <- newChan + + -- Create the context in a separate thread that never finishes. If + -- withContext or withSocket complete, the context or socket become invalid. + forkIO $ withContext $ \context -> + -- Serve on all sockets. + serveSocket context Router (stdinPort profile) $ \socket -> do + -- Read the request from the interface channel and send it. + readChan reqChannel >>= sendMessage socket + + -- Receive a response and write it to the interface channel. + receiveMessage socket >>= writeChan repChannel + + return $ StdinChannel reqChannel repChannel + -- | Serve on a given socket in a separate thread. Bind the socket in the -- | given context and then loop the provided action, which should listen -- | on the socket and respond to any events. @@ -120,11 +146,6 @@ iopub :: ZeroMQInterface -> Socket Pub -> IO () iopub channels socket = readChan (iopubChannel channels) >>= sendMessage socket -stdin :: ZeroMQInterface -> Socket Router -> IO () -stdin _ socket = do - void $ receive socket - return () - -- | Receive and parse a message from a socket. receiveMessage :: Receiver a => Socket a -> IO Message receiveMessage socket = do diff --git a/src/Main.hs b/src/Main.hs index cde0ba29..ed7ebaf9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,6 +24,7 @@ import IHaskell.Eval.Completion (complete) import IHaskell.Eval.Info import qualified Data.ByteString.Char8 as Chars import IHaskell.IPython +import qualified IHaskell.Eval.Stdin as Stdin import GHC hiding (extensions) import Outputable (showSDoc, ppr) @@ -218,6 +219,9 @@ runKernel profileSrc initInfo = do -- Parse the profile file. Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc + -- Necessary for `getLine` and their ilk to work. + Stdin.recordKernelProfile profile + -- Serve on all sockets and ports defined in the profile. interface <- serveProfile profile @@ -289,7 +293,8 @@ replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpr -- Reply to kernel info requests with a kernel info reply. No computation -- needs to be done, as a kernel info reply is a static object (all info is -- hard coded into the representation of that message type). -replyTo _ KernelInfoRequest{} replyHeader state = return (state, KernelInfoReply { header = replyHeader }) +replyTo _ KernelInfoRequest{} replyHeader state = + return (state, KernelInfoReply { header = replyHeader }) -- Reply to a shutdown request by exiting the main thread. -- Before shutdown, reply to the request to let the frontend know shutdown @@ -301,10 +306,13 @@ replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ -- Reply to an execution request. The reply itself does not require -- computation, but this causes messages to be sent to the IOPub socket -- with the output of the code in the execution request. -replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do +replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do -- Convenience function to send a message to the IOPub socket. let send msg = liftIO $ writeChan (iopubChannel interface) msg + -- Log things so that we can use stdin. + liftIO $ Stdin.recordParentHeader $ header req + -- Notify the frontend that the kernel is busy computing. -- All the headers are copies of the reply header with a different -- message type, because this preserves the session ID, parent header,