diff --git a/Hbro/Core.hs b/Hbro/Core.hs new file mode 100644 --- /dev/null +++ b/Hbro/Core.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hbro.Core where + +-- {{{ Imports +import Hbro.Gui +import Hbro.Socket +import Hbro.Util + +import qualified Config.Dyre as Dyre +import Control.Concurrent +import Control.Monad.Trans(liftIO) +import Data.Map +import Graphics.UI.Gtk +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebInspector +import Graphics.UI.Gtk.WebKit.WebSettings +import Network.URL +import Prelude hiding (lookup) +import System.Environment +import System.Posix.Process +-- }}} + +-- {{{ Type definitions +data Browser = Browser { + mGUI :: GUI +} + +data Configuration = Configuration { + mHomePage :: String, -- ^ Startup page + mKeyBindings :: [(([Modifier], String), GUI -> IO ())], -- ^ List of keybindings + mWebSettings :: IO WebSettings, -- ^ Web settings + mCustomizations :: GUI -> IO (), -- ^ Custom callbacks + mError :: Maybe String -- ^ Error +} + +instance Ord Modifier where + m <= m' = fromEnum m <= fromEnum m' +-- }}} + +-- {{{ Entry point +-- | Entry point of the application. +-- Check if help display is requested. +realMain :: Configuration -> IO () +realMain configuration = do + args <- getArgs + + case args of + ["--help"] -> putStrLn "Usage: browser [url]" + _ -> initBrowser configuration +-- }}} + +-- {{{ Main function +-- | Application's main function. +-- Create browser and load homepage. +initBrowser :: Configuration -> IO () +initBrowser configuration = do + -- Initialize GUI + args <- initGUI + gui <- loadGUI "" + + -- Initialize IPC socket + pid <- getProcessID + _ <- forkIO $ createReplySocket ("ipc:///tmp/hbro." ++ (show pid)) gui + + -- Load configuration + settings <- mWebSettings configuration + webViewSetWebSettings (mWebView gui) settings + (mCustomizations configuration) gui + + -- Load url + let url = case args of + [arg] -> arg + _ -> mHomePage configuration + + webViewLoadUri (mWebView gui) url + + -- Load key bindings + let keyBindings = fromList (mKeyBindings configuration) + + -- Open all link in current window. + _ <- on (mWebView gui) createWebView $ \frame -> do + newUri <- webFrameGetUri frame + case newUri of + Just uri -> webViewLoadUri (mWebView gui) uri + Nothing -> return () + return (mWebView gui) + + -- Web inspector + inspector <- webViewGetInspector (mWebView gui) + _ <- on inspector inspectWebView $ \_ -> do + webView <- webViewNew + containerAdd (mInspectorWindow gui) webView + return webView + + _ <- on inspector showWindow $ do + widgetShowAll (mInspectorWindow gui) + return True + + -- TODO: when does this signal happen ?! + --_ <- on inspector finished $ return () + + _ <- on inspector attachWindow $ do + getWebView <- webInspectorGetWebView inspector + case getWebView of + Just webView -> do widgetHide (mInspectorWindow gui) + containerRemove (mInspectorWindow gui) webView + widgetSetSizeRequest webView (-1) 250 + boxPackEnd (mWindowBox gui) webView PackNatural 0 + widgetShow webView + return True + _ -> return False + + _ <- on inspector detachWindow $ do + getWebView <- webInspectorGetWebView inspector + _ <- case getWebView of + Just webView -> do containerRemove (mWindowBox gui) webView + containerAdd (mInspectorWindow gui) webView + widgetShowAll (mInspectorWindow gui) + return True + _ -> return False + + widgetShowAll (mInspectorWindow gui) + return True + + -- Key bindings + _ <- after (mWebView gui) keyPressEvent $ do + keyVal <- eventKeyVal + modifiers <- eventModifier + + let keyString = keyToString keyVal + + case keyString of + Just string -> do + case lookup (modifiers, string) keyBindings of + Just callback -> liftIO $ callback gui + _ -> liftIO $ putStrLn string + _ -> return () + + return False + + -- Connect and show. + _ <- onDestroy (mWindow gui) mainQuit + widgetShowAll (mWindow gui) + widgetHide (mPromptLabel gui) + widgetHide (mPrompt gui) + + mainGUI +-- }}} + +-- | Show web inspector for current webpage. +showWebInspector :: GUI -> IO () +showWebInspector gui = do + inspector <- webViewGetInspector (mWebView gui) + webInspectorInspectCoordinates inspector 0 0 + + +-- | Load given URL in the browser. +loadURL :: String -> GUI -> IO () +loadURL url gui = + case importURL url of + Just url' -> loadURL' url' gui + _ -> return () + +-- | Backend function for loadURL. +loadURL' :: URL -> GUI -> IO () +loadURL' url@URL {url_type = Absolute _} gui = + webViewLoadUri (mWebView gui) (exportURL url) +loadURL' url@URL {url_type = HostRelative} gui = + webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url) +loadURL' url@URL {url_type = _} gui = + webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url + +-- {{{ Dyre +showError :: Configuration -> String -> Configuration +showError configuration message = configuration { mError = Just message } + +browser :: Configuration -> IO () +browser = Dyre.wrapMain Dyre.defaultParams { + Dyre.projectName = "hbro", + Dyre.showError = showError, + Dyre.realMain = realMain +} +-- }}} diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs new file mode 100644 --- /dev/null +++ b/Hbro/Gui.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DoRec #-} +module Hbro.Gui where + +-- {{{ Imports +import Control.Monad.Trans(liftIO) + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.WebKit.WebView +-- }}} + +data GUI = GUI { + mWindow :: Window, -- ^ Main window + mInspectorWindow :: Window, -- ^ WebInspector window + mWebView :: WebView, -- ^ Browser's webview + mPromptLabel :: Label, -- ^ Description of current prompt + mPrompt :: Entry, -- ^ Prompt entry + mWindowBox :: VBox, -- ^ Window's layout + mStatusBox :: HBox, -- ^ Status bar's layout + mProgressLabel :: Label, + mUrlLabel :: Label +} + +-- {{{ Load glade GUI +-- | Load GUI from a glade file. +loadGUI :: String -> IO GUI +loadGUI gladePath = do +-- -- Note: crashes with a runtime error on console if fails! +-- Just xml <- xmlNew gladePath + +-- -- Load main window +-- -- castTo* don't exist :( +-- window <- xmlGetWidget xml castToWindow "window" +-- webView <- xmlGetWidget xml castToWebView "webView" +-- promptLabel <- xmlGetWidget xml castToLabel "promptLabel" +-- prompt <- xmlGetWidget xml castToEntry "prompt" + + window <- windowNew + inspectorWindow <- windowNew + + windowSetDefaultSize window 1024 768 + windowSetPosition window WinPosCenter + --windowSetIconFromFile window "/path/to/icon" + set window [ windowTitle := "hbro" ] + + webView <- webViewNew + winBox <- vBoxNew False 0 + promptBox <- hBoxNew False 10 + statusBox <- hBoxNew False 5 + scrollWin <- scrolledWindowNew Nothing Nothing + promptLabel <- labelNew Nothing + promptEntry <- entryNew + progressLabel <- labelNew (Just "0%") + urlLabel <- labelNew (Just "") + + boxPackStart winBox scrollWin PackGrow 0 + boxPackStart winBox promptBox PackNatural 0 + boxPackStart winBox statusBox PackNatural 0 + boxPackStart promptBox promptLabel PackNatural 0 + boxPackStart promptBox promptEntry PackGrow 0 + boxPackStart statusBox progressLabel PackNatural 0 + boxPackStart statusBox urlLabel PackNatural 0 + + window `containerAdd` winBox + scrollWin `containerAdd` webView + + set webView [ widgetCanDefault := True ] + windowSetDefault window (Just webView) + + _ <- on webView closeWebView $ do + mainQuit + return True + + return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel +-- }}} + +-- | Show or hide the prompt bar (label + entry). +showPrompt :: Bool -> GUI -> IO () +showPrompt toShow gui = case toShow of + False -> do widgetHide (mPromptLabel gui) + widgetHide (mPrompt gui) + _ -> do widgetShow (mPromptLabel gui) + widgetShow (mPrompt gui) + +-- | Show the prompt bar label and default text. +-- As the user validates its entry, the given callback is executed. +prompt :: String -> String -> Bool -> GUI -> (GUI -> IO ()) -> IO () +prompt label defaultText incremental gui callback = do + -- Show prompt + showPrompt True gui + + -- Fill prompt + labelSetText (mPromptLabel gui) label + entrySetText (mPrompt gui) defaultText + + widgetGrabFocus (mPrompt gui) + + -- Register callback + case incremental of + True -> do + id1 <- on (mPrompt gui) editableChanged $ + liftIO $ callback gui + rec id2 <- on (mPrompt gui) keyPressEvent $ do + key <- eventKeyName + + case key of + "Return" -> do + liftIO $ showPrompt False gui + liftIO $ signalDisconnect id1 + liftIO $ signalDisconnect id2 + liftIO $ widgetGrabFocus (mWebView gui) + "Escape" -> do + liftIO $ showPrompt False gui + liftIO $ signalDisconnect id1 + liftIO $ signalDisconnect id2 + liftIO $ widgetGrabFocus (mWebView gui) + _ -> return () + return False + return () + + _ -> do + rec id <- on (mPrompt gui) keyPressEvent $ do + key <- eventKeyName + + case key of + "Return" -> do + liftIO $ showPrompt False gui + liftIO $ callback gui + liftIO $ signalDisconnect id + liftIO $ widgetGrabFocus (mWebView gui) + "Escape" -> do + liftIO $ showPrompt False gui + liftIO $ signalDisconnect id + liftIO $ widgetGrabFocus (mWebView gui) + _ -> return () + return False + + return () + diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs new file mode 100644 --- /dev/null +++ b/Hbro/Socket.hs @@ -0,0 +1,64 @@ +module Hbro.Socket where + +-- {{{ Imports +import Hbro.Gui + +import Control.Monad +import Data.ByteString.Char8 (pack, unpack) +import Graphics.UI.Gtk.WebKit.WebView +import System.ZMQ +-- }}} + +createReplySocket :: String -> GUI -> IO a +createReplySocket socketName gui = withContext 1 $ \context -> do + withSocket context Rep $ \socket -> do + bind socket socketName + forever $ do + command <- receive socket [] + case unpack command of + + -- Get information + "getUri" -> do + getUri <- webViewGetUri (mWebView gui) + case getUri of + Just uri -> send socket (pack uri) [] + _ -> send socket (pack "ERROR No URL opened") [] + "getTitle" -> do + getTitle <- webViewGetTitle (mWebView gui) + case getTitle of + Just title -> send socket (pack title) [] + _ -> send socket (pack "ERROR No title") [] + "getFaviconUri" -> do + getUri <- webViewGetIconUri (mWebView gui) + case getUri of + Just uri -> send socket (pack uri) [] + _ -> send socket (pack "ERROR No favicon uri") [] + "getLoadProgress" -> do + progress <- webViewGetProgress (mWebView gui) + send socket (pack (show progress)) [] + + -- Trigger actions + ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do + webViewLoadUri (mWebView gui) uri + send socket (pack "OK") [] + "stopLoading" -> do + webViewStopLoading (mWebView gui) + send socket (pack "OK") [] + "reload" -> do + webViewReload (mWebView gui) + send socket (pack "OK") [] + "goBack" -> do + webViewGoBack (mWebView gui) + send socket (pack "OK") [] + "goForward" -> do + webViewGoForward (mWebView gui) + send socket (pack "OK") [] + "zoomIn" -> do + webViewZoomIn (mWebView gui) + send socket (pack "OK") [] + "zoomOut" -> do + webViewZoomOut (mWebView gui) + send socket (pack "OK") [] + + _ -> send socket (pack "ERROR Wrong command") [] + diff --git a/Hbro/Util.hs b/Hbro/Util.hs new file mode 100644 --- /dev/null +++ b/Hbro/Util.hs @@ -0,0 +1,25 @@ +module Hbro.Util where + +import Graphics.UI.Gtk + +-- | Converts a keyVal to a String. +-- For printable characters, the corresponding String is returned, except for the space character for which "" is returned. +-- For non-printable characters, the corresponding keyName between <> is returned. +-- For modifiers, Nothing is returned. +keyToString :: KeyVal -> Maybe String +keyToString keyVal = case keyToChar keyVal of + Just ' ' -> Just "" + Just char -> Just [char] + _ -> case keyName keyVal of + "Caps_Lock" -> Nothing + "Shift_L" -> Nothing + "Shift_R" -> Nothing + "Control_L" -> Nothing + "Control_R" -> Nothing + "Alt_L" -> Nothing + "Alt_R" -> Nothing + "Super_L" -> Nothing + "Super_R" -> Nothing + "Menu" -> Nothing + "ISO_Level3_Shift" -> Nothing + x -> Just ('<':x ++ ">") diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,224 @@ +module Main where + +-- {{{ Imports +import Hbro.Core +import Hbro.Gui + +import Control.Concurrent +import Graphics.UI.Gtk +import Graphics.UI.Gtk.WebKit.Download +import Graphics.UI.Gtk.WebKit.NetworkRequest +import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.WebSettings +import System.Cmd +-- }}} + +main :: IO () +main = browser Configuration { + mError = Nothing, + mHomePage = "https://www.google.com", + + mKeyBindings = [ +-- ((Mod, Key), Callback) + -- Browsing + (([], "<"), back), + (([Shift], ">"), forward), + (([], "s"), stop), + (([], ""), reload True), + (([Shift], ""), reload False), + + -- Zooming + (([Shift], "+"), zoomIn), + (([], "-"), zoomOut), + + -- Prompt + (([], "o"), promptURL False), + (([Shift], "O"), promptURL True), + + -- Search + (([Shift], "/"), promptFind False True), + (([Shift], "?"), promptFind False False), + (([], "n"), findNext False True), + (([Shift], "N"), findNext False False), + + -- Others + (([Control], "i"), showWebInspector), + (([Control], "u"), toggleSourceMode), + (([], "t"), toggleStatusBar), + (([Control], "p"), printPage), + (([], ""), fullscreen), + (([], ""), unfullscreen) + ], + + mWebSettings = (do + settings <- webSettingsNew + set settings [ + --SETTING DEFAULT VALUE + --webSettingsCursiveFontFamily := "serif", + --webSettingsDefaultFontFamily := "sans-serif", + --webSettingsFantasyFontFamily := , + --webSettingsMonospaceFontFamily := "monospace", + --webSettingsSansFontFamily := "sans-serif", + --webSettingsSerifFontFamily := "serif", + --webSettingsDefaultFontSize := , + --webSettingsDefaultMonospaceFontSize := 10, + --webSettingsMinimumFontSize := 5, + --webSettingsMinimumLogicalFontSize := 5, + --webSettingsAutoLoadImages := True, + --webSettingsAutoShrinkImages := True, + --webSettingsDefaultEncoding := "iso-8859-1", + --webSettingsEditingBehavior := EditingBehaviorWindows, + --webSettingsEnableCaretBrowsing := , + webSettingsEnableDeveloperExtras := True, + webSettingsEnableHtml5Database := False, + webSettingsEnableHtml5LocalStorage := False, + webSettingsEnableOfflineWebApplicationCache := True, + webSettingsEnablePlugins := True, + webSettingsEnablePrivateBrowsing := False, + webSettingsEnableScripts := True, + webSettingsEnableSpellChecking := True, + webSettingsEnableUniversalAccessFromFileUris := True, + webSettingsEnableXssAuditor := True, + --webSettingsEnableSiteSpecificQuirks := False, + --webSettingsEnableDomPaste := False, + --webSettingsEnableDefaultContextMenu := True, + webSettingsEnablePageCache := True, + --webSettingsEnableSpatialNavigation := False, + --webSettingsEnforce96Dpi := , + webSettingsJSCanOpenWindowAuto := True, + --webSettingsPrintBackgrounds := True, + --webSettingsResizableTextAreas := True, + webSettingsSpellCheckingLang := Just "en_US", + --webSettingsTabKeyCyclesThroughElements := True, + webSettingsUserAgent := "Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.3) Gecko/20100401 Firefox/4.0 (.NET CLR 3.5.30729)" + --webSettingsUserStylesheetUri := Nothing, + --webSettingsZoomStep := 0.1 + ] + return settings), + + -- Custom callbacks + mCustomizations = \gui -> (let + webView = mWebView gui + progressLabel = mProgressLabel gui + urlLabel = mUrlLabel gui + window = mWindow gui + in do + _ <- on webView loadStarted $ \_ -> do + labelSetMarkup progressLabel "0%" + + _ <- on webView loadCommitted $ \_ -> do + getUrl <- (webViewGetUri webView) + case getUrl of + Just url -> labelSetMarkup urlLabel url + _ -> labelSetMarkup urlLabel "" + + _ <- on webView progressChanged $ \progress' -> + labelSetMarkup progressLabel $ "" ++ show progress' ++ "%" + + _ <- on webView loadFinished $ \_ -> + labelSetMarkup progressLabel "100%" + + _ <- on webView loadError $ \_ _ _ -> do + labelSetMarkup progressLabel "ERROR" + return False + + _ <- on webView titleChanged $ \_ title -> do + set window [ windowTitle := title] + + _ <- on webView downloadRequested $ \download -> do + getUrl <- downloadGetUri download + _ <- case getUrl of + Just url -> forkOS $ (rawSystem "wget" [url]) >> return () + _ -> forkOS $ return () + return True + + _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do + putStrLn mimetype + getUrl <- networkRequestGetUri request + case getUrl of + Just url -> putStrLn url + _ -> putStrLn "ERROR" + + return False + + _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do + getUrl <- networkRequestGetUri request + case getUrl of + Just url -> putStrLn ("New Window: " ++ url) + _ -> putStrLn "ERROR" + + return True + + return () + )} + + +-- Definitions + where + back :: GUI -> IO () + back gui = webViewGoBack (mWebView gui) + + forward :: GUI -> IO () + forward gui = webViewGoForward (mWebView gui) + + stop :: GUI -> IO () + stop gui = webViewStopLoading (mWebView gui) + + reload :: Bool -> GUI -> IO () + reload True gui = webViewReload (mWebView gui) + reload _ gui = webViewReloadBypassCache (mWebView gui) + + zoomIn :: GUI -> IO () + zoomIn gui = webViewZoomIn (mWebView gui) + + zoomOut :: GUI -> IO () + zoomOut gui = webViewZoomOut (mWebView gui) + + toggleSourceMode :: GUI -> IO () + toggleSourceMode gui = do + currentMode <- webViewGetViewSourceMode (mWebView gui) + webViewSetViewSourceMode (mWebView gui) (not currentMode) + + -- TODO + toggleStatusBar :: GUI -> IO () + toggleStatusBar gui = return() + + + promptURL :: Bool -> GUI -> IO () + promptURL False gui = + prompt "Open URL" "" False gui (\g -> do + uri <- entryGetText (mPrompt g) + loadURL uri g) + promptURL _ gui = do + uri <- webViewGetUri (mWebView gui) + case uri of + Just url -> prompt "Open URL" url False gui (\g -> do + u <- entryGetText (mPrompt g) + loadURL u g) + _ -> return () + + promptFind :: Bool -> Bool -> GUI -> IO () + promptFind caseSensitive forward gui = + prompt "Search" "" True gui (\gui' -> do + keyWord <- entryGetText (mPrompt gui') + webViewSearchText (mWebView gui) keyWord caseSensitive forward True + return ()) + + findNext :: Bool -> Bool -> GUI -> IO() + findNext caseSensitive forward gui = do + keyWord <- entryGetText (mPrompt gui) + webViewSearchText (mWebView gui) keyWord caseSensitive forward True + return () + + printPage :: GUI -> IO () + printPage gui = do + frame <- webViewGetMainFrame (mWebView gui) + webFramePrint frame + + fullscreen :: GUI -> IO () + fullscreen gui = windowFullscreen (mWindow gui) + + unfullscreen :: GUI -> IO () + unfullscreen gui = windowUnfullscreen (mWindow gui) + diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,9 +1,9 @@ Name: hbro -Version: 0.4 +Version: 0.4.1 Synopsis: A suckless minimal KISSy browser -Stability: alpha -- Description: -- Homepage: +Stability: alpha License: OtherLicense License-file: LICENSE @@ -17,7 +17,7 @@ -- a README. -- Extra-source-files: -Cabal-version: >=1.6 +Cabal-version: >=1.8 Build-type: Simple @@ -25,8 +25,7 @@ Type: git Location: git@twyk.tk/haskell-browser.git -Executable hbro - Main-is: Main.hs +Library Build-depends: base == 4.*, webkit, @@ -40,8 +39,20 @@ zeromq-haskell, bytestring, unix - Other-modules: Gui Browser Util Socket - -- Build-tools: - Hs-Source-Dirs: src + Exposed-modules: + Hbro.Core, + Hbro.Gui, + Hbro.Socket + Hbro.Util Ghc-options: -Wall -threaded - + +Executable hbro + Build-depends: + hbro, + base == 4.*, + gtk, + process, + webkit + Main-is: Main.hs + Hs-Source-Dirs: examples + diff --git a/src/Browser.hs b/src/Browser.hs deleted file mode 100644 --- a/src/Browser.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Browser where - --- {{{ Imports -import Gui -import Socket -import Util - -import qualified Config.Dyre as Dyre -import Control.Concurrent -import Control.Monad.Trans(liftIO) -import Data.Map -import Graphics.UI.Gtk -import Graphics.UI.Gtk.WebKit.WebView -import Graphics.UI.Gtk.WebKit.WebFrame -import Graphics.UI.Gtk.WebKit.WebInspector -import Graphics.UI.Gtk.WebKit.WebSettings -import Network.URL -import Prelude hiding (lookup) -import System.Environment -import System.Posix.Process --- }}} - --- {{{ Type definitions -data Browser = Browser { - mGUI :: GUI -} - -data Configuration = Configuration { - mHomePage :: String, -- ^ Startup page - mKeyBindings :: [(([Modifier], String), GUI -> IO ())], -- ^ List of keybindings - mWebSettings :: IO WebSettings, -- ^ Web settings - mCustomizations :: GUI -> IO (), -- ^ Custom callbacks - mError :: Maybe String -- ^ Error -} - -instance Ord Modifier where - m <= m' = fromEnum m <= fromEnum m' --- }}} - --- {{{ Entry point --- | Entry point of the application. --- Check if help display is requested. -realMain :: Configuration -> IO () -realMain configuration = do - args <- getArgs - - case args of - ["--help"] -> putStrLn "Usage: browser [url]" - _ -> initBrowser configuration --- }}} - --- {{{ Main function --- | Application's main function. --- Create browser and load homepage. -initBrowser :: Configuration -> IO () -initBrowser configuration = do - -- Initialize GUI - args <- initGUI - gui <- loadGUI "" - - -- Initialize IPC socket - pid <- getProcessID - _ <- forkIO $ createReplySocket ("ipc:///tmp/hbro." ++ (show pid)) gui - - -- Load configuration - settings <- mWebSettings configuration - webViewSetWebSettings (mWebView gui) settings - (mCustomizations configuration) gui - - -- Load url - let url = case args of - [arg] -> arg - _ -> mHomePage configuration - - webViewLoadUri (mWebView gui) url - - -- Load key bindings - let keyBindings = fromList (mKeyBindings configuration) - - -- Open all link in current window. - _ <- on (mWebView gui) createWebView $ \frame -> do - newUri <- webFrameGetUri frame - case newUri of - Just uri -> webViewLoadUri (mWebView gui) uri - Nothing -> return () - return (mWebView gui) - - -- Web inspector - inspector <- webViewGetInspector (mWebView gui) - _ <- on inspector inspectWebView $ \_ -> do - webView <- webViewNew - containerAdd (mInspectorWindow gui) webView - return webView - - _ <- on inspector showWindow $ do - widgetShowAll (mInspectorWindow gui) - return True - - -- TODO: when does this signal happen ?! - --_ <- on inspector finished $ return () - - _ <- on inspector attachWindow $ do - getWebView <- webInspectorGetWebView inspector - case getWebView of - Just webView -> do widgetHide (mInspectorWindow gui) - containerRemove (mInspectorWindow gui) webView - widgetSetSizeRequest webView (-1) 250 - boxPackEnd (mWindowBox gui) webView PackNatural 0 - widgetShow webView - return True - _ -> return False - - _ <- on inspector detachWindow $ do - getWebView <- webInspectorGetWebView inspector - _ <- case getWebView of - Just webView -> do containerRemove (mWindowBox gui) webView - containerAdd (mInspectorWindow gui) webView - widgetShowAll (mInspectorWindow gui) - return True - _ -> return False - - widgetShowAll (mInspectorWindow gui) - return True - - -- Key bindings - _ <- after (mWebView gui) keyPressEvent $ do - keyVal <- eventKeyVal - modifiers <- eventModifier - - let keyString = keyToString keyVal - - case keyString of - Just string -> do - case lookup (modifiers, string) keyBindings of - Just callback -> liftIO $ callback gui - _ -> liftIO $ putStrLn string - _ -> return () - - return False - - -- Connect and show. - _ <- onDestroy (mWindow gui) mainQuit - widgetShowAll (mWindow gui) - widgetHide (mPromptLabel gui) - widgetHide (mPrompt gui) - - mainGUI --- }}} - --- | Show web inspector for current webpage. -showWebInspector :: GUI -> IO () -showWebInspector gui = do - inspector <- webViewGetInspector (mWebView gui) - webInspectorInspectCoordinates inspector 0 0 - - --- | Load given URL in the browser. -loadURL :: String -> GUI -> IO () -loadURL url gui = - case importURL url of - Just url' -> loadURL' url' gui - _ -> return () - --- | Backend function for loadURL. -loadURL' :: URL -> GUI -> IO () -loadURL' url@URL {url_type = Absolute _} gui = - webViewLoadUri (mWebView gui) (exportURL url) -loadURL' url@URL {url_type = HostRelative} gui = - webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url) -loadURL' url@URL {url_type = _} gui = - webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url - --- {{{ Dyre -showError :: Configuration -> String -> Configuration -showError configuration message = configuration { mError = Just message } - -browser :: Configuration -> IO () -browser = Dyre.wrapMain Dyre.defaultParams { - Dyre.projectName = "hbro", - Dyre.showError = showError, - Dyre.realMain = realMain -} --- }}} diff --git a/src/Gui.hs b/src/Gui.hs deleted file mode 100644 --- a/src/Gui.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DoRec #-} -module Gui where - --- {{{ Imports -import Control.Monad.Trans(liftIO) - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.WebKit.WebView --- }}} - -data GUI = GUI { - mWindow :: Window, -- ^ Main window - mInspectorWindow :: Window, -- ^ WebInspector window - mWebView :: WebView, -- ^ Browser's webview - mPromptLabel :: Label, -- ^ Description of current prompt - mPrompt :: Entry, -- ^ Prompt entry - mWindowBox :: VBox, -- ^ Window's layout - mStatusBox :: HBox, -- ^ Status bar's layout - mProgressLabel :: Label, - mUrlLabel :: Label -} - --- {{{ Load glade GUI --- | Load GUI from a glade file. -loadGUI :: String -> IO GUI -loadGUI gladePath = do --- -- Note: crashes with a runtime error on console if fails! --- Just xml <- xmlNew gladePath - --- -- Load main window --- -- castTo* don't exist :( --- window <- xmlGetWidget xml castToWindow "window" --- webView <- xmlGetWidget xml castToWebView "webView" --- promptLabel <- xmlGetWidget xml castToLabel "promptLabel" --- prompt <- xmlGetWidget xml castToEntry "prompt" - - window <- windowNew - inspectorWindow <- windowNew - - windowSetDefaultSize window 1024 768 - windowSetPosition window WinPosCenter - --windowSetIconFromFile window "/path/to/icon" - set window [ windowTitle := "hbro" ] - - webView <- webViewNew - winBox <- vBoxNew False 0 - promptBox <- hBoxNew False 10 - statusBox <- hBoxNew False 5 - scrollWin <- scrolledWindowNew Nothing Nothing - promptLabel <- labelNew Nothing - promptEntry <- entryNew - progressLabel <- labelNew (Just "0%") - urlLabel <- labelNew (Just "") - - boxPackStart winBox scrollWin PackGrow 0 - boxPackStart winBox promptBox PackNatural 0 - boxPackStart winBox statusBox PackNatural 0 - boxPackStart promptBox promptLabel PackNatural 0 - boxPackStart promptBox promptEntry PackGrow 0 - boxPackStart statusBox progressLabel PackNatural 0 - boxPackStart statusBox urlLabel PackNatural 0 - - window `containerAdd` winBox - scrollWin `containerAdd` webView - - set webView [ widgetCanDefault := True ] - windowSetDefault window (Just webView) - - _ <- on webView closeWebView $ do - mainQuit - return True - - return $ GUI window inspectorWindow webView promptLabel promptEntry winBox statusBox progressLabel urlLabel --- }}} - --- | Show or hide the prompt bar (label + entry). -showPrompt :: Bool -> GUI -> IO () -showPrompt toShow gui = case toShow of - False -> do widgetHide (mPromptLabel gui) - widgetHide (mPrompt gui) - _ -> do widgetShow (mPromptLabel gui) - widgetShow (mPrompt gui) - --- | Show the prompt bar label and default text. --- As the user validates its entry, the given callback is executed. -prompt :: String -> String -> Bool -> GUI -> (GUI -> IO ()) -> IO () -prompt label defaultText incremental gui callback = do - -- Show prompt - showPrompt True gui - - -- Fill prompt - labelSetText (mPromptLabel gui) label - entrySetText (mPrompt gui) defaultText - - widgetGrabFocus (mPrompt gui) - - -- Register callback - case incremental of - True -> do - id1 <- on (mPrompt gui) editableChanged $ - liftIO $ callback gui - rec id2 <- on (mPrompt gui) keyPressEvent $ do - key <- eventKeyName - - case key of - "Return" -> do - liftIO $ showPrompt False gui - liftIO $ signalDisconnect id1 - liftIO $ signalDisconnect id2 - liftIO $ widgetGrabFocus (mWebView gui) - "Escape" -> do - liftIO $ showPrompt False gui - liftIO $ signalDisconnect id1 - liftIO $ signalDisconnect id2 - liftIO $ widgetGrabFocus (mWebView gui) - _ -> return () - return False - return () - - _ -> do - rec id <- on (mPrompt gui) keyPressEvent $ do - key <- eventKeyName - - case key of - "Return" -> do - liftIO $ showPrompt False gui - liftIO $ callback gui - liftIO $ signalDisconnect id - liftIO $ widgetGrabFocus (mWebView gui) - "Escape" -> do - liftIO $ showPrompt False gui - liftIO $ signalDisconnect id - liftIO $ widgetGrabFocus (mWebView gui) - _ -> return () - return False - - return () - diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,224 +0,0 @@ -module Main where - --- {{{ Imports -import Browser -import Gui - -import Control.Concurrent -import Graphics.UI.Gtk -import Graphics.UI.Gtk.WebKit.Download -import Graphics.UI.Gtk.WebKit.NetworkRequest -import Graphics.UI.Gtk.WebKit.WebFrame -import Graphics.UI.Gtk.WebKit.WebView -import Graphics.UI.Gtk.WebKit.WebSettings -import System.Cmd --- }}} - -main :: IO () -main = browser Configuration { - mError = Nothing, - mHomePage = "https://www.google.com", - - mKeyBindings = [ --- ((Mod, Key), Callback) - -- Browsing - (([], "<"), back), - (([Shift], ">"), forward), - (([], "s"), stop), - (([], ""), reload True), - (([Shift], ""), reload False), - - -- Zooming - (([Shift], "+"), zoomIn), - (([], "-"), zoomOut), - - -- Prompt - (([], "o"), promptURL False), - (([Shift], "O"), promptURL True), - - -- Search - (([Shift], "/"), promptFind False True), - (([Shift], "?"), promptFind False False), - (([], "n"), findNext False True), - (([Shift], "N"), findNext False False), - - -- Others - (([Control], "i"), showWebInspector), - (([Control], "u"), toggleSourceMode), - (([], "t"), toggleStatusBar), - (([Control], "p"), printPage), - (([], ""), fullscreen), - (([], ""), unfullscreen) - ], - - mWebSettings = (do - settings <- webSettingsNew - set settings [ - --SETTING DEFAULT VALUE - --webSettingsCursiveFontFamily := "serif", - --webSettingsDefaultFontFamily := "sans-serif", - --webSettingsFantasyFontFamily := , - --webSettingsMonospaceFontFamily := "monospace", - --webSettingsSansFontFamily := "sans-serif", - --webSettingsSerifFontFamily := "serif", - --webSettingsDefaultFontSize := , - --webSettingsDefaultMonospaceFontSize := 10, - --webSettingsMinimumFontSize := 5, - --webSettingsMinimumLogicalFontSize := 5, - --webSettingsAutoLoadImages := True, - --webSettingsAutoShrinkImages := True, - --webSettingsDefaultEncoding := "iso-8859-1", - --webSettingsEditingBehavior := EditingBehaviorWindows, - --webSettingsEnableCaretBrowsing := , - webSettingsEnableDeveloperExtras := True, - webSettingsEnableHtml5Database := False, - webSettingsEnableHtml5LocalStorage := False, - webSettingsEnableOfflineWebApplicationCache := True, - webSettingsEnablePlugins := True, - webSettingsEnablePrivateBrowsing := False, - webSettingsEnableScripts := True, - webSettingsEnableSpellChecking := True, - webSettingsEnableUniversalAccessFromFileUris := True, - webSettingsEnableXssAuditor := True, - --webSettingsEnableSiteSpecificQuirks := False, - --webSettingsEnableDomPaste := False, - --webSettingsEnableDefaultContextMenu := True, - webSettingsEnablePageCache := True, - --webSettingsEnableSpatialNavigation := False, - --webSettingsEnforce96Dpi := , - webSettingsJSCanOpenWindowAuto := True, - --webSettingsPrintBackgrounds := True, - --webSettingsResizableTextAreas := True, - webSettingsSpellCheckingLang := Just "en_US", - --webSettingsTabKeyCyclesThroughElements := True, - webSettingsUserAgent := "Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.3) Gecko/20100401 Firefox/4.0 (.NET CLR 3.5.30729)" - --webSettingsUserStylesheetUri := Nothing, - --webSettingsZoomStep := 0.1 - ] - return settings), - - -- Custom callbacks - mCustomizations = \gui -> (let - webView = mWebView gui - progressLabel = mProgressLabel gui - urlLabel = mUrlLabel gui - window = mWindow gui - in do - _ <- on webView loadStarted $ \_ -> do - labelSetMarkup progressLabel "0%" - - _ <- on webView loadCommitted $ \_ -> do - getUrl <- (webViewGetUri webView) - case getUrl of - Just url -> labelSetMarkup urlLabel url - _ -> labelSetMarkup urlLabel "" - - _ <- on webView progressChanged $ \progress' -> - labelSetMarkup progressLabel $ "" ++ show progress' ++ "%" - - _ <- on webView loadFinished $ \_ -> - labelSetMarkup progressLabel "100%" - - _ <- on webView loadError $ \_ _ _ -> do - labelSetMarkup progressLabel "ERROR" - return False - - _ <- on webView titleChanged $ \_ title -> do - set window [ windowTitle := title] - - _ <- on webView downloadRequested $ \download -> do - getUrl <- downloadGetUri download - _ <- case getUrl of - Just url -> forkOS $ (rawSystem "wget" [url]) >> return () - _ -> forkOS $ return () - return True - - _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do - putStrLn mimetype - getUrl <- networkRequestGetUri request - case getUrl of - Just url -> putStrLn url - _ -> putStrLn "ERROR" - - return False - - _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do - getUrl <- networkRequestGetUri request - case getUrl of - Just url -> putStrLn ("New Window: " ++ url) - _ -> putStrLn "ERROR" - - return True - - return () - )} - - --- Definitions - where - back :: GUI -> IO () - back gui = webViewGoBack (mWebView gui) - - forward :: GUI -> IO () - forward gui = webViewGoForward (mWebView gui) - - stop :: GUI -> IO () - stop gui = webViewStopLoading (mWebView gui) - - reload :: Bool -> GUI -> IO () - reload True gui = webViewReload (mWebView gui) - reload _ gui = webViewReloadBypassCache (mWebView gui) - - zoomIn :: GUI -> IO () - zoomIn gui = webViewZoomIn (mWebView gui) - - zoomOut :: GUI -> IO () - zoomOut gui = webViewZoomOut (mWebView gui) - - toggleSourceMode :: GUI -> IO () - toggleSourceMode gui = do - currentMode <- webViewGetViewSourceMode (mWebView gui) - webViewSetViewSourceMode (mWebView gui) (not currentMode) - - -- TODO - toggleStatusBar :: GUI -> IO () - toggleStatusBar gui = return() - - - promptURL :: Bool -> GUI -> IO () - promptURL False gui = - prompt "Open URL" "" False gui (\g -> do - uri <- entryGetText (mPrompt g) - loadURL uri g) - promptURL _ gui = do - uri <- webViewGetUri (mWebView gui) - case uri of - Just url -> prompt "Open URL" url False gui (\g -> do - u <- entryGetText (mPrompt g) - loadURL u g) - _ -> return () - - promptFind :: Bool -> Bool -> GUI -> IO () - promptFind caseSensitive forward gui = - prompt "Search" "" True gui (\gui' -> do - keyWord <- entryGetText (mPrompt gui') - webViewSearchText (mWebView gui) keyWord caseSensitive forward True - return ()) - - findNext :: Bool -> Bool -> GUI -> IO() - findNext caseSensitive forward gui = do - keyWord <- entryGetText (mPrompt gui) - webViewSearchText (mWebView gui) keyWord caseSensitive forward True - return () - - printPage :: GUI -> IO () - printPage gui = do - frame <- webViewGetMainFrame (mWebView gui) - webFramePrint frame - - fullscreen :: GUI -> IO () - fullscreen gui = windowFullscreen (mWindow gui) - - unfullscreen :: GUI -> IO () - unfullscreen gui = windowUnfullscreen (mWindow gui) - diff --git a/src/Socket.hs b/src/Socket.hs deleted file mode 100644 --- a/src/Socket.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Socket where - -import Gui - -import Control.Monad -import Data.ByteString.Char8 (pack, unpack) -import Graphics.UI.Gtk.WebKit.WebView -import System.ZMQ - - -createReplySocket :: String -> GUI -> IO a -createReplySocket socketName gui = withContext 1 $ \context -> do - withSocket context Rep $ \socket -> do - bind socket socketName - forever $ do - command <- receive socket [] - case unpack command of - - -- Get information - "getUri" -> do - getUri <- webViewGetUri (mWebView gui) - case getUri of - Just uri -> send socket (pack uri) [] - _ -> send socket (pack "ERROR No URL opened") [] - "getTitle" -> do - getTitle <- webViewGetTitle (mWebView gui) - case getTitle of - Just title -> send socket (pack title) [] - _ -> send socket (pack "ERROR No title") [] - "getFaviconUri" -> do - getUri <- webViewGetIconUri (mWebView gui) - case getUri of - Just uri -> send socket (pack uri) [] - _ -> send socket (pack "ERROR No favicon uri") [] - "getLoadProgress" -> do - progress <- webViewGetProgress (mWebView gui) - send socket (pack (show progress)) [] - - -- Trigger actions - ('l':'o':'a':'d':'U':'r':'i':' ':uri) -> do - webViewLoadUri (mWebView gui) uri - send socket (pack "OK") [] - "stopLoading" -> do - webViewStopLoading (mWebView gui) - send socket (pack "OK") [] - "reload" -> do - webViewReload (mWebView gui) - send socket (pack "OK") [] - "goBack" -> do - webViewGoBack (mWebView gui) - send socket (pack "OK") [] - "goForward" -> do - webViewGoForward (mWebView gui) - send socket (pack "OK") [] - "zoomIn" -> do - webViewZoomIn (mWebView gui) - send socket (pack "OK") [] - "zoomOut" -> do - webViewZoomOut (mWebView gui) - send socket (pack "OK") [] - - _ -> send socket (pack "ERROR Wrong command") [] - diff --git a/src/Util.hs b/src/Util.hs deleted file mode 100644 --- a/src/Util.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Util where - -import Graphics.UI.Gtk - --- | Converts a keyVal to a String. --- For printable characters, the corresponding String is returned, except for the space character for which "" is returned. --- For non-printable characters, the corresponding keyName between <> is returned. --- For modifiers, Nothing is returned. -keyToString :: KeyVal -> Maybe String -keyToString keyVal = case keyToChar keyVal of - Just ' ' -> Just "" - Just char -> Just [char] - _ -> case keyName keyVal of - "Caps_Lock" -> Nothing - "Shift_L" -> Nothing - "Shift_R" -> Nothing - "Control_L" -> Nothing - "Control_R" -> Nothing - "Alt_L" -> Nothing - "Alt_R" -> Nothing - "Super_L" -> Nothing - "Super_R" -> Nothing - "Menu" -> Nothing - "ISO_Level3_Shift" -> Nothing - x -> Just ('<':x ++ ">")