Kernel.hs

{-|
Module      : Jupyter.Test.Kernel
Description : Tests for the Jupyter.Kernel module.
Copyright   : (c) Andrew Gibiansky, 2016
License     : MIT
Maintainer  : andrew.gibiansky@gmail.com
Stability   : stable
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
module Jupyter.Test.Kernel (kernelTests) where

-- Imports from 'base'
import           Control.Concurrent (newEmptyMVar, MVar, forkIO, putMVar, takeMVar, readMVar,
                                     killThread)
import           Control.Exception (throwIO)
import           Control.Monad (forM_, void)
import           Data.Proxy (Proxy(Proxy))

-- Imports from 'async'
import           Control.Concurrent.Async (async, wait, cancel)

-- Imports from 'transformers'
import           Control.Monad.IO.Class (liftIO)

-- Imports from 'tasty'
import           Test.Tasty (TestTree, testGroup)

-- Imports from 'tasty-hunit'
import           Test.Tasty.HUnit (testCase, testCaseSteps, (@=?))

-- Imports from 'aeson'
import           Data.Aeson (object)

-- Imports from 'zeromq4-haskell'
import           System.ZMQ4.Monadic (Req(..), Dealer(..), send, receive, runZMQ, ZMQError)

-- Imports from 'jupyter'
import           Jupyter.Client
import           Jupyter.Kernel
import           Jupyter.Messages
import           Jupyter.Messages.Internal
import           Jupyter.ZeroMQ
import qualified Jupyter.UUID as UUID

import           Jupyter.Test.Utils (connectedSocket, shouldThrow, HandlerException(..))

kernelTests :: TestTree
kernelTests = testGroup "Kernel Tests"
                [testKernel, testKernelPortsTaken, testKernelExceptions, testKernelServeDynamic]

-- | Test that a ZMQError is thrown if we try to serve two kernels on the same profile, because the
-- second one should fail due to the ports already being taken.
testKernelPortsTaken :: TestTree
testKernelPortsTaken = testCase "Kernel Ports Taken" $ do
  profileVar <- newEmptyMVar
  let reqHandler cb req = do
        profile <- readMVar profileVar
        defaultClientRequestHandler profile (simpleKernelInfo "Test") cb req
  thread <- async $ serveDynamic (putMVar profileVar) defaultCommHandler reqHandler
  profile <- readMVar profileVar
  serve profile defaultCommHandler reqHandler `shouldThrow` (Proxy :: Proxy ZMQError)
  cancel thread

-- | Test that a client can connect to a kernel when the kernel is started with serveDynamic.
-- second one should fail due to the ports already being taken.
testKernelServeDynamic :: TestTree
testKernelServeDynamic = testCase "Serve Dynamic with Client" $ do
  -- Set up the dynamic-ported kernel.
  profileVar <- newEmptyMVar
  let reqHandler cb req = do
        profile <- readMVar profileVar
        defaultClientRequestHandler profile (simpleKernelInfo "Test") cb req
  thread <- async $ serveDynamic (putMVar profileVar) defaultCommHandler reqHandler
  profile <- readMVar profileVar

  -- Connect a client to it.
  runClient (Just profile) Nothing emptyHandler $ \profile' -> do
    -- Ensure that the received profile is the same as assigned.
    liftIO $ profile' @=? profile

    -- Do a simple back-and-forth.
    connection <- connectKernel
    KernelInfoReply info <- sendClientRequest connection KernelInfoRequest
    liftIO $ info @=? simpleKernelInfo "Test"

  -- Kill the kernel thread.
  cancel thread
  where
      emptyHandler =
          ClientHandlers (const . const . return $ InputReply "")
                         (const . const $ return ())
                         (const . const $ return ())

-- | Test the behaviour of the kernel if the kernel handlers throw exceptions.
testKernelExceptions :: TestTree
testKernelExceptions = testCaseSteps "Kernel Exceptions" $ \step -> do
  profileVar <- newEmptyMVar

  let sendShellMsg msg =
        runZMQ $ do
          profile <- liftIO $ readMVar profileVar
          shellClientSocket <- connectedSocket profile profileShellPort Dealer
          header <- liftIO $ mkFreshTestHeader msg
          sendMessage "" shellClientSocket header msg

  -- Test that when the client request handler throws an error, the error is
  -- propagated to the main thread.
  step "Testing broken request handler..."
  thread1 <- async $ serveDynamic (putMVar profileVar) defaultCommHandler brokenHandler
  sendShellMsg ConnectRequest
  wait thread1 `shouldThrow` [HandlerException]

  -- Test that when the comm handler throws an error, the error is
  -- propagated to the main thread.
  step "Testing broken comm handler..."
  void $ takeMVar profileVar
  thread2 <- async $ serveDynamic (putMVar profileVar) brokenHandler (reqHandler profileVar)
  sendShellMsg $ CommMessage (UUID.uuidFromString "test") (object [])
  wait thread2 `shouldThrow` [HandlerException]
 
  where
    reqHandler var cb req = do
      profile <- readMVar var
      defaultClientRequestHandler profile (simpleKernelInfo "Test") cb req

    brokenHandler _ _ = throwIO HandlerException

-- | Test that communication on the heartbeat and shell sockets works as intended.
testKernel :: TestTree
testKernel = testCaseSteps "Simple Kernel" $ \step -> do
  -- Start serving the kernel and obtain the port info so we can connect to it.
  step "Starting kernel..."
  profileVar <- newEmptyMVar
  clientMessageVar <- newEmptyMVar
  threadId <- forkIO $ serveDynamic (putMVar profileVar) defaultCommHandler (reqHandler profileVar clientMessageVar)
  profile <- readMVar profileVar

  runZMQ $ do
    -- Obtain the sockets
    liftIO $ step "Connecting to kernel..."
    heartbeatClientSocket <- connectedSocket profile profileHeartbeatPort Req
    shellClientSocket <- connectedSocket profile profileShellPort Dealer

    -- Check that every message sent to the heartbeat socket is echoed back
    liftIO $ step "Checking heartbeat..."
    let message = "heartbeat"
    send heartbeatClientSocket [] message
    response <- receive heartbeatClientSocket
    liftIO $ message @=? response

    -- Check that every message we sent to the shell socket is received
    -- in exactly the way it was sent.
    liftIO $ step "Checking client request encoding / decoding..."
    forM_ clientMessages $ \msg -> do
      header <- liftIO $ mkFreshTestHeader msg
      sendMessage "" shellClientSocket header msg
      received <- liftIO $ takeMVar clientMessageVar
      liftIO $ msg @=? received

  killThread threadId
  where
    kernelInfo :: KernelInfo
    kernelInfo = KernelInfo
      { kernelProtocolVersion = "1.2.3"
      , kernelBanner = "Banner"
      , kernelImplementation = "kernel"
      , kernelImplementationVersion = "1.0.0"
      , kernelHelpLinks = []
      , kernelLanguageInfo = LanguageInfo
        { languageName = "Test"
        , languageVersion = "1.0.0"
        , languageMimetype = "text/plain"
        , languageFileExtension = ".txt"
        , languagePygmentsLexer = Nothing
        , languageCodeMirrorMode = Nothing
        , languageNbconvertExporter = Nothing
        }
      }

    -- Request handler for the kernel. It responds with the default reply, but also
    -- writes the client request to the provided 'MVar', so that it can be inspected
    -- and compared with the client request that was actually sent.
    reqHandler :: MVar KernelProfile -> MVar ClientRequest -> ClientRequestHandler
    reqHandler profileVar clientMessageVar cb req = do
      putMVar clientMessageVar req
      profile <- readMVar profileVar
      defaultClientRequestHandler profile kernelInfo cb req

    clientMessages = [ ExecuteRequest (CodeBlock "1 + 1")
                         ExecuteOptions
                           { executeSilent = False
                           , executeStoreHistory = True
                           , executeAllowStdin = False
                           , executeStopOnError = True
                           }
                     , InspectRequest (CodeBlock "print 'X'") 5 DetailLow
                     , InspectRequest (CodeBlock "print 'X'") 5 DetailHigh
                     , HistoryRequest
                         HistoryOptions
                           { historyShowOutput = True
                           , historyRaw = True
                           , historyAccessType = HistoryTail 3
                           }
                     , HistoryRequest
                         HistoryOptions
                           { historyShowOutput = True
                           , historyRaw = True
                           , historyAccessType = HistoryRange
                                                   HistoryRangeOptions
                                                     { historyRangeSession = -1
                                                     , historyRangeStart = 10
                                                     , historyRangeStop = 100
                                                     }
                           }
                     , HistoryRequest
                         HistoryOptions
                           { historyShowOutput = True
                           , historyRaw = True
                           , historyAccessType = HistorySearch
                                                   HistorySearchOptions
                                                     { historySearchCells = 10
                                                     , historySearchPattern = "putStr*"
                                                     , historySearchUnique = True
                                                     }
                           }
                     , CompleteRequest (CodeBlock "putStrL + 3") 7
                     , IsCompleteRequest (CodeBlock "let x = 3 in")
                     , ConnectRequest
                     , CommInfoRequest Nothing
                     , CommInfoRequest (Just (TargetName "comm_target"))
                     , KernelInfoRequest
                     ]

-- | Make a new 'MessageHeader', with a random session and id.
mkFreshTestHeader :: IsMessage v => v -> IO MessageHeader
mkFreshTestHeader content = do
  uuid <- UUID.random
  sess <- UUID.random
  return
    MessageHeader
      { messageIdentifiers = ["ABC", "DEF"]
      , messageParent = Nothing
      , messageMetadata = mempty
      , messageId = uuid
      , messageSession = sess
      , messageUsername = "test-user"
      , messageType = getMessageType content
      }