module Dialog.RunWebkitGtk3 (
runDialogUsingWebkitGtk3
) where
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Exception (SomeException, finally, catch)
import Control.Concurrent (forkOS)
import Control.Concurrent.MVar (
MVar, newMVar, newEmptyMVar, 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 SharedState = SharedState {
shrWindow :: Gtk.Window,
shrWebView :: WV.WebView,
shrWakeUpDialog :: MVar (),
shrExitRequested :: MVar (),
shrNoRunningDialog :: MVar ()
}
data PrivateState = PrivateState {
privEndMessageRef :: IORef String
}
executeScriptTL :: WV.WebView -> TL.Text -> IO ()
executeScriptTL webView script =
WV.webViewExecuteScript webView (TL.toStrict script)
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
_ <- 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)
couldOpenBrowser <- liftIO (openBrowser uri)
when (not couldOpenBrowser) $
liftIO (executeScriptTL webView
("couldNotOpenBrowser(" <> strJSON uri <> ")"))
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 ()
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
setWindowTitle "Dialog"
postScriptTL "dialogReset()"
runActions 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 :: IO ()
stopExistingDialog = do
putMVar (shrExitRequested shared) ()
putMVar (shrWakeUpDialog shared) ()
_ <- takeMVar (shrNoRunningDialog shared)
pure ()
clearStatusMVars :: IO ()
clearStatusMVars = do
_ <- tryTakeMVar (shrWakeUpDialog shared)
_ <- tryTakeMVar (shrExitRequested shared)
pure ()
runActions :: forall a . DialogIO a -> IO a
runActions = \case
Pure value -> pure value
Bind func ->
func handleBind
where
handleBind :: forall b . DialogIO b -> (b -> DialogIO a) -> IO a
handleBind action getNextAction = do
result <- runActions action
handleExitRequest
undefined
(runActions (getNextAction result))
Lift action ->
action
ChangeTitle title ->
setWindowTitle title
ChangeEndMessage endMessage ->
writeIORef (privEndMessageRef priv) endMessage
Display paragraphs ->
postScriptTL ("dialogDisplay(" <> paragraphsToJSON paragraphs <> ")")
AskLine prompt ->
awaitScriptOutput
(postScriptTL ("dialogAskLine(" <> strJSON prompt <> ")"))
setWindowTitle :: String -> IO ()
setWindowTitle title =
Gtk.postGUISync (GA.set (shrWindow shared) [Gtk.windowTitle := title])
postScriptTL :: TL.Text -> IO ()
postScriptTL script =
Gtk.postGUISync (executeScriptTL (shrWebView shared) 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)