Disable stdin for widgets

ihaskell-display/ihaskell-widgets/Examples/Introduction to Widgets.ipynb

@@ -1350,7 +1350,7 @@
    "cell_type": "markdown",
    "metadata": {},
    "source": [
-    "The button widget also provides a click handler. We can make it do anything, except console input."
+    "The button widget also provides a click handler. We can make it do anything, except console input. Universally, no widget event can trigger console input."
    ]
   },
   {
@@ -1366,10 +1366,145 @@
      },
      "metadata": {},
      "output_type": "display_data"
+    },
+    {
+     "data": {
+      "text/html": [
+       "<style>/*\n",
+       "Custom IHaskell CSS.\n",
+       "*/\n",
+       "\n",
+       "/* Styles used for the Hoogle display in the pager */\n",
+       ".hoogle-doc {\n",
+       "    display: block;\n",
+       "    padding-bottom: 1.3em;\n",
+       "    padding-left: 0.4em;\n",
+       "}\n",
+       ".hoogle-code {\n",
+       "    display: block;\n",
+       "    font-family: monospace;\n",
+       "    white-space: pre;\n",
+       "}\n",
+       ".hoogle-text {\n",
+       "    display: block;\n",
+       "}\n",
+       ".hoogle-name {\n",
+       "    color: green;\n",
+       "    font-weight: bold;\n",
+       "}\n",
+       ".hoogle-head {\n",
+       "    font-weight: bold;\n",
+       "}\n",
+       ".hoogle-sub {\n",
+       "    display: block;\n",
+       "    margin-left: 0.4em;\n",
+       "}\n",
+       ".hoogle-package {\n",
+       "    font-weight: bold;\n",
+       "    font-style: italic;\n",
+       "}\n",
+       ".hoogle-module {\n",
+       "    font-weight: bold;\n",
+       "}\n",
+       ".hoogle-class {\n",
+       "    font-weight: bold;\n",
+       "}\n",
+       "\n",
+       "/* Styles used for basic displays */\n",
+       ".get-type {\n",
+       "    color: green;\n",
+       "    font-weight: bold;\n",
+       "    font-family: monospace;\n",
+       "    display: block;\n",
+       "    white-space: pre-wrap;\n",
+       "}\n",
+       "\n",
+       ".show-type {\n",
+       "    color: green;\n",
+       "    font-weight: bold;\n",
+       "    font-family: monospace;\n",
+       "    margin-left: 1em;\n",
+       "}\n",
+       "\n",
+       ".mono {\n",
+       "    font-family: monospace;\n",
+       "    display: block;\n",
+       "}\n",
+       "\n",
+       ".err-msg {\n",
+       "    color: red;\n",
+       "    font-style: italic;\n",
+       "    font-family: monospace;\n",
+       "    white-space: pre;\n",
+       "    display: block;\n",
+       "}\n",
+       "\n",
+       "#unshowable {\n",
+       "    color: red;\n",
+       "    font-weight: bold;\n",
+       "}\n",
+       "\n",
+       ".err-msg.in.collapse {\n",
+       "  padding-top: 0.7em;\n",
+       "}\n",
+       "\n",
+       "/* Code that will get highlighted before it is highlighted */\n",
+       ".highlight-code {\n",
+       "    white-space: pre;\n",
+       "    font-family: monospace;\n",
+       "}\n",
+       "\n",
+       "/* Hlint styles */\n",
+       ".suggestion-warning { \n",
+       "    font-weight: bold;\n",
+       "    color: rgb(200, 130, 0);\n",
+       "}\n",
+       ".suggestion-error { \n",
+       "    font-weight: bold;\n",
+       "    color: red;\n",
+       "}\n",
+       ".suggestion-name {\n",
+       "    font-weight: bold;\n",
+       "}\n",
+       "</style><span class='err-msg'>Widgets cannot do console input, sorry :)</span>"
+      ],
+      "text/plain": [
+       "Widgets cannot do console input, sorry :)"
+      ]
+     },
+     "metadata": {},
+     "output_type": "display_data"
     }
    ],
    "source": [
-    "setField button SClickHandler $ putStrLn \"fO_o\""
+    "setField button SClickHandler $ putStrLn \"fO_o\"\n",
+    "button -- Displaying again for convenience"
+   ]
+  },
+  {
+   "cell_type": "markdown",
+   "metadata": {},
+   "source": [
+    "Now try clicking the button, and see the output. If we try to do console input, an error occurs."
+   ]
+  },
+  {
+   "cell_type": "code",
+   "execution_count": 15,
+   "metadata": {
+    "collapsed": false
+   },
+   "outputs": [
+    {
+     "data": {
+      "text/plain": []
+     },
+     "metadata": {},
+     "output_type": "display_data"
+    }
+   ],
+   "source": [
+    "setField button SClickHandler $ getLine >>= putStrLn"
    ]
   }
  ],

ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal

@@ -101,6 +101,7 @@ library
                      , vector -any
                      , singletons >= 0.9.0
                      , scientific -any
+                     , unix -any
 
                        -- Waiting for the next release
                      , ihaskell -any

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs

@@ -52,10 +52,14 @@ module IHaskell.Display.Widgets.Types where
 -- To know more about the IPython messaging specification (as implemented in this package) take a look
 -- at the supplied MsgSpec.md.
 
-import Control.Monad (unless, join)
+import Control.Monad (unless, join, when, void)
 import Control.Applicative ((<$>))
 import qualified Control.Exception as Ex
 
+import GHC.IO.Exception
+import System.IO.Error
+import System.Posix.IO
+
 import Data.Aeson
 import Data.Aeson.Types (Pair)
 import Data.IORef (IORef, readIORef, modifyIORef)
@@ -593,18 +597,35 @@ properties widget = do
       convert attr = Const { getConst = _field attr }
   return $ recordToList . rmap convert . _getState $ st
 
+-- Helper function for widget to enforce their inability to fetch console input
+noStdin :: IO a -> IO ()
+noStdin action =
+  let handler :: IOException -> IO ()
+      handler e = when (ioeGetErrorType e == InvalidArgument)
+                    (error "Widgets cannot do console input, sorry :)")
+  in Ex.handle handler $ do
+    nullFd <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags
+    oldStdin <- dup stdInput
+    void $ dupTo nullFd stdInput
+    closeFd nullFd
+    void action
+    void $ dupTo oldStdin stdInput
+
 -- Trigger events
+triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO ()
+triggerEvent sfield w = noStdin . join $ getField w sfield
+
 triggerChange :: (ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
-triggerChange w = join $ getField w SChangeHandler
+triggerChange = triggerEvent SChangeHandler
 
 triggerClick :: (ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
-triggerClick w = join $ getField w SClickHandler
+triggerClick = triggerEvent SClickHandler
 
 triggerSelection :: (SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
-triggerSelection w = join $ getField w SSelectionHandler
+triggerSelection = triggerEvent SSelectionHandler
 
 triggerSubmit :: (SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
-triggerSubmit w = join $ getField w SSubmitHandler
+triggerSubmit = triggerEvent SSubmitHandler
 
 triggerDisplay :: (DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
-triggerDisplay w = join $ getField w SDisplayHandler
+triggerDisplay = triggerEvent SDisplayHandler