diff --git a/example-data/calc_profile.tar b/example-data/calc_profile.tar
new file mode 100644
Binary files /dev/null and b/example-data/calc_profile.tar differ
diff --git a/examples/Calc.hs b/examples/Calc.hs
new file mode 100644
--- /dev/null
+++ b/examples/Calc.hs
@@ -0,0 +1,249 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, MultiWayIf #-}
+module Main where
+
+import Control.Applicative
+import Control.Arrow
+
+import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay)
+import Control.Monad (guard)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.State.Strict (StateT, get, modify, runStateT)
+
+import Data.Char (isDigit)
+import Data.List (isPrefixOf)
+import Data.Monoid ((<>))
+import qualified Data.Text as T
+
+import IHaskell.IPython.Kernel
+import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..))
+
+import System.Environment (getArgs)
+import System.FilePath (())
+
+import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, runParser, ())
+import qualified Text.Parsec.Token as P
+
+import qualified Paths_ipython_kernel as Paths
+
+---------------------------------------------------------
+-- Hutton's Razor, plus time delays, plus a global state
+---------------------------------------------------------
+
+-- | This language is Hutton's Razor with two added operations that
+-- are needed to demonstrate the kernel features: a global state,
+-- accessed and modified using Count, and a sleep operation.
+data Razor = I Integer
+ | Plus Razor Razor
+ | SleepThen Double Razor
+ | Count
+ deriving (Read, Show, Eq)
+
+
+---------
+-- Parser
+---------
+
+razorDef :: Monad m => P.GenLanguageDef String a m
+razorDef = P.LanguageDef
+ { P.commentStart = "(*"
+ , P.commentEnd = "*)"
+ , P.commentLine = "//"
+ , P.nestedComments = True
+ , P.identStart = letter <|> char '_'
+ , P.identLetter = alphaNum <|> char '_'
+ , P.opStart = oneOf "+"
+ , P.opLetter = oneOf "+"
+ , P.reservedNames = ["sleep", "then", "end", "count"]
+ , P.reservedOpNames = []
+ , P.caseSensitive = True
+ }
+
+lexer :: Monad m => P.GenTokenParser String a m
+lexer = P.makeTokenParser razorDef
+
+parens :: Parsec String a b -> Parsec String a b
+parens = P.parens lexer
+
+reserved :: String -> Parsec String a ()
+reserved = P.reserved lexer
+
+integer :: Parsec String a Integer
+integer = P.integer lexer
+
+float :: Parsec String a Double
+float = P.float lexer
+
+operator :: Parsec String a String
+operator = P.operator lexer
+
+keyword :: String -> Parsec String a ()
+keyword kwd = reserved kwd "the keyword \"" ++ kwd ++ "\""
+
+literal :: Parsec String a Razor
+literal = I <$> integer
+
+sleepThen :: Parsec String a Razor
+sleepThen = do keyword "sleep"
+ delay <- float "seconds"
+ keyword "then"
+ body <- expr
+ keyword "end" ""
+ return $ SleepThen delay body
+
+count :: Parsec String a Razor
+count = keyword "count" >> return Count
+
+expr :: Parsec String a Razor
+expr = do one <- parens expr <|> literal <|> sleepThen <|> count
+ rest <- optionMaybe (do op <- operator
+ guard (op == "+")
+ expr)
+ case rest of
+ Nothing -> return one
+ Just other -> return $ Plus one other
+
+parse :: String -> Either ParseError Razor
+parse = runParser expr () "(input)"
+
+
+----------------------
+-- Language operations
+----------------------
+
+-- | Completion
+langCompletion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)
+langCompletion _code line col =
+ let (before, _) = T.splitAt col line
+ in fmap (\word -> (map T.pack . matchesFor $ T.unpack word, word, word))
+ (lastMaybe (T.words before))
+ where
+ lastMaybe :: [a] -> Maybe a
+ lastMaybe [] = Nothing
+ lastMaybe [x] = Just x
+ lastMaybe (_:xs) = lastMaybe xs
+ matchesFor :: String -> [String]
+ matchesFor input = filter (isPrefixOf input) available
+ available = ["sleep", "then", "end", "count"] ++ map show [(-1000::Int)..1000]
+
+-- | Documentation lookup
+langInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)
+langInfo obj =
+ if | any (T.isPrefixOf obj) ["sleep", "then", "end"] ->
+ Just (obj, sleepDocs, sleepType)
+ | T.isPrefixOf obj "count" ->
+ Just (obj, countDocs, countType)
+ | obj == "+" -> Just (obj, plusDocs, plusType)
+ | T.all isDigit obj -> Just (obj, intDocs obj, intType)
+ | [x, y] <- T.splitOn "." obj,
+ T.all isDigit x,
+ T.all isDigit y -> Just (obj, floatDocs obj, floatType)
+ | otherwise -> Nothing
+ where
+ sleepDocs = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE"
+ sleepType = "sleep FLOAT then INT end"
+ plusDocs = "Perform addition"
+ plusType = "INT + INT"
+ intDocs i = "The integer " <> i
+ intType = "INT"
+ floatDocs f = "The floating point value " <> f
+ floatType = "FLOAT"
+ countDocs = "Increment and return the current counter"
+ countType = "INT"
+
+-- | Messages sent to the frontend during evaluation will be lists of trace elements
+data IntermediateEvalRes = Got Razor Integer
+ | Waiting Double
+ deriving Show
+
+-- | Cons for lists of trace elements - in this case, "sleeping"
+-- messages should replace old ones to create a countdown effect.
+consRes :: IntermediateEvalRes -> [IntermediateEvalRes] -> [IntermediateEvalRes]
+consRes r@(Waiting _) (Waiting _ : s) = r:s
+consRes r s = r:s
+
+-- | Execute an expression.
+execRazor :: MVar Integer -- ^ The global counter state
+ -> Razor -- ^ The term to execute
+ -> IO () -- ^ Callback to clear output so far
+ -> ([IntermediateEvalRes] -> IO ()) -- ^ Callback for intermediate results
+ -> StateT ([IntermediateEvalRes], T.Text) IO Integer
+execRazor _ x@(I i) _ _ =
+ modify (second (<> (T.pack (show x)))) >> return i
+execRazor val tm@(Plus x y) clear send =
+ do modify (second (<> (T.pack (show tm))))
+ x' <- execRazor val x clear send
+ modify (first $ consRes (Got x x'))
+ sendState
+ y' <- execRazor val y clear send
+ modify (first $ consRes (Got y y'))
+ sendState
+ let res = x' + y'
+ modify (first $ consRes (Got tm res))
+ sendState
+ return res
+ where sendState = liftIO clear >> fst <$> get >>= liftIO . send
+execRazor val (SleepThen delay body) clear send
+ | delay <= 0.0 = execRazor val body clear send
+ | delay > 0.1 = do modify (first $ consRes (Waiting delay))
+ sendState
+ liftIO $ threadDelay 100000
+ execRazor val (SleepThen (delay - 0.1) body) clear send
+ | otherwise = do modify (first $ consRes (Waiting 0))
+ sendState
+ liftIO $ threadDelay (floor (delay * 1000000))
+ execRazor val body clear send
+ where sendState = liftIO clear >> fst <$> get >>= liftIO . send
+execRazor val Count clear send = do
+ i <- liftIO $ takeMVar val
+ modify (first $ consRes (Got Count i))
+ sendState
+ liftIO $ putMVar val (i+1)
+ return i
+
+ where sendState = liftIO clear >> fst <$> get >>= liftIO . send
+
+-- | Generate a language configuration for some initial state
+mkConfig :: MVar Integer -- ^ The internal state of the execution
+ -> KernelConfig IO [IntermediateEvalRes] (Either ParseError Integer)
+mkConfig var = KernelConfig
+ { languageName = "expanded_huttons_razor"
+ , languageVersion = [0,1,0]
+ , profileSource = Just . ( "calc_profile.tar") <$> Paths.getDataDir
+ , displayResult = displayRes
+ , displayOutput = displayOut
+ , completion = langCompletion
+ , objectInfo = langInfo
+ , run = parseAndRun
+ , debug = False
+ }
+ where
+ displayRes (Left err) =
+ [ DisplayData MimeHtml . T.pack $ "" ++ show err ++ ""
+ , DisplayData PlainText . T.pack $ show err
+ ]
+ displayRes (Right x) =
+ return . DisplayData MimeHtml . T.pack $
+ "Answer: " ++ show x ++ ""
+ displayOut out =
+ let outLines = reverse (map (T.pack . show) out)
+ in return (DisplayData PlainText (T.unlines outLines))
+ parseAndRun code clear send =
+ case parse (T.unpack code) of
+ Left err -> return (Left err, Err, "")
+ Right tm -> do
+ (res, (_, pager)) <- runStateT (execRazor var tm clear send) ([], "")
+ return (Right res, Ok, T.unpack pager)
+
+main :: IO ()
+main = do args <- getArgs
+ val <- newMVar 1
+ case args of
+ ["kernel", profileFile] ->
+ easyKernel profileFile (mkConfig val)
+ ["setup"] -> do
+ putStrLn "Installing profile..."
+ installProfile (mkConfig val)
+ _ -> do
+ putStrLn "Usage:"
+ putStrLn "simple-calc-example setup -- set up the profile"
+ putStrLn "simple-calc-example kernel FILE -- run a kernel with FILE for communication with the frontend"
diff --git a/ipython-kernel.cabal b/ipython-kernel.cabal
--- a/ipython-kernel.cabal
+++ b/ipython-kernel.cabal
@@ -1,5 +1,5 @@
name: ipython-kernel
-version: 0.1.0.0
+version: 0.3.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.
@@ -14,24 +14,55 @@
cabal-version: >=1.16
+data-dir: example-data
+data-files: calc_profile.tar
+
+
+flag examples
+ description: Build example programs
+ default: False
+
+
library
- exposed-modules: IPython.Kernel
- IPython.Types
- IPython.ZeroMQ
- IPython.Stdin
- IPython.Message.Writer
- IPython.Message.Parser
- IPython.Message.UUID
+ exposed-modules: IHaskell.IPython.Kernel
+ IHaskell.IPython.Types
+ IHaskell.IPython.ZeroMQ
+ IHaskell.IPython.Stdin
+ IHaskell.IPython.Message.Writer
+ IHaskell.IPython.Message.Parser
+ IHaskell.IPython.Message.UUID
+ IHaskell.IPython.EasyKernel
-- other-modules:
other-extensions: OverloadedStrings
hs-source-dirs: src
default-language: Haskell2010
- build-depends: base >=4.6 && <4.7,
- aeson >=0.6 && <0.7,
+ build-depends: base >=4.6 && < 4.8,
+ aeson >=0.6 && < 0.9,
bytestring >=0.10,
- cereal ==0.3.*,
+ cereal >=0.3,
containers >=0.5,
+ directory >=1.1,
+ filepath >=1.2,
+ mtl >=2.1,
+ tar >=0.4.0.1,
text >=0.11,
+ transformers >=0.3,
unix >=2.6,
uuid >=1.3,
zeromq4-haskell >=0.1
+
+
+-- Example program
+executable simple-calc-example
+ hs-source-dirs: examples
+ main-is: Calc.hs
+ build-depends: ipython-kernel,
+ base >=4.6 && <4.8,
+ filepath >=1.2,
+ mtl >=2.1,
+ parsec >=3.1,
+ text >=0.11,
+ transformers >=0.3
+
+ if !flag(examples)
+ buildable: False
diff --git a/src/IHaskell/IPython/EasyKernel.hs b/src/IHaskell/IPython/EasyKernel.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/IPython/EasyKernel.hs
@@ -0,0 +1,284 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Description : Easy IPython kernels
+-- = Overview
+-- This module provides automation for writing simple IPython
+-- kernels. In particular, it provides a record type that defines
+-- configurations and a function that interprets a configuration as an
+-- action in some monad that can do IO.
+--
+-- The configuration consists primarily of functions that implement
+-- the various features of a kernel, such as running code, looking up
+-- documentation, and performing completion. An example for a simple
+-- language that nevertheless has side effects, global state, and
+-- timing effects is included in the examples directory.
+--
+-- = Profiles
+-- To run your kernel, you will need an IPython profile that causes
+-- the frontend to run it. To generate a fresh profile, run the command
+--
+-- > ipython profile create NAME
+--
+-- This will create a fresh IPython profile in @~\/.ipython\/profile_NAME@.
+-- This profile must be modified in two ways:
+--
+-- 1. It needs to run your kernel instead of the default ipython
+-- 2. It must have message signing turned off, because 'easyKernel' doesn't support it
+--
+-- == Setting the executable
+-- To set the executable, modify the configuration object's
+-- @KernelManager.kernel_cmd@ property. For example:
+--
+-- > c.KernelManager.kernel_cmd = ['my_kernel', '{connection_file}']
+--
+-- Your own main should arrange to parse command line arguments such
+-- that the connection file is passed to easyKernel.
+--
+-- == Message signing
+-- To turn off message signing, use the following snippet:
+--
+-- > c.Session.key = b''
+-- > c.Session.keyfile = b''
+--
+-- == Further profile improvements
+-- Consult the IPython documentation along with the generated profile
+-- source code for further configuration of the frontend, including
+-- syntax highlighting, logos, help text, and so forth.
+
+module IHaskell.IPython.EasyKernel (easyKernel, installProfile, KernelConfig(..)) where
+
+import Data.Aeson (decode)
+
+import qualified Data.ByteString.Lazy as BL
+
+import qualified Codec.Archive.Tar as Tar
+
+import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad (forever, when)
+
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+
+import IHaskell.IPython.Kernel
+import IHaskell.IPython.Message.UUID as UUID
+
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory)
+import System.FilePath (())
+import System.Exit (exitSuccess)
+import System.IO (openFile, IOMode(ReadMode))
+
+-- | The kernel configuration specifies the behavior that is specific
+-- to your language. The type parameters provide the monad in which
+-- your kernel will run, the type of intermediate outputs from running
+-- cells, and the type of final results of cells, respectively.
+data KernelConfig m output result = KernelConfig
+ { languageName :: String
+ -- ^ The name of the language. This field is used to calculate
+ -- the name of the profile, so it should contain characters that
+ -- are reasonable to have in file names.
+ , languageVersion :: [Int] -- ^ The version of the language
+ , profileSource :: IO (Maybe FilePath)
+ -- ^ Determine the source of a profile to install using
+ -- 'installProfile'. The source should be a tarball whose contents
+ -- will be unpacked directly into the profile directory. For
+ -- example, the file whose name is @ipython_config.py@ in the
+ -- tar file for a language named @lang@ will end up in
+ -- @~/.ipython/profile_lang/ipython_config.py@.
+ , displayOutput :: output -> [DisplayData] -- ^ How to render intermediate output
+ , displayResult :: result -> [DisplayData] -- ^ How to render final cell results
+ , completion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)
+ -- ^ Perform completion. The returned tuple consists of the matches,
+ -- the matched text, and the completion text. The arguments are the
+ -- code in the cell, the current line as text, and the column at
+ -- which the cursor is placed.
+ , objectInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)
+ -- ^ Return the information or documentation for its argument. The
+ -- returned tuple consists of the name, the documentation, and the
+ -- type, respectively.
+ , run :: T.Text -> IO () -> (output -> IO ()) -> m (result, ExecuteReplyStatus, String)
+ -- ^ Execute a cell. The arguments are the contents of the cell, an
+ -- IO action that will clear the current intermediate output, and an
+ -- IO action that will add a new item to the intermediate
+ -- output. The result consists of the actual result, the status to
+ -- be sent to IPython, and the contents of the pager. Return the
+ -- empty string to indicate that there is no pager output. Errors
+ -- should be handled by defining an appropriate error constructor in
+ -- your result type.
+ , debug :: Bool -- ^ Whether to print extra debugging information to
+ -- the console
+ }
+
+-- | Attempt to install the IPython profile from the .tar file
+-- indicated by the 'profileSource' field of the configuration, if it
+-- is not already installed.
+installProfile :: MonadIO m => KernelConfig m output result -> m ()
+installProfile config = do
+ installed <- isInstalled
+ when (not installed) $ do
+ profSrc <- liftIO $ profileSource config
+ case profSrc of
+ Nothing -> liftIO (putStrLn "No IPython profile is installed or specified")
+ Just tar -> do
+ profExists <- liftIO $ doesFileExist tar
+ profTgt <- profDir
+ if profExists
+ then do liftIO $ createDirectoryIfMissing True profTgt
+ liftIO $ Tar.extract profTgt tar
+ else liftIO . putStrLn $
+ "The supplied profile source '" ++ tar ++ "' does not exist"
+
+ where
+ profDir = do
+ home <- liftIO getHomeDirectory
+ return $ home ".ipython" ("profile_" ++ languageName config)
+ isInstalled = do
+ prof <- profDir
+ dirThere <- liftIO $ doesDirectoryExist prof
+ isProf <- liftIO . doesFileExist $ prof "ipython_config.py"
+ return $ dirThere && isProf
+
+getProfile :: FilePath -> IO Profile
+getProfile fn = do
+ profData <- openFile fn ReadMode >>= BL.hGetContents
+ case decode profData of
+ Just prof -> return prof
+ Nothing -> error "Invalid profile data"
+
+createReplyHeader :: MonadIO m => MessageHeader -> m MessageHeader
+createReplyHeader parent = do
+ -- Generate a new message UUID.
+ newMessageId <- liftIO UUID.random
+ let repType = fromMaybe err (replyType $ msgType parent)
+ err = error $ "No reply for message " ++ show (msgType parent)
+
+ return MessageHeader {
+ identifiers = identifiers parent,
+ parentHeader = Just parent,
+ metadata = Map.fromList [],
+ messageId = newMessageId,
+ sessionId = sessionId parent,
+ username = username parent,
+ msgType = repType
+ }
+
+
+
+-- | Execute an IPython kernel for a config. Your 'main' action should
+-- call this as the last thing it does.
+easyKernel :: (MonadIO m)
+ => FilePath -- ^ The connection file provided by the IPython frontend
+ -> KernelConfig m output result -- ^ The kernel configuration specifying how to react to messages
+ -> m ()
+easyKernel profileFile config = do
+ prof <- liftIO $ getProfile profileFile
+ zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan) <-
+ liftIO $ serveProfile prof
+ execCount <- liftIO $ newMVar 0
+ forever $ do
+ req <- liftIO $ readChan shellReqChan
+ repHeader <- createReplyHeader (header req)
+ when (debug config) . liftIO $ print req
+ reply <- replyTo config execCount zmq req repHeader
+ liftIO $ writeChan shellRepChan reply
+
+
+replyTo :: MonadIO m
+ => KernelConfig m output result
+ -> MVar Integer
+ -> ZeroMQInterface
+ -> Message
+ -> MessageHeader
+ -> m Message
+replyTo config _ _ KernelInfoRequest{} replyHeader =
+ return KernelInfoReply
+ { header = replyHeader
+ , language = languageName config
+ , versionList = languageVersion config
+ }
+replyTo config _ interface ShutdownRequest{restartPending=pending} replyHeader = do
+ liftIO $ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending
+ liftIO exitSuccess
+
+replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHeader = do
+ let send msg = writeChan (iopubChannel interface) msg
+
+ busyHeader <- dupHeader replyHeader StatusMessage
+ liftIO . send $ PublishStatus busyHeader Busy
+
+ outputHeader <- dupHeader replyHeader DisplayDataMessage
+ (res, replyStatus, pagerOut) <-
+ let clearOutput = do
+ clearHeader <- dupHeader replyHeader ClearOutputMessage
+ send $ ClearOutput clearHeader False
+ sendOutput x =
+ send $ PublishDisplayData outputHeader (languageName config)
+ (displayOutput config x)
+ in run config code clearOutput sendOutput
+ liftIO . send $ PublishDisplayData outputHeader (languageName config) (displayResult config res)
+
+
+ idleHeader <- dupHeader replyHeader StatusMessage
+ liftIO . send $ PublishStatus idleHeader Idle
+
+ liftIO $ modifyMVar_ execCount (return . (+1))
+ counter <- liftIO $ readMVar execCount
+
+ return ExecuteReply
+ { header = replyHeader
+ , pagerOutput = pagerOut
+ , executionCounter = fromIntegral counter
+ , status = replyStatus
+ }
+
+replyTo config _ _ req@CompleteRequest{} replyHeader = do
+ let code = getCode req
+ line = getCodeLine req
+ col = getCursorPos req
+
+ return $ case completion config code line col of
+ Nothing ->
+ CompleteReply
+ { header = replyHeader
+ , completionMatches = []
+ , completionMatchedText = ""
+ , completionText = ""
+ , completionStatus = False
+ }
+ Just (matches, matchedText, cmplText) ->
+ CompleteReply
+ { header = replyHeader
+ , completionMatches = matches
+ , completionMatchedText = matchedText
+ , completionText = cmplText
+ , completionStatus = True
+ }
+
+replyTo config _ _ ObjectInfoRequest { objectName = obj } replyHeader =
+ return $ case objectInfo config obj of
+ Just (name, docs, ty) -> ObjectInfoReply
+ { header = replyHeader
+ , objectName = obj
+ , objectFound = True
+ , objectTypeString = ty
+ , objectDocString = docs
+ }
+ Nothing -> ObjectInfoReply
+ { header = replyHeader
+ , objectName = obj
+ , objectFound = False
+ , objectTypeString = ""
+ , objectDocString = ""
+ }
+
+replyTo _ _ _ msg _ = do
+ liftIO $ putStrLn "Unknown message: "
+ liftIO $ print msg
+ return msg
+
+
+dupHeader :: MonadIO m => MessageHeader -> MessageType -> m MessageHeader
+dupHeader hdr mtype =
+ do uuid <- liftIO UUID.random
+ return hdr { messageId = uuid , msgType = mtype }
diff --git a/src/IHaskell/IPython/Kernel.hs b/src/IHaskell/IPython/Kernel.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/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 IHaskell.IPython.Kernel (
+ module IHaskell.IPython.Types,
+ module IHaskell.IPython.Message.Writer,
+ module IHaskell.IPython.Message.Parser,
+ module IHaskell.IPython.Message.UUID,
+ module IHaskell.IPython.ZeroMQ,
+ ) where
+
+import IHaskell.IPython.Types
+import IHaskell.IPython.Message.Writer
+import IHaskell.IPython.Message.Parser
+import IHaskell.IPython.Message.UUID
+import IHaskell.IPython.ZeroMQ
diff --git a/src/IHaskell/IPython/Message/Parser.hs b/src/IHaskell/IPython/Message/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/IPython/Message/Parser.hs
@@ -0,0 +1,191 @@
+{-# 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 IHaskell.IPython.Message.Parser (parseMessage) where
+
+import Data.Aeson ((.:), decode, Result(..), Object)
+import Control.Applicative ((<|>))
+import Data.Aeson.Types (parse)
+import Data.ByteString
+import Data.Map (Map)
+import Data.Text (Text)
+
+import qualified Data.ByteString.Lazy as Lazy
+
+import IHaskell.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 Text Text)
+
+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 CommOpenMessage = commOpenParser
+parser CommDataMessage = commDataParser
+parser CommCloseMessage = commCloseParser
+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
+
+commOpenParser :: LByteString -> Message
+commOpenParser content = parsed
+ where
+ Success parsed = flip parse decoded $ \ obj -> do
+ uuid <- obj .: "comm_id"
+ name <- obj .: "target_name"
+ value <- obj .: "data"
+ return $ CommOpen noHeader name uuid value
+
+ Just decoded = decode content
+
+commDataParser :: LByteString -> Message
+commDataParser content = parsed
+ where
+ Success parsed = flip parse decoded $ \ obj -> do
+ uuid <- obj .: "comm_id"
+ value <- obj .: "data"
+ return $ CommData noHeader uuid value
+
+ Just decoded = decode content
+
+commCloseParser :: LByteString -> Message
+commCloseParser content = parsed
+ where
+ Success parsed = flip parse decoded $ \ obj -> do
+ uuid <- obj .: "comm_id"
+ value <- obj .: "data"
+ return $ CommClose noHeader uuid value
+
+ Just decoded = decode content
diff --git a/src/IHaskell/IPython/Message/UUID.hs b/src/IHaskell/IPython/Message/UUID.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/IPython/Message/UUID.hs
@@ -0,0 +1,43 @@
+-- | Description : UUID generator and data structure
+--
+-- Generate, parse, and pretty print UUIDs for use with IPython.
+module IHaskell.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)
+
+-- 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, Ord)
+
+-- | 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/IHaskell/IPython/Message/Writer.hs b/src/IHaskell/IPython/Message/Writer.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/IPython/Message/Writer.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Description : @ToJSON@ for Messages
+--
+-- This module contains the @ToJSON@ instance for @Message@.
+module IHaskell.IPython.Message.Writer (
+ ToJSON(..)
+) where
+
+import Data.Aeson
+import Data.Map (Map)
+import Data.Text (Text, pack)
+import Data.Monoid (mempty)
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as B
+import Data.Text.Encoding
+
+import IHaskell.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 req@CommOpen{} = object [
+ "comm_id" .= commUuid req,
+ "target_name" .= commTargetName req,
+ "data" .= commData req
+ ]
+
+ toJSON req@CommData{} = object [
+ "comm_id" .= commUuid req,
+ "data" .= commData req
+ ]
+
+ toJSON req@CommClose{} = object [
+ "comm_id" .= commUuid req,
+ "data" .= commData req
+ ]
+
+ 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) .= String 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/IHaskell/IPython/Stdin.hs b/src/IHaskell/IPython/Stdin.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/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 IHaskell.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 IHaskell.IPython.Types
+import IHaskell.IPython.ZeroMQ
+import IHaskell.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/IHaskell/IPython/Types.hs b/src/IHaskell/IPython/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/IPython/Types.hs
@@ -0,0 +1,416 @@
+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
+-- | This module contains all types used to create an IPython language
+-- kernel.
+module IHaskell.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.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Text (Text)
+import Data.Serialize
+import IHaskell.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 :: Text -- ^ 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 mech) =
+ case mech of
+ "tcp" -> return TCP
+ _ -> fail $ "Unknown transport mechanism " ++ Text.unpack 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 = Text
+
+-- | A metadata dictionary.
+type Metadata = Map Text Text
+
+-- | 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
+ | CommOpenMessage
+ | CommDataMessage
+ | CommCloseMessage
+ deriving (Show, Read, Eq)
+
+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"
+showMessageType CommOpenMessage = "comm_open"
+showMessageType CommDataMessage = "comm_msg"
+showMessageType CommCloseMessage = "comm_close"
+
+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
+ "comm_open" -> return CommOpenMessage
+ "comm_msg" -> return CommDataMessage
+ "comm_close" -> return CommCloseMessage
+
+ _ -> 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 :: Text, -- ^ 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 :: [Text], -- ^ Unused.
+ getUserExpressions :: [Text] -- ^ 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 :: Text, {- ^
+ 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 :: Text, -- ^ 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 :: [Text],
+ completionMatchedText :: Text,
+ completionText :: Text,
+ completionStatus :: Bool
+ }
+
+ | ObjectInfoRequest {
+ header :: MessageHeader,
+ objectName :: Text, -- ^ 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 :: Text, -- ^ Name of object which was searched for.
+ objectFound :: Bool, -- ^ Whether the object was found.
+ objectTypeString :: Text, -- ^ Object type.
+ objectDocString :: Text
+ }
+
+ | 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
+ }
+
+ | CommOpen {
+ header :: MessageHeader,
+ commTargetName :: String,
+ commUuid :: UUID,
+ commData :: Value
+ }
+
+ | CommData {
+ header :: MessageHeader,
+ commUuid :: UUID,
+ commData :: Value
+ }
+
+ | CommClose {
+ header :: MessageHeader,
+ commUuid :: UUID,
+ commData :: Value
+ }
+
+ | SendNothing -- Dummy message; nothing is sent.
+ 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 Text 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 Text where
+ put str = put (Text.encodeUtf8 str)
+ get = Text.decodeUtf8 <$> get
+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
+ | MimeJavascript
+ 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) -> Text.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"
+ show MimeJavascript = "application/javascript"
diff --git a/src/IHaskell/IPython/ZeroMQ.hs b/src/IHaskell/IPython/ZeroMQ.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskell/IPython/ZeroMQ.hs
@@ -0,0 +1,208 @@
+{-# 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 IHaskell.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 IHaskell.IPython.Types
+import IHaskell.IPython.Message.Parser
+import IHaskell.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 _ SendNothing = return ()
+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
diff --git a/src/IPython/Kernel.hs b/src/IPython/Kernel.hs
deleted file mode 100644
--- a/src/IPython/Kernel.hs
+++ /dev/null
@@ -1,16 +0,0 @@
--- | 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
deleted file mode 100644
--- a/src/IPython/Message/Parser.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/src/IPython/Message/UUID.hs
+++ /dev/null
@@ -1,46 +0,0 @@
--- | 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
deleted file mode 100644
--- a/src/IPython/Message/Writer.hs
+++ /dev/null
@@ -1,118 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/src/IPython/Stdin.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/src/IPython/Types.hs
+++ /dev/null
@@ -1,382 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/src/IPython/ZeroMQ.hs
+++ /dev/null
@@ -1,207 +0,0 @@
-{-# 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