diff --git a/examples/Calc.hs b/examples/Calc.hs --- a/examples/Calc.hs +++ b/examples/Calc.hs @@ -221,6 +221,7 @@ , languageVersion = "1.0.0" , languageFileExtension = ".txt" , languageCodeMirrorMode = "null" + , languagePygmentsLexer = "Text" } , writeKernelspec = const $ return $ KernelSpec { kernelDisplayName = "Hutton's Razor" diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -61,6 +61,7 @@ , languageVersion = "1.0.0" , languageFileExtension = ".txt" , languageCodeMirrorMode = "null" + , languagePygmentsLexer = "Text" } languageKernelspec :: KernelSpec 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.9.1.0 +version: 0.10.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. @@ -24,20 +24,22 @@ library + ghc-options: -Wall + exposed-modules: IHaskell.IPython.Kernel IHaskell.IPython.Types IHaskell.IPython.ZeroMQ - IHaskell.IPython.Message.Writer IHaskell.IPython.Message.Parser IHaskell.IPython.Message.UUID IHaskell.IPython.EasyKernel other-extensions: OverloadedStrings hs-source-dirs: src default-language: Haskell2010 - build-depends: base >=4.6 && <5, + build-depends: base >=4.9 && <5, aeson , bytestring , cereal , + cereal-text , containers , cryptonite , directory , diff --git a/src/IHaskell/IPython/EasyKernel.hs b/src/IHaskell/IPython/EasyKernel.hs --- a/src/IHaskell/IPython/EasyKernel.hs +++ b/src/IHaskell/IPython/EasyKernel.hs @@ -23,7 +23,7 @@ -- logos, help text, and so forth. module IHaskell.IPython.EasyKernel (easyKernel, installKernelspec, KernelConfig(..)) where -import Data.Aeson (decode, encode) +import Data.Aeson (decode, encode, toJSON) import qualified Data.ByteString.Lazy as BL @@ -32,18 +32,17 @@ import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (forever, when, unless, void) +import Control.Monad (forever, when, void) +import qualified Data.HashMap.Strict as HashMap 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 IHaskell.IPython.Types -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, - getHomeDirectory, getTemporaryDirectory) +import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) import System.FilePath (()) import System.Exit (exitSuccess) import System.IO (openFile, IOMode(ReadMode)) @@ -53,7 +52,7 @@ -- running cells, and the type of final results of cells, respectively. data KernelConfig m output result = KernelConfig - { + { -- | Info on the language of the kernel. kernelLanguageInfo :: LanguageInfo -- | Write all the files into the kernel directory, including `kernel.js`, `logo-64x64.svg`, and any @@ -122,20 +121,13 @@ 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) + let repType = fromMaybe err (replyType $ mhMsgType parent) + err = error $ "No reply for message " ++ show (mhMsgType parent) - return - MessageHeader - { identifiers = identifiers parent - , parentHeader = Just parent - , metadata = Map.fromList [] - , messageId = newMessageId - , sessionId = sessionId parent - , username = username parent - , msgType = repType - } + return $ MessageHeader (mhIdentifiers parent) (Just parent) (Metadata (HashMap.fromList [])) + newMessageId (mhSessionId parent) (mhUsername parent) repType + -- | Execute an IPython kernel for a config. Your 'main' action should call this as the last thing -- it does. easyKernel :: MonadIO m @@ -145,16 +137,14 @@ -> m () easyKernel profileFile config = do prof <- liftIO $ getProfile profileFile - zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <- liftIO $ serveProfile - prof - False + zmq <- liftIO $ serveProfile prof False execCount <- liftIO $ newMVar 0 forever $ do - req <- liftIO $ readChan shellReqChan + req <- liftIO $ readChan (shellRequestChannel zmq) repHeader <- createReplyHeader (header req) when (debug config) . liftIO $ print req reply <- replyTo config execCount zmq req repHeader - liftIO $ writeChan shellRepChan reply + liftIO $ writeChan (shellRequestChannel zmq) reply replyTo :: MonadIO m => KernelConfig m output result @@ -180,17 +170,17 @@ , status = Ok } -replyTo config _ _ CommInfoRequest{} replyHeader = +replyTo _ _ _ CommInfoRequest{} replyHeader = return CommInfoReply { header = replyHeader , commInfo = Map.empty } -replyTo config _ interface ShutdownRequest { restartPending = pending } replyHeader = do +replyTo _ _ 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 +replyTo config execCount interface req@ExecuteRequest{} replyHeader = do let send = writeChan (iopubChannel interface) busyHeader <- dupHeader replyHeader StatusMessage @@ -205,8 +195,9 @@ send $ PublishDisplayData outputHeader (displayOutput config x) - in run config code clearOutput sendOutput - liftIO . send $ PublishDisplayData outputHeader (displayResult config res) + Nothing + in run config (getCode req) clearOutput sendOutput + liftIO . send $ PublishDisplayData outputHeader (displayResult config res) Nothing idleHeader <- dupHeader replyHeader StatusMessage @@ -230,7 +221,7 @@ let start = pos - T.length matchedText end = pos - reply = CompleteReply replyHeader completions start end Map.empty True + reply = CompleteReply replyHeader completions start end (Metadata HashMap.empty) True return reply replyTo config _ _ req@InspectRequest{} replyHeader = do @@ -254,4 +245,4 @@ dupHeader hdr mtype = do uuid <- liftIO UUID.random - return hdr { messageId = uuid, msgType = mtype } + return hdr { mhMessageId = uuid, mhMsgType = mtype } diff --git a/src/IHaskell/IPython/Kernel.hs b/src/IHaskell/IPython/Kernel.hs --- a/src/IHaskell/IPython/Kernel.hs +++ b/src/IHaskell/IPython/Kernel.hs @@ -3,7 +3,6 @@ module IHaskell.IPython.Kernel (module X) where import IHaskell.IPython.Types as X -import IHaskell.IPython.Message.Writer as X import IHaskell.IPython.Message.Parser as X import IHaskell.IPython.Message.UUID as X import IHaskell.IPython.ZeroMQ as X diff --git a/src/IHaskell/IPython/Message/Parser.hs b/src/IHaskell/IPython/Message/Parser.hs --- a/src/IHaskell/IPython/Message/Parser.hs +++ b/src/IHaskell/IPython/Message/Parser.hs @@ -8,15 +8,13 @@ -- the low-level 0MQ interface. module IHaskell.IPython.Message.Parser (parseMessage) where -import Control.Applicative ((<|>), (<$>), (<*>)) -import Data.Aeson ((.:), (.:?), (.!=), decode, Result(..), Object, Value(..)) -import Data.Aeson.Types (parse, parseEither) +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson ((.:), (.:?), (.!=), decode, FromJSON, Result(..), Object, Value(..)) +import Data.Aeson.Types (Parser, parse, parseEither) import Data.ByteString hiding (unpack) import qualified Data.ByteString.Lazy as Lazy import Data.HashMap.Strict as HM -import Data.Map (Map) import Data.Maybe (fromMaybe) -import Data.Text (Text) import Data.Text (Text, unpack) import Debug.Trace import IHaskell.IPython.Types @@ -32,7 +30,7 @@ -> Message -- ^ A parsed message. parseMessage idents headerData parentHeader metadata content = let header = parseHeader idents headerData parentHeader metadata - messageType = msgType header + messageType = mhMsgType header messageWithoutHeader = parser messageType $ Lazy.fromStrict content in messageWithoutHeader { header = header } @@ -43,15 +41,7 @@ -> 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 - } + MessageHeader idents parentResult metadataMap messageUUID sessionUUID username 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. @@ -68,7 +58,7 @@ return (messType, username, message, session) -- Get metadata as a simple map. - Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map Text Text) + Just metadataMap = fmap Metadata $ decode $ Lazy.fromStrict metadata noHeader :: MessageHeader noHeader = error "No header created" @@ -158,7 +148,7 @@ traceback <- obj .: "traceback" ename <- obj .: "ename" evalue <- obj .: "evalue" - return $ ExecuteError noHeader [] traceback ename evalue + return $ ExecuteError noHeader traceback ename evalue makeDisplayDatas :: Object -> [DisplayData] makeDisplayDatas dataDict = [DisplayData (read $ unpack mimeType) content | (mimeType, String content) <- HM.toList @@ -178,8 +168,9 @@ displayDataParser = requestParser $ \obj -> do dataDict :: Object <- obj .: "data" let displayDatas = makeDisplayDatas dataDict - return $ PublishDisplayData noHeader displayDatas + return $ PublishDisplayData noHeader displayDatas Nothing +requestParser :: FromJSON a => (a -> Parser Message) -> LByteString -> Message requestParser parser content = case parseEither parser decoded of Right parsed -> parsed @@ -218,6 +209,7 @@ executionCount <- obj .: "execution_count" return $ Input noHeader code executionCount +getDisplayDatas :: Maybe Object -> [DisplayData] getDisplayDatas Nothing = [] getDisplayDatas (Just dataDict) = makeDisplayDatas dataDict diff --git a/src/IHaskell/IPython/Message/UUID.hs b/src/IHaskell/IPython/Message/UUID.hs --- a/src/IHaskell/IPython/Message/UUID.hs +++ b/src/IHaskell/IPython/Message/UUID.hs @@ -3,7 +3,7 @@ -- Generate, parse, and pretty print UUIDs for use with IPython. module IHaskell.IPython.Message.UUID (UUID, random, randoms, uuidToString) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Control.Monad (mzero, replicateM) import Data.Aeson import Data.Text (pack) diff --git a/src/IHaskell/IPython/Message/Writer.hs b/src/IHaskell/IPython/Message/Writer.hs deleted file mode 100644 --- a/src/IHaskell/IPython/Message/Writer.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-unused-matches #-} - --- | Description : @ToJSON@ for Messages --- --- This module contains the @ToJSON@ instance for @Message@. -module IHaskell.IPython.Message.Writer (ToJSON(..)) where - -import Data.Aeson -import Data.Aeson.Types (Pair) -import Data.Aeson.Parser (json) -import Data.Map (Map) -import Data.Monoid (mempty) -import Data.Text (Text, pack) -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Map as Map -import IHaskell.IPython.Types -import Data.Maybe (fromMaybe) - -instance ToJSON LanguageInfo where - toJSON info = object - [ "name" .= languageName info - , "version" .= languageVersion info - , "file_extension" .= languageFileExtension info - , "codemirror_mode" .= languageCodeMirrorMode info - , "pygments_lexer" .= languagePygmentsLexer info - ] - --- Convert message bodies into JSON. -instance ToJSON Message where - toJSON rep@KernelInfoReply{} = - object - [ "protocol_version" .= protocolVersion rep - , "banner" .= banner rep - , "implementation" .= implementation rep - , "implementation_version" .= implementationVersion rep - , "language_info" .= languageInfo rep - , "status" .= show (status rep) - ] - - toJSON CommInfoReply - { header = header - , commInfo = commInfo - } = - object - [ "comms" .= Map.map (\comm -> object ["target_name" .= comm]) commInfo - , "status" .= string "ok" - ] - - toJSON ExecuteRequest - { getCode = code - , getSilent = silent - , getStoreHistory = storeHistory - , getAllowStdin = allowStdin - , getUserExpressions = userExpressions - } = - object - [ "code" .= code - , "silent" .= silent - , "store_history" .= storeHistory - , "allow_stdin" .= allowStdin - , "user_expressions" .= userExpressions - ] - - toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } = - object - [ "status" .= show status - , "execution_count" .= counter - , "payload" .= - if null pager - then [] - else mkPayload pager - , "user_expressions" .= emptyMap - ] - where - mkPayload o = [ object - [ "source" .= string "page" - , "start" .= Number 0 - , "data" .= object (map displayDataToJson o) - ] - ] - toJSON PublishStatus { executionState = executionState } = - object ["execution_state" .= executionState] - toJSON PublishStream { streamType = streamType, streamContent = content } = - object ["data" .= content, "name" .= streamType] - toJSON PublishDisplayData { displayData = datas } = - object - ["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 _ matches start end metadata status) = - object - [ "matches" .= matches - , "cursor_start" .= start - , "cursor_end" .= end - , "metadata" .= metadata - , "status" .= if status - then string "ok" - else "error" - ] - toJSON i@InspectReply{} = - object - [ "status" .= if inspectStatus i - then string "ok" - else "error" - , "data" .= object (map displayDataToJson . inspectData $ i) - , "metadata" .= object [] - , "found" .= inspectStatus i - ] - - toJSON ShutdownReply { restartPending = restart } = - object ["restart" .= restart - , "status" .= string "ok" - ] - - 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 - , "target_module" .= commTargetModule 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 req@HistoryReply{} = - object ["history" .= map tuplify (historyReply req) - , "status" .= string "ok" - ] - where - tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of - Left inp -> toJSON inp - Right (inp, out) -> toJSON out) - - toJSON req@IsCompleteReply{} = - object pairs - where - pairs = - case reviewResult req of - CodeComplete -> status "complete" - CodeIncomplete ind -> status "incomplete" ++ indent ind - CodeInvalid -> status "invalid" - CodeUnknown -> status "unknown" - status x = ["status" .= pack x] - indent x = ["indent" .= pack x] - - 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 MimeJson dataStr) = - pack (show MimeJson) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value) -displayDataToJson (DisplayData MimeVegalite dataStr) = - pack (show MimeVegalite) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe Value) -displayDataToJson (DisplayData MimeVega dataStr) = - pack (show MimeVega) .= fromMaybe (String "") (decodeStrict (encodeUtf8 dataStr) :: Maybe 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/Types.hs b/src/IHaskell/IPython/Types.hs --- a/src/IHaskell/IPython/Types.hs +++ b/src/IHaskell/IPython/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-unused-matches #-} -- | This module contains all types used to create an IPython language kernel. @@ -6,8 +6,8 @@ -- * IPython kernel profile Profile(..), Transport(..), - Port(..), - IP(..), + Port, + IP, -- * IPython kernelspecs KernelSpec(..), @@ -15,18 +15,19 @@ -- * IPython messaging protocol Message(..), MessageHeader(..), - Username(..), - Metadata(..), + Username, + Transient(..), MessageType(..), CodeReview(..), - Width(..), - Height(..), + Width, + Height, StreamType(..), ExecutionState(..), ExecuteReplyStatus(..), HistoryAccessType(..), HistoryReplyElement(..), LanguageInfo(..), + Metadata(..), replyType, showMessageType, @@ -38,11 +39,16 @@ import Control.Applicative ((<$>), (<*>)) import Data.Aeson +import Data.Aeson.Types (typeMismatch) import Data.ByteString (ByteString) import Data.List (find) import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup) import Data.Serialize -import Data.Text (Text) +import Data.Serialize.Text () +import Data.Text (Text, pack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Typeable @@ -117,7 +123,7 @@ -------------------- IPython Kernelspec Types ---------------------- data KernelSpec = KernelSpec - { + { -- | Name shown to users to describe this kernel (e.g. "Haskell") kernelDisplayName :: String -- | Name for the kernel; unique kernel identifier (e.g. "haskell") @@ -140,13 +146,13 @@ -- | 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. + { mhIdentifiers :: [ByteString] -- ^ The identifiers sent with the message. + , mhParentHeader :: Maybe MessageHeader -- ^ The parent header, if present. + , mhMetadata :: Metadata -- ^ A dict of metadata. + , mhMessageId :: UUID -- ^ A unique message UUID. + , mhSessionId :: UUID -- ^ A unique session UUID. + , mhUsername :: Username -- ^ The user who sent this message. + , mhMsgType :: MessageType -- ^ The message type. } deriving (Show, Read) @@ -154,18 +160,19 @@ -- all the record fields. instance ToJSON MessageHeader where toJSON header = object - [ "msg_id" .= messageId header - , "session" .= sessionId header - , "username" .= username header + [ "msg_id" .= mhMessageId header + , "session" .= mhSessionId header + , "username" .= mhUsername header , "version" .= ("5.0" :: String) - , "msg_type" .= showMessageType (msgType header) + , "msg_type" .= showMessageType (mhMsgType header) ] -- | A username for the source of a message. type Username = Text -- | A metadata dictionary. -type Metadata = Map Text Text +newtype Metadata = Metadata Object + deriving (Show, Read, ToJSON, Semigroup, Monoid) -- | The type of a message, corresponding to IPython message types. data MessageType = KernelInfoReplyMessage @@ -178,6 +185,7 @@ | StatusMessage | StreamMessage | DisplayDataMessage + | UpdateDisplayDataMessage | OutputMessage | InputMessage | IsCompleteRequestMessage @@ -211,6 +219,7 @@ showMessageType StatusMessage = "status" showMessageType StreamMessage = "stream" showMessageType DisplayDataMessage = "display_data" +showMessageType UpdateDisplayDataMessage = "update_display_data" showMessageType OutputMessage = "pyout" showMessageType InputMessage = "pyin" showMessageType IsCompleteRequestMessage = "is_complete_request" @@ -245,6 +254,7 @@ "status" -> return StatusMessage "stream" -> return StreamMessage "display_data" -> return DisplayDataMessage + "update_display_data" -> return UpdateDisplayDataMessage "pyout" -> return OutputMessage "pyin" -> return InputMessage "is_complete_request" -> return IsCompleteRequestMessage @@ -280,12 +290,31 @@ } deriving (Show, Eq) +instance ToJSON LanguageInfo where + toJSON info = object + [ "name" .= languageName info + , "version" .= languageVersion info + , "file_extension" .= languageFileExtension info + , "codemirror_mode" .= languageCodeMirrorMode info + , "pygments_lexer" .= languagePygmentsLexer info + ] + data CodeReview = CodeComplete | CodeIncomplete String -- ^ String to be used to indent next line of input | CodeInvalid | CodeUnknown deriving Show + +newtype Transient = Transient + { transientDisplayId :: UUID + } + deriving (Show, Eq) + +instance ToJSON Transient where + toJSON t = object [ "display_id" .= transientDisplayId t + ] + -- | A message used to communicate with the IPython frontend. data Message = -- | A request from a frontend for information about the kernel. @@ -349,7 +378,6 @@ -- | An error reply to an execute request ExecuteError { header :: MessageHeader - , pagerOutput :: [DisplayData] -- ^ The mimebundles to display in the pager. , traceback :: [Text] , ename :: Text , evalue :: Text @@ -369,8 +397,15 @@ PublishDisplayData { header :: MessageHeader , displayData :: [DisplayData] -- ^ A list of data representations. + , transient :: Maybe Transient } | + PublishUpdateDisplayData + { header :: MessageHeader + , displayData :: [DisplayData] -- ^ A list of data representations. + , transient :: Maybe Transient + } + | PublishOutput { header :: MessageHeader , reprText :: String -- ^ Printed output text. @@ -472,6 +507,165 @@ | SendNothing -- Dummy message; nothing is sent. deriving Show +-- Convert message bodies into JSON. +instance ToJSON Message where + toJSON rep@KernelInfoReply{} = + object + [ "protocol_version" .= protocolVersion rep + , "banner" .= banner rep + , "implementation" .= implementation rep + , "implementation_version" .= implementationVersion rep + , "language_info" .= languageInfo rep + , "status" .= show (status rep) + ] + + toJSON CommInfoReply + { header = header + , commInfo = commInfo + } = + object + [ "comms" .= Map.map (\comm -> object ["target_name" .= comm]) commInfo + , "status" .= string "ok" + ] + + toJSON ExecuteRequest + { getCode = code + , getSilent = silent + , getStoreHistory = storeHistory + , getAllowStdin = allowStdin + , getUserExpressions = userExpressions + } = + object + [ "code" .= code + , "silent" .= silent + , "store_history" .= storeHistory + , "allow_stdin" .= allowStdin + , "user_expressions" .= userExpressions + ] + + toJSON ExecuteReply { status = status, executionCounter = counter, pagerOutput = pager } = + object + [ "status" .= show status + , "execution_count" .= counter + , "payload" .= + if null pager + then [] + else mkPayload pager + , "user_expressions" .= emptyMap + ] + where + mkPayload o = [ object + [ "source" .= string "page" + , "start" .= Number 0 + , "data" .= object (map displayDataToJson o) + ] + ] + toJSON ExecuteError { header = header, traceback = traceback, ename = ename, evalue = evalue } = + object + [ "header" .= show header + , "traceback" .= map toJSON traceback + , "ename" .= ename + , "evalue" .= evalue + ] + toJSON PublishStatus { executionState = executionState } = + object ["execution_state" .= executionState] + toJSON PublishStream { streamType = streamType, streamContent = content } = + object ["data" .= content, "name" .= streamType] + toJSON r@PublishDisplayData { displayData = datas } + = object + $ case transient r of + Just t -> (("transient" .= toJSON (transient r)) :) + Nothing -> id + $ ["metadata" .= object [] + , "data" .= object (map displayDataToJson datas) + ] + toJSON r@PublishUpdateDisplayData { displayData = datas } + = object + $ case transient r of + Just t -> (("transient" .= toJSON (transient r)) :) + Nothing -> id + $ ["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 _ matches start end metadata status) = + object + [ "matches" .= matches + , "cursor_start" .= start + , "cursor_end" .= end + , "metadata" .= metadata + , "status" .= if status + then string "ok" + else "error" + ] + toJSON i@InspectReply{} = + object + [ "status" .= if inspectStatus i + then string "ok" + else "error" + , "data" .= object (map displayDataToJson . inspectData $ i) + , "metadata" .= object [] + , "found" .= inspectStatus i + ] + + toJSON ShutdownReply { restartPending = restart } = + object ["restart" .= restart + , "status" .= string "ok" + ] + + 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 + , "target_module" .= commTargetModule 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 req@HistoryReply{} = + object ["history" .= map tuplify (historyReply req) + , "status" .= string "ok" + ] + where + tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of + Left inp -> toJSON inp + Right (inp, out) -> toJSON out) + + toJSON req@IsCompleteReply{} = + object pairs + where + pairs = + case reviewResult req of + CodeComplete -> status "complete" + CodeIncomplete ind -> status "incomplete" ++ indent ind + CodeInvalid -> status "invalid" + CodeUnknown -> status "unknown" + status x = ["status" .= pack x] + indent x = ["indent" .= pack x] + + toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body + + + + -- | Ways in which the frontend can request history. TODO: Implement fields as described in -- messaging spec. data HistoryAccessType = HistoryRange @@ -497,6 +691,7 @@ parseJSON (String "ok") = return Ok parseJSON (String "error") = return Err parseJSON (String "abort") = return Abort + parseJSON invalid = typeMismatch "ExecuteReplyStatus" invalid instance Show ExecuteReplyStatus where show Ok = "ok" @@ -513,7 +708,14 @@ parseJSON (String "busy") = return Busy parseJSON (String "idle") = return Idle parseJSON (String "starting") = return Starting + parseJSON invalid = typeMismatch "ExecutionState" invalid +-- | 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" + -- | Input and output streams. data StreamType = Stdin | Stdout @@ -524,7 +726,14 @@ parseJSON (String "stdin") = return Stdin parseJSON (String "stdout") = return Stdout parseJSON (String "stderr") = return Stderr + parseJSON invalid = typeMismatch "StreamType" invalid +-- | Print a stream as "stdin" or "stdout" strings. +instance ToJSON StreamType where + toJSON Stdin = String "stdin" + toJSON Stdout = String "stdout" + toJSON Stderr = String "stderr" + -- | Get the reply message type for a request message type. replyType :: MessageType -> Maybe MessageType replyType KernelInfoRequestMessage = Just KernelInfoReplyMessage @@ -547,11 +756,6 @@ 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 @@ -583,6 +787,7 @@ case find isPlain disps of Nothing -> "" Just (DisplayData PlainText bytestr) -> Text.unpack bytestr + Just _ -> "" where isPlain (DisplayData mime _) = mime == PlainText @@ -617,3 +822,21 @@ readsPrec _ "application/vnd.vega.v2+json" = [(MimeVega, "")] readsPrec _ "application/vnd.vegalite.v1+json" = [(MimeVegalite, "")] readsPrec _ "application/vdom.v1+json" = [(MimeVdom, "")] + readsPrec _ _ = [] + +-- | Convert a MIME type and value into a JSON dictionary pair. +displayDataToJson :: DisplayData -> (Text, Value) +displayDataToJson (DisplayData MimeJson dataStr) = + pack (show MimeJson) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value) +displayDataToJson (DisplayData MimeVegalite dataStr) = + pack (show MimeVegalite) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value) +displayDataToJson (DisplayData MimeVega dataStr) = + pack (show MimeVega) .= fromMaybe (String "") (decodeStrict (Text.encodeUtf8 dataStr) :: Maybe Value) +displayDataToJson (DisplayData mimeType dataStr) = + pack (show mimeType) .= String dataStr + +string :: String -> String +string = id + +emptyMap :: Map String String +emptyMap = mempty diff --git a/src/IHaskell/IPython/ZeroMQ.hs b/src/IHaskell/IPython/ZeroMQ.hs --- a/src/IHaskell/IPython/ZeroMQ.hs +++ b/src/IHaskell/IPython/ZeroMQ.hs @@ -21,17 +21,17 @@ import Crypto.Hash.Algorithms (SHA256) import qualified Crypto.MAC.HMAC as HMAC import Data.Aeson +import qualified Data.ByteArray.Encoding as Encoding import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Char import qualified Data.ByteString.Lazy as LBS import Data.Char import Data.Monoid ((<>)) import qualified Data.Text.Encoding as Text -import System.ZMQ4 as ZMQ4 hiding (stdin) +import System.ZMQ4 as ZMQ4 import Text.Read (readMaybe) import IHaskell.IPython.Message.Parser -import IHaskell.IPython.Message.Writer () import IHaskell.IPython.Types -- | The channel interface to the ZeroMQ sockets. All communication is done via Messages, which are @@ -39,7 +39,7 @@ -- should functionally serve as high-level sockets which speak Messages instead of ByteStrings. data ZeroMQInterface = Channels - { + { -- | A channel populated with requests from the frontend. shellRequestChannel :: Chan Message -- | Writing to this channel causes a reply to be sent to the frontend. @@ -90,16 +90,16 @@ -- 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 + _ <- forkIO $ withContext $ \ctxt -> do -- Serve on all sockets. - forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels - forkIO $ serveSocket context Router (controlPort profile) $ control debug channels - forkIO $ serveSocket context Router (shellPort profile) $ shell debug channels + _ <- forkIO $ serveSocket ctxt Rep (hbPort profile) $ heartbeat channels + _ <- forkIO $ serveSocket ctxt Router (controlPort profile) $ control debug channels + _ <- forkIO $ serveSocket ctxt Router (shellPort profile) $ shell debug 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 + -- The ctxt is reference counted in this thread only. Thus, the last serveSocket cannot be + -- asynchronous, because otherwise ctxt 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 debug channels + serveSocket ctxt Pub (iopubPort profile) $ iopub debug channels return channels @@ -132,9 +132,9 @@ num = reverse (takeWhile isNumber (reverse s)) bindLocalEphemeralPort :: Socket a -> IO Int -bindLocalEphemeralPort socket = do - bind socket $ "tcp://127.0.0.1:*" - endpointString <- lastEndpoint socket +bindLocalEphemeralPort sock = do + bind sock $ "tcp://127.0.0.1:*" + endpointString <- lastEndpoint sock case parsePort endpointString of Nothing -> fail $ "internalError: IHaskell.IPython.ZeroMQ.bindLocalEphemeralPort encountered a port index that could not be interpreted as an int." @@ -152,19 +152,19 @@ withEphemeralPorts key debug callback = do channels <- newZeroMQInterface key -- Create the ZMQ4 context - withContext $ \context -> do + withContext $ \ctxt -> do -- Create the sockets to communicate with. - withSocket context Rep $ \heartbeatSocket -> do - withSocket context Router $ \controlportSocket -> do - withSocket context Router $ \shellportSocket -> do - withSocket context Pub $ \iopubSocket -> do + withSocket ctxt Rep $ \heartbeatSocket -> do + withSocket ctxt Router $ \controlportSocket -> do + withSocket ctxt Router $ \shellportSocket -> do + withSocket ctxt Pub $ \iopubSocket -> do -- Bind each socket to a local port, getting the port chosen. - hbPort <- bindLocalEphemeralPort heartbeatSocket - controlPort <- bindLocalEphemeralPort controlportSocket - shellPort <- bindLocalEphemeralPort shellportSocket - iopubPort <- bindLocalEphemeralPort iopubSocket + hbPt <- bindLocalEphemeralPort heartbeatSocket + controlPt <- bindLocalEphemeralPort controlportSocket + shellPt <- bindLocalEphemeralPort shellportSocket + iopubPt <- bindLocalEphemeralPort iopubSocket -- Create object to store ephemeral ports - let ports = ZeroMQEphemeralPorts { ephHbPort = hbPort, ephControlPort = controlPort, ephShellPort = shellPort, ephIOPubPort = iopubPort, ephSignatureKey = key } + let ports = ZeroMQEphemeralPorts hbPt controlPt shellPt iopubPt key -- Launch actions to listen to communicate between channels and cockets. _ <- forkIO $ forever $ heartbeat channels heartbeatSocket _ <- forkIO $ forever $ control debug channels controlportSocket @@ -180,44 +180,44 @@ -- Create the context in a separate thread that never finishes. If withContext or withSocket -- complete, the context or socket become invalid. - forkIO $ withContext $ \context -> + _ <- forkIO $ withContext $ \ctxt -> -- Serve on all sockets. - serveSocket context Router (stdinPort profile) $ \socket -> do + serveSocket ctxt Router (stdinPort profile) $ \sock -> do -- Read the request from the interface channel and send it. - readChan reqChannel >>= sendMessage False (signatureKey profile) socket + readChan reqChannel >>= sendMessage False (signatureKey profile) sock -- Receive a response and write it to the interface channel. - receiveMessage False socket >>= writeChan repChannel + receiveMessage False sock >>= 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. +-- | Serve on a given sock in a separate thread. Bind the sock in the | given context and then +-- loop the provided action, which should listen | on the sock 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 +serveSocket ctxt socketType port action = void $ + withSocket ctxt socketType $ \sock -> do + bind sock $ "tcp://127.0.0.1:" ++ show port + forever $ action sock -- | Listener on the heartbeat port. Echoes back any data it was sent. heartbeat :: ZeroMQInterface -> Socket Rep -> IO () -heartbeat _ socket = do +heartbeat _ sock = do -- Read some data. - request <- receive socket + request <- receive sock -- Send it back. - send socket [] request + send sock [] 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 :: Bool -> ZeroMQInterface -> Socket Router -> IO () -shell debug channels socket = do +shell debug channels sock = do -- Receive a message and write it to the interface channel. - receiveMessage debug socket >>= writeChan requestChannel + receiveMessage debug sock >>= writeChan requestChannel -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage debug (hmacKey channels) socket + readChan replyChannel >>= sendMessage debug (hmacKey channels) sock where requestChannel = shellRequestChannel channels @@ -227,12 +227,12 @@ -- each message, reads a response from the | shell reply channel of the interface and sends it back -- to the frontend. control :: Bool -> ZeroMQInterface -> Socket Router -> IO () -control debug channels socket = do +control debug channels sock = do -- Receive a message and write it to the interface channel. - receiveMessage debug socket >>= writeChan requestChannel + receiveMessage debug sock >>= writeChan requestChannel -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage debug (hmacKey channels) socket + readChan replyChannel >>= sendMessage debug (hmacKey channels) sock where requestChannel = controlRequestChannel channels @@ -241,33 +241,33 @@ -- | Send messages via the iopub channel. | This reads messages from the ZeroMQ iopub interface -- channel | and then writes the messages to the socket. iopub :: Bool -> ZeroMQInterface -> Socket Pub -> IO () -iopub debug channels socket = - readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) socket +iopub debug channels sock = + readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) sock -- | Attempt to send a message along the socket, returning true if successful. trySendMessage :: Sender a => String -> Bool -> ByteString -> Socket a -> Message -> IO Bool -trySendMessage nm debug hmacKey socket message = do +trySendMessage _ debug hmackey sock msg = do let zmqErrorHandler :: ZMQError -> IO Bool zmqErrorHandler e -- Ignore errors if we cannot send. We may want to forward this to the thread that tried put the -- message in the Chan initially. | errno e == 38 = return False | otherwise = throwIO e - (sendMessage debug hmacKey socket message >> return True) `catch` zmqErrorHandler + (sendMessage debug hmackey sock msg >> return True) `catch` zmqErrorHandler -- | Send messages via the iopub channel. This reads messages from the ZeroMQ iopub interface -- channel and then writes the messages to the socket. This is a checked implementation which will -- stop if the socket is closed. checkedIOpub :: Bool -> ZeroMQInterface -> Socket Pub -> IO () -checkedIOpub debug channels socket = do +checkedIOpub debug channels sock = do msg <- readChan (iopubChannel channels) - cont <- trySendMessage "io" debug (hmacKey channels) socket msg + cont <- trySendMessage "io" debug (hmacKey channels) sock msg when cont $ - checkedIOpub debug channels socket + checkedIOpub debug channels sock -- | Receive and parse a message from a socket. receiveMessage :: Receiver a => Bool -> Socket a -> IO Message -receiveMessage debug socket = do +receiveMessage debug sock = do -- Read all identifiers until the identifier/message delimiter. idents <- readUntil "" @@ -285,12 +285,11 @@ putStr "Content: " Char.putStrLn content - let message = parseMessage idents headerData parentHeader metadata content - return message + return $ parseMessage idents headerData parentHeader metadata content where -- Receive the next piece of data from the socket. - next = receive socket + next = receive sock -- Read data from the socket until we hit an ending string. Return all data as a list, which does -- not include the ending string. @@ -306,10 +305,10 @@ -- socket. Sign it using HMAC with SHA-256 using the provided key. sendMessage :: Sender a => Bool -> ByteString -> Socket a -> Message -> IO () sendMessage _ _ _ SendNothing = return () -sendMessage debug hmacKey socket message = do +sendMessage debug hmackey sock msg = do when debug $ do putStr "Message: " - print message + print msg putStr "Sent: " print content @@ -325,8 +324,8 @@ sendLast content where - sendPiece = send socket [SendMore] - sendLast = send socket [] + sendPiece = send sock [SendMore] + sendLast = send sock [] -- Encode to a strict bytestring. encodeStrict :: ToJSON a => a -> ByteString @@ -338,12 +337,14 @@ -- Compute the HMAC SHA-256 signature of a bytestring message. hmac :: ByteString -> ByteString - hmac = Char.pack . show . (HMAC.hmacGetDigest :: HMAC.HMAC SHA256 -> Hash.Digest SHA256) . HMAC.hmac hmacKey + hmac = (Encoding.convertToBase Encoding.Base16 :: Hash.Digest SHA256 -> ByteString) + . HMAC.hmacGetDigest + . HMAC.hmac hmackey -- Pieces of the message. - head = header message - parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head - idents = identifiers head + hdr = header msg + parentHeaderStr = maybe "{}" encodeStrict $ mhParentHeader hdr + idents = mhIdentifiers hdr metadata = "{}" - content = encodeStrict message - headStr = encodeStrict head + content = encodeStrict msg + headStr = encodeStrict hdr