diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2013 Andrew Gibiansky + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/ipython-kernel.cabal b/ipython-kernel.cabal new file mode 100644 --- /dev/null +++ b/ipython-kernel.cabal @@ -0,0 +1,37 @@ +name: ipython-kernel +version: 0.1.0.0 +synopsis: A library for creating kernels for IPython frontends + +description: ipython-kernel is a library for communicating with frontends for the interactive IPython framework. It is used extensively in IHaskell, the interactive Haskell environment. +homepage: http://github.com/gibiansky/IHaskell +license: MIT +license-file: LICENSE +author: Andrew Gibiansky +maintainer: andrew.gibiansky@gmail.com + +category: Development +build-type: Simple + +cabal-version: >=1.16 + +library + exposed-modules: IPython.Kernel + IPython.Types + IPython.ZeroMQ + IPython.Stdin + IPython.Message.Writer + IPython.Message.Parser + IPython.Message.UUID + -- other-modules: + other-extensions: OverloadedStrings + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >=4.6 && <4.7, + aeson >=0.6 && <0.7, + bytestring >=0.10, + cereal ==0.3.*, + containers >=0.5, + text >=0.11, + unix >=2.6, + uuid >=1.3, + zeromq4-haskell >=0.1 diff --git a/src/IPython/Kernel.hs b/src/IPython/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/IPython/Kernel.hs @@ -0,0 +1,16 @@ +-- | This module exports all the types and functions necessary to create an +-- IPython language kernel that supports the @ipython console@ and @ipython +-- notebook@ frontends. +module IPython.Kernel ( + module IPython.Types, + module IPython.Message.Writer, + module IPython.Message.Parser, + module IPython.Message.UUID, + module IPython.ZeroMQ, + ) where + +import IPython.Types +import IPython.Message.Writer +import IPython.Message.Parser +import IPython.Message.UUID +import IPython.ZeroMQ diff --git a/src/IPython/Message/Parser.hs b/src/IPython/Message/Parser.hs new file mode 100644 --- /dev/null +++ b/src/IPython/Message/Parser.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Description : Parsing messages received from IPython +-- +-- This module is responsible for converting from low-level ByteStrings +-- obtained from the 0MQ sockets into Messages. The only exposed function is +-- `parseMessage`, which should only be used in the low-level 0MQ interface. +module IPython.Message.Parser (parseMessage) where + +import Data.Aeson ((.:), decode, Result(..), Object) +import Control.Applicative ((<|>)) +import Data.Aeson.Types (parse) +import Data.ByteString +import qualified Data.ByteString.Lazy as Lazy +import Data.Map (Map) + +import IPython.Types + +type LByteString = Lazy.ByteString + +----- External interface ----- + +-- | Parse a message from its ByteString components into a Message. +parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message. + -> ByteString -- ^ The header data. + -> ByteString -- ^ The parent header, which is just "{}" if there is no header. + -> ByteString -- ^ The metadata map, also "{}" for an empty map. + -> ByteString -- ^ The message content. + -> Message -- ^ A parsed message. +parseMessage idents headerData parentHeader metadata content = + let header = parseHeader idents headerData parentHeader metadata + messageType = msgType header + messageWithoutHeader = parser messageType $ Lazy.fromStrict content in + messageWithoutHeader { header = header } + +----- Module internals ----- + +-- | Parse a header from its ByteString components into a MessageHeader. +parseHeader :: [ByteString] -- ^ The list of identifiers. + -> ByteString -- ^ The header data. + -> ByteString -- ^ The parent header, or "{}" for Nothing. + -> ByteString -- ^ The metadata, or "{}" for an empty map. + -> MessageHeader -- The resulting message header. +parseHeader idents headerData parentHeader metadata = MessageHeader { + identifiers = idents, + parentHeader = parentResult, + metadata = metadataMap, + messageId = messageUUID, + sessionId = sessionUUID, + username = username, + msgType = messageType + } where + -- Decode the header data and the parent header data into JSON objects. + -- If the parent header data is absent, just have Nothing instead. + Just result = decode $ Lazy.fromStrict headerData :: Maybe Object + parentResult = if parentHeader == "{}" + then Nothing + else Just $ parseHeader idents parentHeader "{}" metadata + + -- Get the basic fields from the header. + Success (messageType, username, messageUUID, sessionUUID) = flip parse result $ \obj -> do + messType <- obj .: "msg_type" + username <- obj .: "username" + message <- obj .: "msg_id" + session <- obj .: "session" + return (messType, username, message, session) + + -- Get metadata as a simple map. + Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map ByteString ByteString) + +noHeader :: MessageHeader +noHeader = error "No header created" + +parser :: MessageType -- ^ The message type being parsed. + -> LByteString -> Message -- The parser that converts the body into a message. + -- This message should have an undefined + -- header. +parser KernelInfoRequestMessage = kernelInfoRequestParser +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. +-- A kernel info request has no auxiliary information, so ignore the body. +kernelInfoRequestParser :: LByteString -> Message +kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader } + +-- | Parse an execute request. +-- Fields used are: +-- 1. "code": the code to execute. +-- 2. "silent": whether to execute silently. +-- 3. "store_history": whether to include this in history. +-- 4. "allow_stdin": whether to allow reading from stdin for this code. +executeRequestParser :: LByteString -> Message +executeRequestParser content = + let parser obj = do + code <- obj .: "code" + silent <- obj .: "silent" + storeHistory <- obj .: "store_history" + allowStdin <- obj .: "allow_stdin" + + return (code, silent, storeHistory, allowStdin) + Just decoded = decode content + Success (code, silent, storeHistory, allowStdin) = parse parser decoded in + ExecuteRequest { + header = noHeader, + getCode = code, + getSilent = silent, + getAllowStdin = allowStdin, + getStoreHistory = storeHistory, + getUserVariables = [], + getUserExpressions = [] + } + +completeRequestParser :: LByteString -> Message +completeRequestParser content = parsed + where + Success parsed = flip parse decoded $ \ obj -> do + code <- obj .: "block" <|> return "" + codeLine <- obj .: "line" + pos <- obj .: "cursor_pos" + return $ CompleteRequest noHeader code codeLine pos + + Just decoded = decode content + +objectInfoRequestParser :: LByteString -> Message +objectInfoRequestParser content = parsed + where + Success parsed = flip parse decoded $ \obj -> do + oname <- obj .: "oname" + dlevel <- obj .: "detail_level" + return $ ObjectInfoRequest noHeader oname dlevel + + Just decoded = decode content + + +shutdownRequestParser :: LByteString -> Message +shutdownRequestParser content = parsed + where + Success parsed = flip parse decoded $ \ obj -> do + code <- obj .: "restart" + 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/IPython/Message/UUID.hs b/src/IPython/Message/UUID.hs new file mode 100644 --- /dev/null +++ b/src/IPython/Message/UUID.hs @@ -0,0 +1,46 @@ +-- | Description : UUID generator and data structure +-- +-- Generate, parse, and pretty print UUIDs for use with IPython. +module IPython.Message.UUID ( + UUID, + random, randoms, + ) where + +import Control.Monad (mzero, replicateM) +import Control.Applicative ((<$>)) +import Data.Text (pack) +import Data.Aeson +import Data.UUID.V4 (nextRandom) + +import Text.Read as Read hiding (pfail, String) + + +-- 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 +-- purposes of new UUIDs, it does not matter, but IPython expects UUIDs +-- passed to kernels to be returned unchanged, so we cannot actually parse +-- them. + +-- | A UUID (universally unique identifier). +data UUID = UUID String deriving (Show, Read, Eq) + +-- | Generate a list of random UUIDs. +randoms :: Int -- ^ Number of UUIDs to generate. + -> IO [UUID] +randoms n = replicateM n random + +-- | Generate a single random UUID. +random :: IO UUID +random = UUID <$> show <$> nextRandom + +-- Allows reading and writing UUIDs as Strings in JSON. +instance FromJSON UUID where + parseJSON val@(String _) = UUID <$> parseJSON val + + -- UUIDs must be Strings. + parseJSON _ = mzero + +instance ToJSON UUID where + -- Extract the string from the UUID. + toJSON (UUID str) = String $ pack str diff --git a/src/IPython/Message/Writer.hs b/src/IPython/Message/Writer.hs new file mode 100644 --- /dev/null +++ b/src/IPython/Message/Writer.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Description : @ToJSON@ for Messages +-- +-- This module contains the @ToJSON@ instance for @Message@. +module IPython.Message.Writer ( + ToJSON(..) +) where + +import Data.Aeson +import Data.Map (Map) +import Data.Text (Text, pack) +import Data.Monoid (mempty) + + +import IPython.Types + +-- Convert message bodies into JSON. +instance ToJSON Message where + toJSON KernelInfoReply{ versionList = vers, language = language } = object [ + "protocol_version" .= ints [4, 0], -- current protocol version, major and minor + "language_version" .= vers, + "language" .= language + ] + + toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [ + "status" .= show status, + "execution_count" .= counter, + "payload" .= + if null pager + then [] + else [object [ + "source" .= string "page", + "text" .= pager + ]], + "user_variables" .= emptyMap, + "user_expressions" .= emptyMap + ] + toJSON PublishStatus{ executionState = executionState } = object [ + "execution_state" .= executionState + ] + toJSON PublishStream{ streamType = streamType, streamContent = content } = object [ + "data" .= content, + "name" .= streamType + ] + toJSON PublishDisplayData{ source = src, displayData = datas } = object [ + "source" .= src, + "metadata" .= object [], + "data" .= object (map displayDataToJson datas) + ] + + toJSON PublishOutput{ executionCount = execCount, reprText = reprText } = object [ + "data" .= object ["text/plain" .= reprText], + "execution_count" .= execCount, + "metadata" .= object [] + ] + toJSON PublishInput{ executionCount = execCount, inCode = code } = object [ + "execution_count" .= execCount, + "code" .= code + ] + toJSON (CompleteReply _ m mt t s) = object [ + "matches" .= m, + "matched_text" .= mt, + "text" .= t, + "status" .= if s then string "ok" else "error" + ] + toJSON o@ObjectInfoReply{} = object [ + "oname" .= objectName o, + "found" .= objectFound o, + "ismagic" .= False, + "isalias" .= False, + "type_name" .= objectTypeString o, + "docstring" .= objectDocString o + ] + + toJSON ShutdownReply{restartPending = restart} = object [ + "restart" .= restart + ] + + toJSON ClearOutput{wait = wait} = object [ + "wait" .= wait + ] + + toJSON RequestInput{inputPrompt = prompt} = object [ + "prompt" .= prompt + ] + + + toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body + + +-- | Print an execution state as "busy", "idle", or "starting". +instance ToJSON ExecutionState where + toJSON Busy = String "busy" + toJSON Idle = String "idle" + toJSON Starting = String "starting" + +-- | Print a stream as "stdin" or "stdout" strings. +instance ToJSON StreamType where + toJSON Stdin = String "stdin" + toJSON Stdout = String "stdout" + +-- | Convert a MIME type and value into a JSON dictionary pair. +displayDataToJson :: DisplayData -> (Text, Value) +displayDataToJson (DisplayData mimeType dataStr) = pack (show mimeType) .= dataStr + +----- Constants ----- + +emptyMap :: Map String String +emptyMap = mempty + +emptyList :: [Int] +emptyList = [] + +ints :: [Int] -> [Int] +ints = id + +string :: String -> String +string = id diff --git a/src/IPython/Stdin.hs b/src/IPython/Stdin.hs new file mode 100644 --- /dev/null +++ b/src/IPython/Stdin.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-} +-- | This module provides a way in which the Haskell standard input may be +-- forwarded to the IPython frontend and thus allows the notebook to use +-- the standard input. +-- +-- This relies on the implementation of file handles in GHC, and is +-- generally unsafe and terrible. However, it is difficult to find another +-- way to do it, as file handles are generally meant to point to streams +-- and files, and not networked communication protocols. +-- +-- In order to use this module, it must first be initialized with two +-- things. First of all, in order to know how to communicate with the +-- IPython frontend, it must know the kernel profile used for +-- communication. For this, use @recordKernelProfile@ once the profile is +-- known. Both this and @recordParentHeader@ take a directory name where +-- they can store this data. +-- +-- Finally, the module must know what @execute_request@ message is +-- currently being replied to (which will request the input). Thus, every +-- time the language kernel receives an @execute_request@ message, it +-- should inform this module via @recordParentHeader@, so that the module +-- may generate messages with an appropriate parent header set. If this is +-- not done, the IPython frontends will not recognize the target of the +-- communication. +-- +-- Finally, in order to activate this module, @fixStdin@ must be called +-- once. It must be passed the same directory name as @recordParentHeader@ +-- and @recordKernelProfile@. Note that if this is being used from within +-- the GHC API, @fixStdin@ /must/ be called from within the GHC session +-- not from the host code. +module IPython.Stdin ( + fixStdin, + recordParentHeader, + recordKernelProfile + ) where + +import Control.Concurrent +import Control.Applicative ((<$>)) +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 IPython.Types +import IPython.ZeroMQ +import IPython.Message.UUID as UUID + +stdinInterface :: MVar ZeroMQStdin +{-# NOINLINE stdinInterface #-} +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 :: String -> IO () +fixStdin dir = do + -- Initialize the stdin interface. + profile <- read <$> readFile (dir ++ "/.kernel-profile") + interface <- serveStdin profile + putMVar stdinInterface interface + void $ forkIO $ stdinOnce dir + +stdinOnce :: String -> IO () +stdinOnce dir = 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 dir + hPutStr stdinInput $ line ++ "\n" + loop stdinInput oldStdin newStdin + +-- | Get a line of input from the IPython frontend. +getInputLine :: String -> IO String +getInputLine dir = do + StdinChannel req rep <- readMVar stdinInterface + + -- Send a request for input. + uuid <- UUID.random + 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 + return value + +recordParentHeader :: String -> MessageHeader -> IO () +recordParentHeader dir header = + writeFile (dir ++ "/.last-req-header") $ show header + +recordKernelProfile :: String -> Profile -> IO () +recordKernelProfile dir profile = + writeFile (dir ++ "/.kernel-profile") $ show profile diff --git a/src/IPython/Types.hs b/src/IPython/Types.hs new file mode 100644 --- /dev/null +++ b/src/IPython/Types.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-} +-- | This module contains all types used to create an IPython language +-- kernel. +module IPython.Types ( + -- * IPython kernel profile + Profile(..), + Transport(..), + Port(..), + IP(..), + + -- * IPython messaging protocol + Message(..), + MessageHeader(..), + Username(..), + Metadata(..), + MessageType(..), + Width(..), Height(..), + StreamType(..), + ExecutionState(..), + ExecuteReplyStatus(..), + replyType, + + -- ** IPython display data message + DisplayData(..), + MimeType(..), + extractPlain + + ) where + +import Data.Aeson +import Control.Applicative ((<$>), (<*>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as Char +import qualified Data.Text as Text +import Data.Serialize +import IPython.Message.UUID +import GHC.Generics (Generic) +import Data.Typeable +import Data.List (find) +import Data.Map (Map) + +-------------------- IPython Kernel Profile Types ---------------------- +-- | A TCP port. +type Port = Int + +-- | An IP address. +type IP = String + +-- | The transport mechanism used to communicate with the IPython frontend. +data Transport + = TCP -- ^ Default transport mechanism via TCP. + deriving (Show, Read) + +-- | A kernel profile, specifying how the kernel communicates. +data Profile = Profile { + ip :: IP, -- ^ The IP on which to listen. + transport :: Transport, -- ^ The transport mechanism. + stdinPort :: Port, -- ^ The stdin channel port. + controlPort :: Port, -- ^ The control channel port. + hbPort :: Port, -- ^ The heartbeat channel port. + shellPort :: Port, -- ^ The shell command port. + iopubPort :: Port, -- ^ The IOPub port. + key :: ByteString -- ^ The HMAC encryption key. + } deriving (Show, Read) + +-- Convert the kernel profile to and from JSON. +instance FromJSON Profile where + parseJSON (Object v) = + Profile <$> v .: "ip" + <*> v .: "transport" + <*> v .: "stdin_port" + <*> v .: "control_port" + <*> v .: "hb_port" + <*> v .: "shell_port" + <*> v .: "iopub_port" + <*> v .: "key" + parseJSON _ = fail "Expecting JSON object." + +instance ToJSON Profile where + toJSON profile = object [ + "ip" .= ip profile, + "transport" .= transport profile, + "stdin_port" .= stdinPort profile, + "control_port".= controlPort profile, + "hb_port" .= hbPort profile, + "shell_port" .= shellPort profile, + "iopub_port" .= iopubPort profile, + "key" .= key profile + ] + +instance FromJSON Transport where + parseJSON (String str) = do + let mech = Text.unpack str + case mech of + "tcp" -> return TCP + _ -> fail $ "Unknown transport mechanism " ++ mech + parseJSON _ = fail "Expected JSON string as transport." + +instance ToJSON Transport where + toJSON TCP = String "tcp" + + +-------------------- IPython Message Types ---------------------- + +-- | A message header with some metadata. +data MessageHeader = MessageHeader { + identifiers :: [ByteString], -- ^ The identifiers sent with the message. + parentHeader :: Maybe MessageHeader, -- ^ The parent header, if present. + metadata :: Metadata, -- ^ A dict of metadata. + messageId :: UUID, -- ^ A unique message UUID. + sessionId :: UUID, -- ^ A unique session UUID. + username :: Username, -- ^ The user who sent this message. + msgType :: MessageType -- ^ The message type. + } deriving (Show, Read) + +-- Convert a message header into the JSON field for the header. +-- This field does not actually have all the record fields. +instance ToJSON MessageHeader where + toJSON header = object [ + "msg_id" .= messageId header, + "session" .= sessionId header, + "username" .= username header, + "msg_type" .= showMessageType (msgType header) + ] + +-- | A username for the source of a message. +type Username = ByteString + +-- | A metadata dictionary. +type Metadata = Map ByteString ByteString + +-- | The type of a message, corresponding to IPython message types. +data MessageType = KernelInfoReplyMessage + | KernelInfoRequestMessage + | ExecuteReplyMessage + | ExecuteRequestMessage + | StatusMessage + | StreamMessage + | DisplayDataMessage + | OutputMessage + | InputMessage + | CompleteRequestMessage + | CompleteReplyMessage + | ObjectInfoRequestMessage + | ObjectInfoReplyMessage + | ShutdownRequestMessage + | ShutdownReplyMessage + | ClearOutputMessage + | InputRequestMessage + | InputReplyMessage + deriving (Show, Read) + +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 + "kernel_info_reply" -> return KernelInfoReplyMessage + "kernel_info_request" -> return KernelInfoRequestMessage + "execute_reply" -> return ExecuteReplyMessage + "execute_request" -> return ExecuteRequestMessage + "status" -> return StatusMessage + "stream" -> return StreamMessage + "display_data" -> return DisplayDataMessage + "pyout" -> return OutputMessage + "pyin" -> return InputMessage + "complete_request" -> return CompleteRequestMessage + "complete_reply" -> return CompleteReplyMessage + "object_info_request" -> return ObjectInfoRequestMessage + "object_info_reply" -> return ObjectInfoReplyMessage + "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." + + +-- | A message used to communicate with the IPython frontend. +data Message + -- | A request from a frontend for information about the kernel. + = KernelInfoRequest { header :: MessageHeader } + -- | A response to a KernelInfoRequest. + | KernelInfoReply { + header :: MessageHeader, + versionList :: [Int], -- ^ The version of the language, e.g. [7, 6, 3] for GHC 7.6.3 + language :: String -- ^ The language name, e.g. "haskell" + } + + -- | A request from a frontend to execute some code. + | ExecuteRequest { + header :: MessageHeader, + getCode :: ByteString, -- ^ The code string. + getSilent :: Bool, -- ^ Whether this should be silently executed. + getStoreHistory :: Bool, -- ^ Whether to store this in history. + getAllowStdin :: Bool, -- ^ Whether this code can use stdin. + + getUserVariables :: [ByteString], -- ^ Unused. + getUserExpressions :: [ByteString] -- ^ Unused. + } + + -- | A reply to an execute request. + | ExecuteReply { + header :: MessageHeader, + status :: ExecuteReplyStatus, -- ^ The status of the output. + pagerOutput :: String, -- ^ The help string to show in the pager. + executionCounter :: Int -- ^ The execution count, i.e. which output this is. + } + + | PublishStatus { + header :: MessageHeader, + executionState :: ExecutionState -- ^ The execution state of the kernel. + } + + | PublishStream { + header :: MessageHeader, + streamType :: StreamType, -- ^ Which stream to publish to. + streamContent :: String -- ^ What to publish. + } + + | PublishDisplayData { + header :: MessageHeader, + source :: String, -- ^ The name of the data source. + displayData :: [DisplayData] -- ^ A list of data representations. + } + + | PublishOutput { + header :: MessageHeader, + reprText :: String, -- ^ Printed output text. + executionCount :: Int -- ^ Which output this is for. + } + + | PublishInput { + header :: MessageHeader, + inCode :: String, -- ^ Submitted input code. + executionCount :: Int -- ^ Which input this is. + } + + | CompleteRequest { + header :: MessageHeader, + getCode :: ByteString, {- ^ + The entire block of text where the line is. This may be useful in the + case of multiline completions where more context may be needed. Note: if + in practice this field proves unnecessary, remove it to lighten the + messages. json field @block@ -} + getCodeLine :: ByteString, -- ^ just the line with the cursor. json field @line@ + getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@ + + } + + | CompleteReply { + header :: MessageHeader, + completionMatches :: [ByteString], + completionMatchedText :: ByteString, + completionText :: ByteString, + completionStatus :: Bool + } + + | ObjectInfoRequest { + header :: MessageHeader, + objectName :: ByteString, -- ^ Name of object being searched for. + detailLevel :: Int -- ^ Level of detail desired (defaults to 0). + -- 0 is equivalent to foo?, 1 is equivalent + -- to foo??. + } + + | ObjectInfoReply { + header :: MessageHeader, + objectName :: ByteString, -- ^ Name of object which was searched for. + objectFound :: Bool, -- ^ Whether the object was found. + objectTypeString :: ByteString, -- ^ Object type. + objectDocString :: ByteString + } + + | ShutdownRequest { + header :: MessageHeader, + restartPending :: Bool -- ^ Whether this shutdown precedes a restart. + } + | ShutdownReply { + header :: MessageHeader, + restartPending :: Bool -- ^ Whether this shutdown precedes a restart. + } + + | ClearOutput { + header :: MessageHeader, + 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. +data ExecuteReplyStatus = Ok | Err | Abort + +instance Show ExecuteReplyStatus where + show Ok = "ok" + show Err = "error" + show Abort = "abort" + +-- | The execution state of the kernel. +data ExecutionState = Busy | Idle | Starting deriving Show + +-- | Input and output streams. +data StreamType = Stdin | Stdout deriving Show + +-- | Get the reply message type for a request message type. +replyType :: MessageType -> Maybe MessageType +replyType KernelInfoRequestMessage = Just KernelInfoReplyMessage +replyType ExecuteRequestMessage = Just ExecuteReplyMessage +replyType CompleteRequestMessage = Just CompleteReplyMessage +replyType ObjectInfoRequestMessage = Just ObjectInfoReplyMessage +replyType ShutdownRequestMessage = Just ShutdownReplyMessage +replyType _ = Nothing + +-- | Data for display: a string with associated MIME type. +data DisplayData = DisplayData MimeType ByteString deriving (Typeable, Generic) + +-- We can't print the actual data, otherwise this will be printed every +-- time it gets computed because of the way the evaluator is structured. +-- See how `displayExpr` is computed. +instance Show DisplayData where + show _ = "DisplayData" + +-- Allow DisplayData serialization +instance Serialize DisplayData +instance Serialize MimeType + +-- | Possible MIME types for the display data. +type Width = Int +type Height = Int +data MimeType = PlainText + | MimeHtml + | MimePng Width Height + | MimeJpg Width Height + | MimeSvg + | MimeLatex + deriving (Eq, Typeable, Generic) + +-- Extract the plain text from a list of displays. +extractPlain :: [DisplayData] -> String +extractPlain disps = + case find isPlain disps of + Nothing -> "" + Just (DisplayData PlainText bytestr) -> Char.unpack bytestr + where + isPlain (DisplayData mime _) = mime == PlainText + +instance Show MimeType where + show PlainText = "text/plain" + show MimeHtml = "text/html" + show (MimePng _ _) = "image/png" + show (MimeJpg _ _) = "image/jpeg" + show MimeSvg = "image/svg+xml" + show MimeLatex = "text/latex" diff --git a/src/IPython/ZeroMQ.hs b/src/IPython/ZeroMQ.hs new file mode 100644 --- /dev/null +++ b/src/IPython/ZeroMQ.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-} +-- | Description : Low-level ZeroMQ communication wrapper. +-- +-- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, +-- replacing it instead with a Haskell Channel based interface. The `serveProfile` function +-- takes a IPython profile specification and returns the channel interface to use. +module IPython.ZeroMQ ( + ZeroMQInterface (..), + ZeroMQStdin(..), + serveProfile, + serveStdin, + ) where + +import qualified Data.ByteString.Lazy as ByteString +import Data.ByteString (ByteString) +import Control.Concurrent +import Control.Monad +import System.IO.Unsafe +import Data.Aeson (encode) +import System.ZMQ4 hiding (stdin) + +import IPython.Types +import IPython.Message.Parser +import IPython.Message.Writer + +-- | 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 +-- high-level sockets which speak Messages instead of ByteStrings. +data ZeroMQInterface = Channels { + shellRequestChannel :: Chan Message, -- ^ A channel populated with requests from the frontend. + shellReplyChannel :: Chan Message, -- ^ Writing to this channel causes a reply to be sent to the frontend. + controlRequestChannel :: Chan Message, -- ^ This channel is a duplicate of the shell request channel, + -- ^ though using a different backend socket. + controlReplyChannel :: Chan Message, -- ^ This channel is a duplicate of the shell reply channel, + -- ^ though using a different backend socket. + 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. +serveProfile :: Profile -- ^ The profile specifying which ports and transport mechanisms to use. + -> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets. +serveProfile profile = do + -- Create all channels which will be used for higher level communication. + shellReqChan <- newChan + shellRepChan <- newChan + controlReqChan <- dupChan shellReqChan + controlRepChan <- dupChan shellRepChan + iopubChan <- newChan + let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan + + -- Create the context in a separate thread that never finishes. If + -- withContext or withSocket complete, the context or socket become invalid. + forkIO $ withContext $ \context -> do + -- Serve on all sockets. + forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels + forkIO $ serveSocket context Router (controlPort profile) $ control channels + forkIO $ serveSocket context Router (shellPort profile) $ shell channels + + -- The context is reference counted in this thread only. Thus, the last + -- serveSocket cannot be asynchronous, because otherwise context would + -- be garbage collectable - since it would only be used in other + -- threads. Thus, keep the last serveSocket in this thread. + serveSocket context Pub (iopubPort profile) $ iopub channels + + 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. +serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO () +serveSocket context socketType port action = void $ + withSocket context socketType $ \socket -> do + bind socket $ "tcp://127.0.0.1:" ++ show port + forever $ action socket + +-- | Listener on the heartbeat port. Echoes back any data it was sent. +heartbeat :: ZeroMQInterface -> Socket Rep -> IO () +heartbeat _ socket = do + -- Read some data. + request <- receive socket + + -- Send it back. + send socket [] request + +-- | Listener on the shell port. Reads messages and writes them to +-- | the shell request channel. For each message, reads a response from the +-- | shell reply channel of the interface and sends it back to the frontend. +shell :: ZeroMQInterface -> Socket Router -> IO () +shell channels socket = do + -- Receive a message and write it to the interface channel. + receiveMessage socket >>= writeChan requestChannel + + -- Read the reply from the interface channel and send it. + readChan replyChannel >>= sendMessage socket + + where + requestChannel = shellRequestChannel channels + replyChannel = shellReplyChannel channels + +-- | Listener on the shell port. Reads messages and writes them to +-- | the shell request channel. For each message, reads a response from the +-- | shell reply channel of the interface and sends it back to the frontend. +control :: ZeroMQInterface -> Socket Router -> IO () +control channels socket = do + -- Receive a message and write it to the interface channel. + receiveMessage socket >>= writeChan requestChannel + + -- Read the reply from the interface channel and send it. + readChan replyChannel >>= sendMessage socket + + where + requestChannel = controlRequestChannel channels + replyChannel = controlReplyChannel channels + +-- | Send messages via the iopub channel. +-- | This reads messages from the ZeroMQ iopub interface channel +-- | and then writes the messages to the socket. +iopub :: ZeroMQInterface -> Socket Pub -> IO () +iopub channels socket = + readChan (iopubChannel channels) >>= sendMessage socket + +-- | Receive and parse a message from a socket. +receiveMessage :: Receiver a => Socket a -> IO Message +receiveMessage socket = do + -- Read all identifiers until the identifier/message delimiter. + idents <- readUntil "" + + -- Ignore the signature for now. + void next + + headerData <- next + parentHeader <- next + metadata <- next + content <- next + + let message = parseMessage idents headerData parentHeader metadata content + return message + + where + -- Receive the next piece of data from the socket. + next = receive socket + + -- Read data from the socket until we hit an ending string. + -- Return all data as a list, which does not include the ending string. + readUntil str = do + line <- next + if line /= str + then do + remaining <- readUntil str + return $ line : remaining + else return [] + +-- | Encode a message in the IPython ZeroMQ communication protocol +-- | and send it through the provided socket. +sendMessage :: Sender a => Socket a -> Message -> IO () +sendMessage socket message = do + let head = header message + parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head + idents = identifiers head + metadata = "{}" + content = encodeStrict message + headStr = encodeStrict head + + -- Send all pieces of the message. + mapM_ sendPiece idents + sendPiece "" + sendPiece "" + sendPiece headStr + sendPiece parentHeaderStr + sendPiece metadata + + -- Conclude transmission with content. + sendLast content + + where + sendPiece = send socket [SendMore] + sendLast = send socket [] + + -- Encode to a strict bytestring. + encodeStrict :: ToJSON a => a -> ByteString + encodeStrict = ByteString.toStrict . encode