module Dialog.RunWebkitGtk3 (
runDialogUsingWebkitGtk3
) where
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Exception (SomeException, finally, catch)
import Control.Concurrent (forkIO, forkOS)
import Control.Concurrent.MVar (
MVar, newMVar, newEmptyMVar, readMVar, swapMVar, takeMVar, putMVar,
tryReadMVar, tryTakeMVar)
import Data.Maybe (isNothing)
import Data.Monoid ((<>))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import System.FilePath ((</>))
import System.Glib.Attributes (AttrOp ((:=)))
import Web.Browser (openBrowser)
import Paths_dialog (getDataFileName)
import Dialog.Internal
import Dialog.EncodeJSON
import qualified Data.Text.Lazy as TL
import qualified System.Glib.Attributes as GA
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.WebKit.WebView as WV
import qualified Graphics.UI.Gtk.WebKit.NetworkRequest as NR
import qualified Graphics.UI.Gtk.WebKit.WebPolicyDecision as WPD
import qualified Graphics.UI.Gtk.WebKit.DOM.Document as Document
import qualified Graphics.UI.Gtk.WebKit.DOM.HTMLElement as HTMLElement
import qualified Graphics.UI.Gtk.WebKit.DOM.Element as Element
import qualified Graphics.UI.Gtk.WebKit.DOM.EventM as EventM
data Message =
Ready |
AskLineAnswer String
data SharedState = SharedState {
shrWindow :: Gtk.Window,
shrWebView :: WV.WebView,
shrWakeUpDialog :: MVar (),
shrExitRequested :: MVar (),
shrNoRunningDialog :: MVar ()
}
runDialogUsingWebkitGtk3 :: MonadIO m => DialogIO () -> m ()
runDialogUsingWebkitGtk3 dialog = liftIO $ do
htmlPath <- getDataFileName "html"
let dialogHTML = "file://" ++ (htmlPath </> "dialog.html")
Gtk.initGUI
webView <- WV.webViewNew
WV.webViewLoadUri webView dialogHTML
scrolledWindow <- Gtk.scrolledWindowNew Nothing Nothing
Gtk.containerAdd scrolledWindow webView
window <- Gtk.windowNew
Gtk.windowSetDefaultSize window 900 600
Gtk.widgetSetSizeRequest window 480 320
GA.set window [Gtk.windowTitle := ("Dialog" :: String)]
Gtk.on window Gtk.deleteEvent $ do
liftIO Gtk.mainQuit
pure False
Gtk.containerAdd window scrolledWindow
Gtk.widgetShowAll window
wakeUpDialog <- newEmptyMVar
exitRequested <- newEmptyMVar
noRunningDialog <- newMVar ()
let shared = SharedState {
shrWindow = window,
shrWebView = webView,
shrWakeUpDialog = wakeUpDialog,
shrExitRequested = exitRequested,
shrNoRunningDialog = noRunningDialog
}
Gtk.on webView WV.navigationPolicyDecisionRequested $
\_ request _ decision -> do
maybeURI <- liftIO $ NR.networkRequestGetUri request
case maybeURI of
Just uri -> do
when (uri /= dialogHTML) $ do
liftIO $ WPD.webPolicyDecisionIgnore decision
liftIO $ openBrowser uri
pure ()
pure False
Nothing -> pure False
Gtk.on webView WV.documentLoadFinished $ \_ -> do
Just document <- WV.webViewGetDomDocument webView
Just scriptOutput <-
Document.getElementById document ("script-output" :: String)
scriptOutputListener <- liftIO $ EventM.newListener $ do
liftIO $ putMVar wakeUpDialog ()
EventM.addListener scriptOutput Element.click scriptOutputListener False
Just resetButton <-
Document.getElementById document ("reset-button" :: String)
resetButtonListener <- liftIO $ EventM.newListener $ do
liftIO $ runDialogThread shared dialog
EventM.addListener resetButton Element.click resetButtonListener False
runDialogThread shared dialog
Gtk.mainGUI
pure ()
data PrivateState = PrivateState {
privEndMessageRef :: IORef String
}
runDialogThread :: SharedState -> DialogIO () -> IO ()
runDialogThread shared dialog = do
endMessageRef <- newIORef "End of program."
let priv = PrivateState {
privEndMessageRef = endMessageRef
}
_ <- forkOS (dialogThreadMain shared priv dialog)
pure ()
dialogThreadMain :: SharedState -> PrivateState -> DialogIO () -> IO ()
dialogThreadMain shared priv dialog =
finally
(catch
(do
stopExistingDialog
clearStatusMVars
postScriptTL "dialogReset()"
runCommands dialog
handleExitRequest
(pure ())
(do
endMessage <- readIORef (privEndMessageRef priv)
postScriptTL ("dialogEnd(" <> strJSON endMessage <> ")")))
(\(e :: SomeException) ->
handleExitRequest
(pure ())
(postScriptTL ("dialogException(" <> strJSON (show e) <> ")"))))
(putMVar (shrNoRunningDialog shared) ())
where
handleExitRequest :: IO a -> IO a -> IO a
handleExitRequest ifExitting ifContinuing = do
exitRequested <- tryReadMVar (shrExitRequested shared)
if isNothing exitRequested
then ifContinuing
else ifExitting
stopExistingDialog = do
putMVar (shrExitRequested shared) ()
putMVar (shrWakeUpDialog shared) ()
takeMVar (shrNoRunningDialog shared)
clearStatusMVars = do
tryTakeMVar (shrWakeUpDialog shared)
tryTakeMVar (shrExitRequested shared)
runCommands :: forall a . DialogIO a -> IO a
runCommands = \case
Pure value -> pure value
Bind func ->
func handleBind
where
handleBind :: forall b . DialogIO b -> (b -> DialogIO a) -> IO a
handleBind dialog getNextDialog = do
result <- runCommands dialog
handleExitRequest
undefined
(runCommands (getNextDialog result))
Lift action ->
action
ChangeTitle title ->
Gtk.postGUISync (GA.set (shrWindow shared) [Gtk.windowTitle := title])
ChangeEndMessage endMessage ->
writeIORef (privEndMessageRef priv) endMessage
Display paragraphs ->
postScriptTL ("dialogDisplay(" <> paragraphsToJSON paragraphs <> ")")
AskLine prompt ->
awaitScriptOutput
(postScriptTL ("dialogAskLine(" <> strJSON prompt <> ")"))
postScriptTL script =
Gtk.postGUISync
(WV.webViewExecuteScript (shrWebView shared) (TL.toStrict script))
awaitScriptOutput :: IO () -> IO String
awaitScriptOutput action = do
action
takeMVar (shrWakeUpDialog shared)
handleExitRequest
undefined
(Gtk.postGUISync $ do
Just document <- WV.webViewGetDomDocument (shrWebView shared)
Just scriptOutput <-
Document.getElementById document ("script-output" :: String)
Just string <-
HTMLElement.getInnerText
(HTMLElement.castToHTMLElement scriptOutput)
pure string)