{-# Language CPP #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.CEF3.Simple -- License : BSD-style (see the file LICENSE) -- Copyright : Maksymilian Owsianny -- Maintainer : Maksymilian.Owsianny@gmail.com -- -- This is a WIP package containing helper functions for some commonly used -- tasks around cef3-raw. -- -- For example, to create a browser window and start it with google webpage: -- -- @ -- main :: IO () -- main = handleSubProcess $ do -- startBrowserUrl "http://google.com" -- @ -- -------------------------------------------------------------------------------- module Graphics.CEF3.Simple ( startBrowserUrl , handleSubProcess ) where import Control.Monad (unless, void) import Data.List (isPrefixOf) import Foreign.C import Foreign.Ptr import Foreign.Marshal hiding (void) import Foreign.Storable import System.Environment #if defined(mingw32_HOST_OS) import Graphics.Win32 import System.Win32.DLL import Data.Bits ((.|.)) #endif import Bindings.CEF3 -- | Starts the browser window with specified URL startBrowserUrl :: String -> IO () startBrowserUrl url = do mainArgs <- initMainArgs app <- initialize_app_handler settings <- mkCefSettings void $ c'cef_initialize mainArgs settings app nullPtr startBrowserWindow url c'cef_run_message_loop c'cef_shutdown -- | Handle the cef subprocesses handleSubProcess :: IO () -> IO () handleSubProcess cont = do haskArgs <- getArgs if any (isPrefixOf "--type=") haskArgs then do putStrLn $ "Starting subprocess: " ++ unwords haskArgs mainArgs <- initMainArgs app <- initialize_app_handler void $ c'cef_execute_process mainArgs app nullPtr else cont initMainArgs :: IO (Ptr C'cef_main_args_t) initMainArgs = do #if defined(mingw32_HOST_OS) mainInstance <- getModuleHandle Nothing new $ C'cef_main_args_t mainInstance #elif defined(linux_HOST_OS) haskArgs <- getArgs argv <- mapM newCString . (:haskArgs) =<< getProgName let argc = fromIntegral . length $ argv pargv <- newArray argv new $ C'cef_main_args_t argc pargv #endif startBrowserWindow :: String -> IO () startBrowserWindow url = do let windowTitle = "CEF3" windowInfo <- createWindowInfo windowTitle client <- initialize_client_handler cefUrl <- mkCefStringPtr url browserSettings <- mkBrowserSettings void $ c'cef_browser_host_create_browser windowInfo client cefUrl browserSettings nullPtr createWindowInfo :: String -> IO (Ptr C'cef_window_info_t) createWindowInfo windowTitle = do winName <- mkCefString windowTitle #if defined(mingw32_HOST_OS) new $ C'cef_window_info_t wS_EX_CLIENTEDGE winName (wS_OVERLAPPEDWINDOW .|. wS_CLIPCHILDREN .|. wS_CLIPSIBLINGS .|. wS_VISIBLE) (fromIntegral cW_USEDEFAULT) -- left (fromIntegral cW_USEDEFAULT) -- top (fromIntegral cW_USEDEFAULT) -- width (fromIntegral cW_USEDEFAULT) -- height nullPtr -- parent_window (HWND) nullPtr -- menu False -- window_rendering_disabled False -- transparent_painting nullPtr -- window (HWND) #elif defined(linux_HOST_OS) new $ C'cef_window_info_t nullPtr -- parent_window (GtkWidget) 0 -- window_rendering_disabled 0 -- transparent_painting nullPtr -- window (GtkWidget) #endif ---------------------------------------------------------------------- debugMsg :: String -> IO () #ifdef DEBUG debugMsg = putStrLn #else debugMsg _ = return () #endif mkCefString :: String -> IO C'cef_string_utf16_t mkCefString str = mkCefStringPtr str >>= peek -- Build a CEF utf16 string in memory from a Haskell string. mkCefStringPtr :: String -> IO (Ptr C'cef_string_utf16_t) mkCefStringPtr str = do let sz = fromIntegral . length $ str strC <- newCString str -- We need to allocate and *initialize* a space for the utf16 string. -- CEF will try to call its destructor if it has one, so failure to -- initialize results in segfault. pUtf16 <- new $ C'cef_string_utf16_t nullPtr 0 nullFunPtr void $ c'cef_string_utf8_to_utf16 strC sz pUtf16 return pUtf16 rtNull1 :: String -> a -> IO (Ptr b) rtNull1 s _ = debugMsg s >> return nullPtr rtVoid2 :: String -> a -> b -> IO () rtVoid2 s _ _ = debugMsg s >> return () rtVoid3 :: String -> a -> b -> c -> IO () rtVoid3 s _ _ _ = debugMsg s >> return () rtInt1 :: String -> a -> IO CInt rtInt1 s _ = debugMsg s >> return 1 rtInt2 :: String -> a -> b -> IO CInt rtInt2 s _ _ = debugMsg s >> return 1 initialize_cef_base :: IO C'cef_base_t initialize_cef_base = do debugMsg "initialize_cef_base" let sz = 0 C'cef_base_t <$> return sz <*> mk'cb_cef_base_add_ref (rtInt1 "cef_base_t.add_ref") <*> mk'cb_cef_base_release (rtInt1 "cef_base_t.release") <*> mk'cb_cef_base_get_refct (rtInt1 "cef_base_t.get_refct") initialize_app_handler :: IO (Ptr C'cef_app_t) initialize_app_handler = do debugMsg "initialize_app_handler" newWithSize (C'cef_app_t <$> initialize_cef_base <*> mk'cb_cef_app_on_before_command_line_processing (rtVoid3 "on_before_command_line_processing") <*> mk'cb_cef_app_on_register_custom_schemes (rtVoid2 "on_register_custom_schemes") <*> mk'cb_cef_app_get_resource_bundle_handler (rtNull1 "get_resource_bundle_handler") <*> mk'cb_cef_app_get_browser_process_handler (rtNull1 "get_browser_process_handler") <*> mk'cb_cef_app_get_render_process_handler (rtNull1 "get_render_process_handler") ) -- Allocate space for a new object, build the object, copy the object to -- the space, then store the size of the object. In CEF, size is always at -- byte offset 0. newWithSize :: Storable a => IO a -> IO (Ptr a) newWithSize mkObj = do obj <- mkObj let sz = sizeOf obj debugMsg $ "Size: "++ show sz ptr <- new obj pokeByteOff ptr 0 sz return ptr -- Settings for configuring CEF process behaviors mkCefSettings :: IO (Ptr C'cef_settings_t) mkCefSettings = newWithSize (C'cef_settings_t <$> return 0 -- dummy size, newWithSize will populate <*> return 0 -- single process <*> return 1 -- no_sandbox <*> mkCefString "" -- browser subprocess path <*> return 0 -- multithreaded message loop <*> return 1 -- command line args disabled <*> mkCefString "" -- cache path <*> return 0 -- persist session cookies <*> mkCefString "" -- user agent <*> mkCefString "" -- product version <*> mkCefString "" -- locale <*> mkCefString "" -- log file <*> return c'LOGSEVERITY_DEFAULT <*> return 0 -- release dcheck enabled <*> mkCefString "" -- javascript flags <*> mkCefString "" -- resources dir path <*> mkCefString "" -- locales dir path <*> return 0 -- pack loading disabled <*> return 0 -- remote debugging port <*> return 5 -- uncaught exception stack size <*> return 0 -- context safety implementation <*> return 0 -- ignore certificate errors <*> return 0 -- background color ) -- Settings for configuring the browser behavior mkBrowserSettings :: IO (Ptr C'cef_browser_settings_t) mkBrowserSettings = newWithSize (C'cef_browser_settings_t <$> return 0 -- dummy size, newWithSize will populate <*> mkCefString "" <*> mkCefString "" <*> mkCefString "" <*> mkCefString "" <*> mkCefString "" <*> mkCefString "" <*> return 14 -- default font size <*> return 10 <*> return 10 <*> return 10 <*> mkCefString ""-- default encoding <*> return c'STATE_DEFAULT -- remove_fonts <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return c'STATE_DEFAULT <*> return 0 -- background color ) -- Callbacks for events within the browser. initialize_client_handler :: IO (Ptr C'cef_client_t) initialize_client_handler = do debugMsg "initialize_client_handler" newWithSize (C'cef_client_t <$> initialize_cef_base <*> mk'cb_cef_client_get_context_menu_handler (rtNull1 "get_context_menu_handler") <*> mk'cb_cef_client_get_dialog_handler (rtNull1 "get_dialog_handler") <*> mk'cb_cef_client_get_display_handler (rtNull1 "get_display_handler") <*> mk'cb_cef_client_get_download_handler (rtNull1 "get_download_handler") <*> mk'cb_cef_client_get_drag_handler (rtNull1 "get_drag_handler") <*> mk'cb_cef_client_get_focus_handler (rtNull1 "get_focus_handler") <*> mk'cb_cef_client_get_geolocation_handler (rtNull1 "get_geolocation_handler") <*> mk'cb_cef_client_get_jsdialog_handler (rtNull1 "get_jsdialog_handler") <*> mk'cb_cef_client_get_keyboard_handler (rtNull1 "get_keyboard_handler") <*> mk'cb_cef_client_get_life_span_handler initialize_life_span_handler --(rtNull1 "get_life_span_handler") <*> mk'cb_cef_client_get_load_handler (rtNull1 "get_load_handler") <*> mk'cb_cef_client_get_render_handler (rtNull1 "get_render_handler") <*> mk'cb_cef_client_get_request_handler (rtNull1 "get_request_handler") <*> mk'cb_cef_client_on_process_message_received (\_ _ _ _ -> debugMsg "on_message_process_received" >> return 0) ) initialize_life_span_handler :: Ptr C'cef_client_t -> IO (Ptr C'cef_life_span_handler_t) initialize_life_span_handler _ = do debugMsg "initialize_life_span_handler" newWithSize (C'cef_life_span_handler_t <$> initialize_cef_base <*> mk'cb_cef_life_span_handler_on_before_popup (\_ _ _ _ _ _ _ _ _ _ -> debugMsg "on_before_popup" >> return 0) <*> mk'cb_cef_life_span_handler_on_after_created (rtVoid2 "on_after_created") <*> mk'cb_cef_life_span_handler_run_modal (rtInt2 "run_modal") <*> mk'cb_cef_life_span_handler_do_close (\_ _ -> do debugMsg "do_close" c'cef_quit_message_loop -- close global cef process return 0) -- allow browser close <*> mk'cb_cef_life_span_handler_on_before_close (rtVoid2 "on_before_close") )