ipython-kernel 0.9.1.0 → 0.10.0.0
raw patch · 10 files changed
+353/−342 lines, 10 filesdep +cereal-textdep ~base
Dependencies added: cereal-text
Dependency ranges changed: base
Files
- examples/Calc.hs +1/−0
- examples/Simple.hs +1/−0
- ipython-kernel.cabal +5/−3
- src/IHaskell/IPython/EasyKernel.hs +21/−30
- src/IHaskell/IPython/Kernel.hs +0/−1
- src/IHaskell/IPython/Message/Parser.hs +10/−18
- src/IHaskell/IPython/Message/UUID.hs +1/−1
- src/IHaskell/IPython/Message/Writer.hs +0/−199
- src/IHaskell/IPython/Types.hs +250/−27
- src/IHaskell/IPython/ZeroMQ.hs +64/−63
examples/Calc.hs view
@@ -221,6 +221,7 @@ , languageVersion = "1.0.0" , languageFileExtension = ".txt" , languageCodeMirrorMode = "null"+ , languagePygmentsLexer = "Text" } , writeKernelspec = const $ return $ KernelSpec { kernelDisplayName = "Hutton's Razor"
examples/Simple.hs view
@@ -61,6 +61,7 @@ , languageVersion = "1.0.0" , languageFileExtension = ".txt" , languageCodeMirrorMode = "null"+ , languagePygmentsLexer = "Text" } languageKernelspec :: KernelSpec
ipython-kernel.cabal view
@@ -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 ,
src/IHaskell/IPython/EasyKernel.hs view
@@ -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 }
src/IHaskell/IPython/Kernel.hs view
@@ -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
src/IHaskell/IPython/Message/Parser.hs view
@@ -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
src/IHaskell/IPython/Message/UUID.hs view
@@ -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)
− src/IHaskell/IPython/Message/Writer.hs
@@ -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
src/IHaskell/IPython/Types.hs view
@@ -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
src/IHaskell/IPython/ZeroMQ.hs view
@@ -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 "<IDS|MSG>" @@ -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