diff --git a/Hbro/Config.hs b/Hbro/Config.hs new file mode 100644 --- /dev/null +++ b/Hbro/Config.hs @@ -0,0 +1,171 @@ +module Hbro.Config ( +-- * Default configuration + defaultConfig, + defaultHooks, + defaultKeyHandler, + defaultKeyBindings, + defaultLinkClickedHook, + defaultMIMEDisposition, +-- defaultNewWindowHook, + defaultTitleChangedHook, + defaultCommandsList +) where + +-- {{{ Import +import Hbro.Core +--import Hbro.Keys +import Hbro.Gui +import qualified Hbro.Prompt as Prompt +import Hbro.Types +import Hbro.Util + +import Control.Monad.Reader hiding(mapM_) + +import Data.Foldable +import Data.Functor +import qualified Data.Map as M + +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.General.General +import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.WebKit.WebPolicyDecision +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.Windows.Window + +import Prelude hiding(mapM_) + +import Network.URI + +import System.Console.CmdArgs (whenLoud) +import System.FilePath +import System.Glib.Attributes +-- }}} + + +-- | Default configuration. +-- Homepage: DuckDuckGo, socket directory: system's temporary directory, +-- UI file: ~/.config/hbro/, Webkit's default websettings, no key/command binding. +defaultConfig :: Config +defaultConfig = Config { + mHomePage = "https://duckduckgo.com/", + mSocketDir = mTemporary, + mUIFile = ( "ui.xml") . mConfiguration, + mWebSettings = [], + mCommands = defaultCommandsList, + mHooks = defaultHooks +} + +-- | Pack of default hooks +defaultHooks :: Hooks +defaultHooks = Hooks { + mBackForward = (\_ decision -> io $ webPolicyDecisionUse decision), + mDownload = defaultDownloadHook, + mFormResubmitted = (\_ decision -> io $ webPolicyDecisionUse decision), + mFormSubmitted = (\_ decision -> io $ webPolicyDecisionUse decision), + mKeyPressed = void . (defaultKeyHandler defaultKeyBindings), + mLinkClicked = defaultLinkClickedHook, + mLoadFinished = return (), + mMIMEDisposition = defaultMIMEDisposition, + mNewWindow = const $ return (), --defaultNewWindowHook, + mOtherNavigation = (\_ decision -> io $ webPolicyDecisionUse decision), + mReload = (\_ decision -> io $ webPolicyDecisionUse decision), + mStartUp = return (), + mTitleChanged = defaultTitleChangedHook +} + +-- | Warn user about missing download hook. +defaultDownloadHook :: URI -> String -> Int -> K () +defaultDownloadHook _ _ _ = notify 5000 "No download hook defined." + +-- | Look for a callback associated to the given keystrokes and trigger it, if any. +defaultKeyHandler :: KeysList -> String -> K (String, Bool) +defaultKeyHandler keysList keystrokes = do + io . whenLoud . putStr $ "Key pressed: " ++ keystrokes + (log', isMapped) <- case M.lookup keystrokes (M.fromList keysList) of + Just callback -> callback >> return (" (mapped)", True) + _ -> return (" (unmapped)", False) + io . whenLoud . putStrLn $ log' + return (keystrokes, isMapped) + +-- | Default key bindings. +defaultKeyBindings :: KeysList +defaultKeyBindings = [ +-- Browse + ("M-", goBack), + ("M-", goForward), + ("C-", stopLoading), + ("", reload), + ("C-r", reload), + ("C-", reloadBypassCache), + ("M-r", reloadBypassCache), + ("C-^", scroll Horizontal (Absolute 0)), + ("C-$", scroll Horizontal (Absolute 100)), + ("C-", scroll Vertical (Absolute 0)), + ("C-", scroll Vertical (Absolute 100)), + ("M-", goHome), +-- Display + ("C-+", zoomIn), + ("C--", zoomOut), + -- ("", with (mWindow . mGUI) windowFullscreen), + -- ("", with (mWindow . mGUI) windowUnfullscreen), + ("C-b", with (mStatusBar . mGUI) toggleVisibility), + ("C-u", toggleSourceMode), +-- Prompt + ("C-o", Prompt.readURI "Open URI" [] loadURI), + ("M-o", withURI $ \uri -> Prompt.readURI "Open URI " (show uri) loadURI), +-- Search + ("/", Prompt.iread "Search " [] $ void . searchText CaseInsensitive Forward Wrap), + ("C-f", Prompt.iread "Search " [] $ void . searchText CaseInsensitive Forward Wrap), + ("?", Prompt.iread "Search " [] $ void . searchText CaseInsensitive Backward Wrap), + ("C-n", withK (mEntry . mPromptBar . mGUI) $ (io . entryGetText) >=> void . searchText CaseInsensitive Forward Wrap), + ("C-N", withK (mEntry . mPromptBar . mGUI) $ (io . entryGetText) >=> void . searchText CaseInsensitive Backward Wrap), +-- Misc + ("", with (mBox . mPromptBar . mGUI) widgetHide), + ("C-i", showWebInspector), + ("C-p", printPage), + ("C-t", io $ spawn "hbro" []), + ("C-w", io mainQuit) + ] + +-- | Left click loads the new page in current window, middle click loads the new page in a new window, right click does nothing. +defaultLinkClickedHook :: Button -> URI -> WebPolicyDecision -> K () +defaultLinkClickedHook ButtonL _uri decision = io $ webPolicyDecisionUse decision +defaultLinkClickedHook ButtonM uri decision = io $ webPolicyDecisionIgnore decision >> spawn "hbro" ["-u", show uri] +defaultLinkClickedHook _ _uri decision = io $ webPolicyDecisionIgnore decision + +-- /!\ NetworkRequest's Haskell binding is missing the function "webkit_network_request_get_message", which makes it rather useless... +-- | Display content if webview can show the given MIME type, otherwise download it. +defaultMIMEDisposition :: URI -> String -> WebPolicyDecision -> K () +defaultMIMEDisposition _uri mimetype decision = with (mWebView . mGUI) $ \view -> do + canShow <- webViewCanShowMimeType view mimetype + + case canShow of + True -> webPolicyDecisionUse decision + _ -> webPolicyDecisionDownload decision + +--- | Default behavior when a new window is requested: load URI in current window. +--defaultNewWindowHook :: URI -> K () +--defaultNewWindowHook uri = loadURI uri + +-- | Update the main window's title +defaultTitleChangedHook :: String -> K () +defaultTitleChangedHook title = with (mWindow . mGUI) (`set` [ windowTitle := ("hbro | " ++ title)]) + +-- | List of default supported requests. +defaultCommandsList :: CommandsList +defaultCommandsList = [ + -- Get information + ("GET_URI", \_arguments -> (maybe "ERROR" show) <$> mapK postGUISync getURI), + ("GET_TITLE", \_arguments -> (maybe "ERROR" show) <$> mapK postGUISync getTitle), + ("GET_FAVICON_URI", \_arguments -> (maybe "ERROR" show) <$> mapK postGUISync getFaviconURI), + ("GET_LOAD_PROGRESS", \_arguments -> show <$> mapK postGUISync getLoadProgress), + -- Trigger actions + ("LOAD_URI", \arguments -> case arguments of + uri:_ -> ((mapK postGUIAsync) . (mapM_ loadURI)) (parseURIReference uri) >> return "OK" + _ -> return "ERROR Argument needed."), + ("STOP_LOADING", \_arguments -> mapK postGUIAsync stopLoading >> return "OK"), + ("RELOAD", \_arguments -> mapK postGUIAsync reload >> return "OK"), + ("GO_BACK", \_arguments -> mapK postGUIAsync goBack >> return "OK"), + ("GO_FORWARD", \_arguments -> mapK postGUIAsync goForward >> return "OK"), + ("ZOOM_IN", \_arguments -> mapK postGUIAsync zoomIn >> return "OK"), + ("ZOOM_OUT", \_arguments -> mapK postGUIAsync zoomOut >> return "OK")] diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -1,14 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoRec #-} module Hbro.Core ( --- * Browsing +-- * 'K'-monad + runK, + mapK, + mapK2, +-- * Util + with, + withK, + withTitle, + withURI, +-- * Read state + getFaviconURI, + getLoadProgress, + getTitle, + getURI, + getState, +-- * Browse + goBack, + goForward, goHome, --- * Scrolling - goTop, - goBottom, - goLeft, - goRight, + loadURI, + reload, + reloadBypassCache, + stopLoading, +-- * Display + zoomIn, + zoomOut, + Axis(..), + Position(..), + scroll, -- * Misc + notify, + searchText, + toggleSourceMode, printPage, executeJSFile ) where @@ -17,64 +42,167 @@ import Hbro.Types import Hbro.Util +import Control.Monad.Reader hiding(forM_, mapM_) + +import Data.Dynamic import Data.Foldable +import Data.Functor +import Data.IORef +import qualified Data.Map as M +import Graphics.UI.Gtk.Display.Label +import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame -import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri) +import Graphics.UI.Gtk.WebKit.WebView import Network.URI +import Prelude hiding(mapM_) + import System.Console.CmdArgs -- }}} --- {{{ Browsing --- | Load homepage (set from configuration file). -goHome :: WebView -> Config -> IO () -goHome webView config@Config{ mHomePage = homeURI } = forM_ (parseURIReference homeURI) $ webViewLoadUri webView +-- {{{ 'K'-monad +-- | 'runReaderT' for 'K'-monad +runK :: Environment -> KT m a -> m a +runK env (KT function) = runReaderT function env + +-- | 'mapReaderT' for 'K'-monad. +mapK :: (m a -> n b) -> KT m a -> KT n b +mapK function (KT env) = KT $ mapReaderT function env + +-- | Like 'mapK', but monadic-input of filter can do little reading. +mapK2 :: ((c -> m a) -> n b) -> (c -> KT m a) -> KT n b +mapK2 f g = KT . ReaderT $ \b -> f (runK b . g) -- }}} --- {{{ Scrolling --- | Scroll up to top of web page. Provided for convenience. -goTop :: ScrolledWindow -> IO () -goTop window = do - adjustment <- scrolledWindowGetVAdjustment window - lower <- adjustmentGetLower adjustment +-- {{{ Util +with :: (Environment -> a) -> (a -> IO b) -> K b +with selector callback = withK selector $ io . callback - adjustmentSetValue adjustment lower +withK :: (Environment -> a) -> (a -> K b) -> K b +withK selector callback = callback =<< asks selector --- | Scroll down to bottom of web page. Provided for convenience. -goBottom :: ScrolledWindow -> IO () -goBottom window = do - adjustment <- scrolledWindowGetVAdjustment window - upper <- adjustmentGetUpper adjustment +withTitle :: (String -> K ()) -> K () +withTitle callback = (mapM_ callback) =<< getTitle - adjustmentSetValue adjustment upper +withURI :: (URI -> K ()) -> K () +withURI callback = (mapM_ callback) =<< getURI --- | Scroll to the left edge of web page. Provided for convenience. -goLeft :: ScrolledWindow -> IO () -goLeft window = do - adjustment <- scrolledWindowGetHAdjustment window - lower <- adjustmentGetLower adjustment +getFaviconURI :: K (Maybe URI) +getFaviconURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetIconUri - adjustmentSetValue adjustment lower +getLoadProgress :: K Double +getLoadProgress = with (mWebView . mGUI) webViewGetProgress --- | Scroll to the right edge of web page. Provided for convenience. -goRight :: ScrolledWindow -> IO () -goRight window = do - adjustment <- scrolledWindowGetHAdjustment window - upper <- adjustmentGetUpper adjustment +getURI :: K (Maybe URI) +getURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetUri - adjustmentSetValue adjustment upper +getTitle :: K (Maybe String) +getTitle = with (mWebView . mGUI) webViewGetTitle + +getState :: Typeable a => String -> a -> K (IORef a) +getState key defaultValue = with mState $ \state -> do + result <- (fromDynamic <=< M.lookup key) <$> readIORef state + case result of + Just value -> return value + _ -> do + value <- newIORef defaultValue + modifyIORef state . M.insert key . toDyn $ value + return value -- }}} - + +-- {{{ Browsing +goBack, goForward, goHome :: K () +goBack = withK (mWebView . mGUI) $ \view -> do + canGoBack <- io . webViewCanGoBack $ view + unless canGoBack $ notify 5000 "Cannot go back anymore" + io . webViewGoBack $ view +goForward = withK (mWebView . mGUI) $ \view -> do + canGoForward <- io . webViewCanGoForward $ view + unless canGoForward $ notify 5000 "Cannot go forward anymore" + io . webViewGoForward $ view + +goHome = withK (mHomePage . mConfig) $ mapM_ loadURI . parseURIReference + +loadURI :: URI -> K () +loadURI uri = do + io . whenLoud . putStrLn . ("Loading URI: " ++) . show $ uri' + with (mWebView . mGUI) (`webViewLoadUri` uri') + where + uri' = case uriScheme uri of + [] -> "http://" ++ show uri + _ -> show uri + +reload, reloadBypassCache, stopLoading :: K () +reload = with (mWebView . mGUI) webViewReload +reloadBypassCache = with (mWebView . mGUI) webViewReloadBypassCache +stopLoading = do + with (mWebView . mGUI) webViewStopLoading + notify 5000 "Stopped loading" +-- }}} + +-- {{{ Display +zoomIn, zoomOut :: K () +zoomIn = with (mWebView . mGUI) webViewZoomIn +zoomOut = with (mWebView . mGUI) webViewZoomOut + +data Axis = Horizontal | Vertical +data Position = Absolute Double | Relative Double + +getAdjustment :: Axis -> (ScrolledWindow -> IO Adjustment) +getAdjustment Horizontal = scrolledWindowGetHAdjustment +getAdjustment Vertical = scrolledWindowGetVAdjustment + +-- | General scrolling command. +scroll :: Axis -> Position -> K () +scroll axis percentage = with (mScrollWindow . mGUI) $ \window -> do + adj <- getAdjustment axis window + page <- adjustmentGetPageSize adj + current <- adjustmentGetValue adj + lower <- adjustmentGetLower adj + upper <- adjustmentGetUpper adj + + let shift (Absolute x) = lower + x/100 * (upper - page - lower) + shift (Relative x) = current + x/100 * page + limit x = (x `max` lower) `min` (upper - page) + + adjustmentSetValue adj $ limit (shift percentage) +-- }}} + -- {{{ Misc --- | Wrapper around webFramePrint function, provided for convenience. -printPage :: WebView -> IO () -printPage webView = webViewGetMainFrame webView >>= webFramePrint +notify :: Int -> String -> K () +notify duration text = with (mNotificationBar . mGUI) $ \notificationBar -> do +-- Set new content + let label = mLabel notificationBar + labelSetMarkup label text +-- Remove old timer, if any + let timer = mTimer notificationBar + oldID <- readIORef timer + forM_ oldID timeoutRemove +-- Add new timer + newID <- timeoutAdd (labelSetMarkup label "" >> return False) duration + modifyIORef timer $ const . Just $ newID +-- | Wrapper around webViewSearchText, provided for convenience +searchText :: CaseSensitivity -> Direction -> Wrap -> String -> K Bool +searchText s d w text = with (mWebView . mGUI) $ \view -> + webViewSearchText view text (isCaseSensitive s) (isForward d) (isWrapped w) + +-- | Toggle source display. +-- Current implementation forces a refresh of current web page, which may be undesired. +toggleSourceMode :: K () +toggleSourceMode = do + with (mWebView . mGUI) $ \view -> + webViewSetViewSourceMode view =<< (not <$> webViewGetViewSourceMode view) + reload + +-- | Wrapper around webFramePrint function, provided for convenience. +printPage :: K () +printPage = with (mWebView . mGUI) $ webViewGetMainFrame >=> webFramePrint -- | Execute a javascript file on current webpage. executeJSFile :: FilePath -> WebView -> IO () diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -1,20 +1,21 @@ {-# LANGUAGE DoRec #-} module Hbro.Gui ( + getObject, initGUI, showWebInspector, - prompt, - promptIncremental, toggleVisibility ) where -- {{{ Imports +import Hbro.Core import Hbro.Util +import qualified Hbro.Prompt as Prompt import Hbro.Types import Control.Monad hiding(forM_, mapM_) -import Control.Monad.Trans -import Data.Foldable +--import Data.Foldable +import Data.IORef import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container @@ -22,10 +23,7 @@ import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label -import Graphics.UI.Gtk.Entry.Editable -import Graphics.UI.Gtk.Entry.Entry import qualified Graphics.UI.Gtk.General.General as GTK -import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow @@ -36,27 +34,32 @@ import Prelude hiding(mapM_) -import System.Console.CmdArgs (whenNormal, whenLoud) +import System.Console.CmdArgs (whenNormal) import System.Glib.Attributes import System.Glib.Signals +import System.Glib.Types -- }}} -initGUI :: FilePath -> [AttrOp WebSettings] -> IO GUI +-- Util +-- | Return the casted GObject corresponding to the given name (set in the builder's XML file) +getObject :: GObjectClass a => (GObject -> a) -> String -> K a +getObject cast name = with (mBuilder . mGUI) $ \builder -> builderGetObject builder cast name + +initGUI :: (RefDirs -> FilePath) -> [AttrOp WebSettings] -> IO GUI initGUI xmlPath settings = do - whenNormal $ putStr ("Loading GUI from " ++ xmlPath ++ "... ") void GTK.initGUI - -- Load XML + xmlPath' <- resolve xmlPath + whenNormal . putStr . ("Loading GUI from " ++) . (++ "... ") $ xmlPath' builder <- builderNew - builderAddFromFile builder xmlPath - + builderAddFromFile builder xmlPath' -- Initialize components - (webView, sWindow) <- initWebView builder settings - (window, wBox) <- initWindow builder webView - promptBar <- initPromptBar builder - statusBar <- initStatusBar builder - inspectorWindow <- initWebInspector webView wBox - + (webView, sWindow) <- initWebView builder settings + (window, wBox) <- initWindow builder webView + promptBar <- Prompt.init builder + statusBar <- initStatusBar builder + notificationBar <- initNotificationBar builder + inspectorWindow <- initWebInspector webView wBox -- Show window widgetShowAll window widgetHide (mBox promptBar) @@ -69,6 +72,7 @@ mWebView = webView, mPromptBar = promptBar, mStatusBar = statusBar, + mNotificationBar = notificationBar, mBuilder = builder } @@ -77,27 +81,17 @@ -- Initialize ScrolledWindows window <- builderGetObject builder castToScrolledWindow "webViewParent" scrolledWindowSetPolicy window PolicyNever PolicyNever - -- Initialize WebSettings webSettings <- webSettingsNew set webSettings settings - -- Initialize WebView webView <- webViewNew set webView [ widgetCanDefault := True ] webViewSetWebSettings webView webSettings - containerAdd window webView - + containerAdd window webView -- _ <- on webView closeWebView $ GTK.mainQuit >> return False --- On new window request - _ <- on webView createWebView $ \frame -> do - webFrameGetUri frame >>= (mapM_ (\uri -> do - whenLoud $ putStrLn ("Requesting new window: " ++ show uri ++ "...") - webViewLoadUri webView uri)) - return webView - return (webView, window) initWindow :: Builder -> WebView -> IO (Window, VBox) @@ -111,24 +105,16 @@ box <- builderGetObject builder castToVBox "windowBox" return (window, box) - -initPromptBar :: Builder -> IO PromptBar -initPromptBar builder = do - label <- builderGetObject builder castToLabel "promptDescription" - labelSetAttributes label [ - AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic}, - AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold} - ] - entry <- builderGetObject builder castToEntry "promptEntry" - box <- builderGetObject builder castToHBox "promptBox" - - return $ PromptBar box label entry - initStatusBar :: Builder -> IO HBox initStatusBar builder = builderGetObject builder castToHBox "statusBox" - +initNotificationBar :: Builder -> IO NotificationBar +initNotificationBar builder = do + label <- builderGetObject builder castToLabel "notificationLabel" + timer <- newIORef Nothing + return $ NotificationBar label timer + -- {{{ Web inspector initWebInspector :: WebView -> VBox -> IO (Window) initWebInspector webView windowBox = do @@ -177,81 +163,11 @@ return inspectorWindow - -- | Show web inspector for current webpage. -showWebInspector :: WebView -> IO () -showWebInspector webView = do - inspector <- webViewGetInspector webView - webInspectorInspectCoordinates inspector 0 0 --- }}} - - --- {{{ Prompt -openPrompt :: PromptBar -> String -> String -> IO () -openPrompt _promptBar@PromptBar {mBox = promptBox, mDescription = description, mEntry = entry} newDescription defaultText = do - labelSetText description newDescription - entrySetText entry defaultText - - widgetShow promptBox - widgetGrabFocus entry - editableSetPosition entry (-1) - --- | Open prompt bar with given description and default value, --- and register a callback to trigger at validation. -prompt :: String -> String -> (String -> IO ()) -> GUI -> IO () -prompt l d = prompt' l d False - --- | Same as 'prompt', but callback is triggered for each change in prompt's entry. -promptIncremental :: String -> String -> (String -> IO ()) -> GUI -> IO () -promptIncremental l d = prompt' l d True - -prompt' :: String -> String -> Bool -> (String -> IO ()) -> GUI -> IO () -prompt' description defaultText incremental callback _gui@GUI {mPromptBar = promptBar, mWebView = webView} = do - openPrompt promptBar description defaultText - --- Register callback - case incremental of - True -> do - id1 <- on entry editableChanged $ entryGetText entry >>= callback - rec id2 <- on entry keyPressEvent $ do - key <- eventKeyName - - case key of - "Return" -> liftIO $ do - widgetHide promptBox - signalDisconnect id1 - signalDisconnect id2 - widgetGrabFocus webView - "Escape" -> liftIO $ do - widgetHide promptBox - signalDisconnect id1 - signalDisconnect id2 - widgetGrabFocus webView - _ -> return () - return False - return () - - _ -> do - rec id <- on entry keyPressEvent $ do - key <- eventKeyName - - case key of - "Return" -> liftIO $ do - widgetHide promptBox - entryGetText entry >>= callback - signalDisconnect id - widgetGrabFocus webView - "Escape" -> liftIO $ do - widgetHide promptBox - signalDisconnect id - widgetGrabFocus webView - _ -> return () - return False - - return () - where - promptBox = mBox promptBar - entry = mEntry promptBar +showWebInspector :: K () +showWebInspector = do + inspector <- with (mWebView . mGUI) webViewGetInspector + io $ webInspectorInspectCoordinates inspector 0 0 -- }}} diff --git a/Hbro/Hbro.hs b/Hbro/Hbro.hs --- a/Hbro/Hbro.hs +++ b/Hbro/Hbro.hs @@ -2,40 +2,54 @@ {-# LANGUAGE DoRec #-} module Hbro.Hbro ( -- * Main - defaultConfig, launchHbro ) where -- {{{ Imports +--import Hbro.Config import Hbro.Core import Hbro.Gui import Hbro.Keys -import Hbro.Socket +import qualified Hbro.Prompt as Prompt +import qualified Hbro.Socket as Socket import Hbro.Types import Hbro.Util import qualified Config.Dyre as D +import Config.Dyre.Compile import Config.Dyre.Paths -import Control.Concurrent -import Control.Monad.Reader +--import Control.Concurrent +import Control.Monad.Reader hiding(forM_, mapM_) +import Data.Dynamic +import Data.Foldable +import Data.IORef import qualified Data.Map as M import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.Entry.Editable +import Graphics.UI.Gtk.Entry.Entry import Graphics.UI.Gtk.General.General hiding(initGUI) -import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri) +import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.WebKit.Download +import Graphics.UI.Gtk.WebKit.NetworkRequest +import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebNavigationAction +import Graphics.UI.Gtk.WebKit.WebPolicyDecision +import Graphics.UI.Gtk.WebKit.WebView import Network.URI +import Prelude hiding(concat, mapM_) + import System.Console.CmdArgs import System.Directory -import System.Environment.XDG.BaseDir +import System.Exit import System.FilePath import System.Glib.Signals import System.IO -import System.Posix.Process +--import System.Posix.Process import System.Posix.Signals import qualified System.ZMQ as ZMQ -- }}} @@ -43,25 +57,45 @@ -- {{{ Commandline options cliOptions :: CliOptions cliOptions = CliOptions { - mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI", - mVanilla = def &= help "Do not read custom configuration file." &= explicit &= name "1" &= name "vanilla", - mDenyReconf = def &= help "Deny recompilation even if the configuration file has changed." &= explicit &= name "deny-reconf", - mForceReconf = def &= help "Force recompilation even if the configuration file hasn't changed." &= explicit &= name "force-reconf", - mDyreDebug = def &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit &= name "dyre-debug", - mMasterBinary = def &= explicit &= name "dyre-master-binary" + mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI", + mVanilla = def &= help "Do not read custom configuration file." &= explicit &= name "1" &= name "vanilla", + mRecompile = def &= help "Force recompilation and do not launch browser." &= explicit &= name "r" &= name "recompile", + mDenyReconf = def &= help "Deny recompilation even if the configuration file has changed." &= explicit &= name "deny-reconf", + mForceReconf = def &= help "Force recompilation even if the configuration file hasn't changed." &= explicit &= name "force-reconf", + mDyreDebug = def &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit &= name "dyre-debug", + mMasterBinary = def &= explicit &= name "dyre-master-binary" } getOptions :: IO CliOptions getOptions = cmdArgs $ cliOptions -    &= verbosityArgs [explicit, name "verbose", name "v"] [] -    &= versionArg [ignore] -    &= help "A minimal KISS-compliant browser." -    &= helpArg [explicit, name "help", name "h"] -    &= program "hbro" + &= verbosityArgs [explicit, name "verbose", name "v"] [] + &= versionArg [ignore] + &= help "A minimal KISS-compliant browser." + &= helpArg [explicit, name "help", name "h"] + &= program "hbro" -- }}} --- {{{ Configuration (Dyre) -dyreParameters :: D.Params (Config, CliOptions) +-- {{{ Util +printDyrePaths :: IO () +printDyrePaths = getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [ + "Current binary: " ++ a, + "Custom binary: " ++ b, + "Config file: " ++ c, + "Cache directory: " ++ d, + "Lib directory: " ++ e, []] + +-- | Launch a recompilation of the configuration file +recompile :: IO (Maybe String) +recompile = do + customCompile dyreParameters + getErrorString dyreParameters + +showError :: (Config', a) -> String -> (Config', a) +showError (_, x) message = (Left message, x) +-- }}} + +-- {{{ Entry point +dyreParameters :: D.Params (Config', CliOptions) dyreParameters = D.defaultParams { D.projectName = "hbro", D.showError = showError, @@ -70,122 +104,208 @@ D.statusOut = hPutStrLn stderr } -showError :: (Config, a) -> String -> (Config, a) -showError (config, x) message = (config { mError = Just message }, x) - --- | Default configuration. --- Homepage: Google, socket directory: /tmp, --- UI file: ~/.config/hbro/, no key/command binding. -defaultConfig :: CommonDirectories -> Config -defaultConfig directories = Config { - mCommonDirectories = directories, - mHomePage = "https://encrypted.google.com/", - mSocketDir = mTemporary directories, - mUIFile = (mConfiguration directories) "ui.xml", - mKeyEventHandler = simpleKeyEventHandler, - mKeyEventCallback = \_ -> simpleKeyEventCallback (keysListToMap []), - mWebSettings = [], - mSetup = const (return () :: IO ()), - mCommands = [], - mDownloadHook = \_ _ _ _ -> return (), - mError = Nothing -} --- }}} - --- {{{ Entry point -- | Browser's main function. -- To be called in main function with a proper configuration. -- See Hbro.Main for an example. -launchHbro :: (CommonDirectories -> Config) -> IO () -launchHbro configGenerator = do - homeDir <- getHomeDirectory - tmpDir <- getTemporaryDirectory - configDir <- getUserConfigDir "hbro" - dataDir <- getUserDataDir "hbro" - - let config = configGenerator (CommonDirectories homeDir tmpDir configDir dataDir) - +launchHbro :: Config -> IO () +launchHbro config = do options <- getOptions +-- Handle recompilation + when (mRecompile options) $ + recompile + >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) +-- Handle vanilla mode case mVanilla options of - True -> D.wrapMain dyreParameters{ D.configCheck = False } (config, options) - _ -> D.wrapMain dyreParameters (config, options) - -realMain :: (Config, CliOptions) -> IO () -realMain (config, options) = do --- Print configuration error, if any - maybe (return ()) putStrLn $ mError config - --- Print in-use paths - whenLoud $ getPaths dyreParameters >>= \(a,b,c,d,e) -> (putStrLn . unlines) [ - "Current binary: " ++ a, - "Custom binary: " ++ b, - "Config file: " ++ c, - "Cache directory: " ++ d, - "Lib directory: " ++ e, - []] - --- Initialize GUI - gui <- initGUI (mUIFile config) (mWebSettings config) + True -> D.wrapMain dyreParameters{ D.configCheck = False } (Right config, options) + _ -> D.wrapMain dyreParameters (Right config, options) --- Initialize IPC socket - ZMQ.withContext 1 $ realMain' config options gui +-- At this point, the reconfiguration process is done +realMain :: (Config', CliOptions) -> IO () +realMain (Left e, _) = putStrLn e +realMain (Right config, options) = do +-- Handle SIGINT + void $ installHandler sigINT (Catch interruptHandler) Nothing +-- Print configuration state + whenLoud printDyrePaths +-- Initialize GUI, state and IPC socket + gui <- initGUI (mUIFile config) (mWebSettings config) + state <- newIORef (M.empty :: M.Map String Dynamic) + + ZMQ.withContext 1 $ \context -> realMain' (Environment state options config gui context) + whenNormal . putStrLn $ "Exiting..." -realMain' :: Config -> CliOptions -> GUI -> ZMQ.Context -> IO () -realMain' config options gui@GUI {mWebView = webView, mWindow = window} context = let - environment = Environment options config gui context - setup = mSetup config - socketDir = mSocketDir config - commands = mCommands config - keyEventHandler = mKeyEventHandler config - keyEventCallback = (mKeyEventCallback config) environment - in do --- Apply custom setup - setup environment +realMain' :: Environment -> IO () +realMain' environment@Environment{ mOptions = options, mConfig = config, mGUI = gui} = let + entry = (mEntry . mPromptBar) gui + webView = mWebView gui + hooks = mHooks config + in do +-- Bind hooks + void $ on webView titleChanged (onTitleChanged environment) + void $ on webView loadFinished (\_frame -> runK environment $ mLoadFinished hooks) + void $ on webView navigationPolicyDecisionRequested (onNavigationRequest environment) + void $ on webView newWindowPolicyDecisionRequested (onNewWindow environment) + void $ on webView createWebView (onNewWebView environment) + void $ on webView downloadRequested (onDownload environment) + void $ on webView mimeTypePolicyDecisionRequested (onMIMEDisposition environment) --- Bind download hook - void $ on webView downloadRequested $ \download -> do - uri <- (>>= parseURI) `fmap` downloadGetUri download - filename <- downloadGetSuggestedFilename download - size <- downloadGetTotalSize download - - case (uri, filename) of - (Just uri', Just filename') -> do - whenNormal $ putStrLn ("Requested download: " ++ show uri') - (mDownloadHook config) environment uri' filename' size - _ -> return () - return False - --- Setup key handler - rec i <- after webView keyPressEvent $ keyEventHandler keyEventCallback i webView + void $ after webView keyPressEvent (onKeyPressed environment) + void $ on entry keyPressEvent (onPromptKeyPress environment) + void $ on entry editableChanged (onPromptChanged environment) --- Load homepage +-- Set start-up page startURI <- case (mURI options) of Just uri -> do fileURI <- doesFileExist uri case fileURI of - True -> getCurrentDirectory >>= \dir -> return $ Just ("file://" ++ dir uri) - _ -> return $ Just uri + True -> getCurrentDirectory >>= \dir -> return $ parseURIReference ("file://" ++ dir uri) + _ -> return $ parseURIReference uri _ -> return Nothing - maybe (goHome webView config) (webViewLoadUri webView) (startURI >>= parseURIReference) - --- Open socket - pid <- getProcessID - let commandsList = M.fromList $ defaultCommandsList ++ commands - let socketURI = "ipc://" ++ socketDir ++ pathSeparator:"hbro." ++ show pid - void $ forkIO (openRepSocket context socketURI (listenToCommands environment commandsList)) - --- Manage POSIX signals - void $ installHandler sigINT (Catch interruptHandler) Nothing - - --timeoutAdd (putStrLn "OK" >> return True) 2000 - mainGUI -- Main loop + runK environment $ do + Socket.open --- Make sure response socket is closed at exit - whenLoud $ putStrLn "Closing socket..." - closeSocket context socketURI - whenNormal $ putStrLn "Exiting..." + -- Custom start-up + mStartUp . mHooks $ config + -- Load home page + maybe goHome loadURI startURI + -- Main loop + io mainGUI + + Socket.close interruptHandler :: IO () interruptHandler = whenLoud (putStrLn "Received SIGINT.") >> mainQuit -- }}} + +-- {{{ Hooks +onDownload :: Environment -> Download -> IO Bool +onDownload environment download = do + uri <- (>>= parseURI) `fmap` downloadGetUri download + filename <- downloadGetSuggestedFilename download + size <- downloadGetTotalSize download + + case (uri, filename) of + (Just uri', Just filename') -> do + whenLoud . putStrLn . ("Requested download: " ++) . show $ uri' + runK environment $ do + notify 5000 $ "Requested download: " ++ filename' ++ " (" ++ show size ++ ")" + callback uri' filename' size + _ -> return () + return False + where + callback = mDownload . mHooks . mConfig $ environment + +onKeyPressed :: Environment -> EventM EKey Bool +onKeyPressed env = do + modifiers <- eventModifier + key' <- keyToString `fmap` eventKeyVal + + io . forM_ key' $ \key -> do + let keystrokes = (++ key) . concat . map stringify $ modifiers + runK env $ (mKeyPressed hooks) keystrokes + return False + where + hooks = mHooks . mConfig $ env + +onMIMEDisposition :: Environment -> WebFrame -> NetworkRequest -> String -> WebPolicyDecision -> IO Bool +onMIMEDisposition env _frame request mimetype decision = do + uri <- (>>= parseURIReference) `fmap` networkRequestGetUri request + forM_ uri (\u -> runK env $ hook u mimetype decision) + return True + where + hook = mMIMEDisposition . mHooks . mConfig $ env + +onNavigationRequest :: Environment -> WebFrame -> NetworkRequest -> WebNavigationAction -> WebPolicyDecision -> IO Bool +onNavigationRequest environment _frame request action decision = do + uri <- (>>= parseURIReference) `fmap` networkRequestGetUri request + reason <- webNavigationActionGetReason action + button <- webNavigationActionGetButton action + + let behavior = case (reason, button, uri) of + (WebNavigationReasonLinkClicked, 1, Just u) -> (mLinkClicked hooks) ButtonL u decision + (WebNavigationReasonLinkClicked, 2, Just u) -> (mLinkClicked hooks) ButtonM u decision + (WebNavigationReasonLinkClicked, 3, Just u) -> (mLinkClicked hooks) ButtonR u decision + (WebNavigationReasonFormSubmitted, _, Just u) -> (mFormSubmitted hooks) u decision + (WebNavigationReasonBackForward, _, Just u) -> (mBackForward hooks) u decision + (WebNavigationReasonReload, _, Just u) -> (mReload hooks) u decision + (WebNavigationReasonFormResubmitted, _, Just u) -> (mFormResubmitted hooks) u decision + (WebNavigationReasonOther, _, Just u) -> (mOtherNavigation hooks) u decision + + (WebNavigationReasonLinkClicked, x, Just _) -> io . whenNormal . putStrLn . ("WARNING: link clicked with invalid button: " ++) . show $ x + _ -> io . whenNormal . putStrLn $ "WARNING: invalid link clicked." + + runK environment behavior + return True + where + hooks = (mHooks . mConfig) environment + +onNewWindow :: Environment -> WebFrame -> NetworkRequest -> WebNavigationAction -> WebPolicyDecision -> IO Bool +onNewWindow _env _frame request _action decision = do + uri <- networkRequestGetUri request + --reason <- webNavigationActionGetReason action + --button <- webNavigationActionGetButton action + + case uri of + Just u -> (putStrLn . ("New window request: " ++) $ u) >> spawn "hbro" ["-u", u] + _ -> putStrLn "WARNING: wrong URI given, unable to open new window." + + webPolicyDecisionIgnore decision + + return True + + + +-- Triggered in 2 cases: +-- 1/ Javascript window.open() +-- 2/ Context menu "Open in new window" +onNewWebView :: Environment -> WebFrame -> IO WebView +onNewWebView _env _frame = do + --forM_ uri $ (runK env) . callback + + webView <- webViewNew + + void . on webView webViewReady $ return True + void . on webView navigationPolicyDecisionRequested $ \_ request _ decision -> do + networkRequestGetUri request >>= mapM_ (\u -> spawn "hbro" ["-u", u]) + webPolicyDecisionIgnore decision + return True + + return webView + --where + --callback = mNewWindow . mHooks . mConfig $ environment + +-- Validate/cancel prompt +onPromptKeyPress :: Environment -> EventM EKey Bool +onPromptKeyPress env = do + key <- eventKeyName + io $ do + callback <- readIORef callbackRef + + when (key == "Return") . runK env $ io (entryGetText entry) >>= callback + when (key == "Return" || key == "Escape") $ do + runK env Prompt.clean + widgetGrabFocus webView + return False + where + callbackRef = mCallbackRef . mPromptBar . mGUI $ env + entry = mEntry . mPromptBar . mGUI $ env + webView = mWebView . mGUI $ env + +-- Incremental behavior +onPromptChanged :: Environment -> IO () +onPromptChanged env = do + callback <- readIORef incrementalCallbackRef + runK env $ io (entryGetText entry) >>= callback + where + incrementalCallbackRef = mIncrementalCallbackRef . mPromptBar . mGUI $ env + entry = mEntry . mPromptBar . mGUI $ env + +-- +onTitleChanged :: Environment -> WebFrame -> String -> IO () +onTitleChanged env _frame title = do + whenLoud . putStrLn . ("Title changed: " ++) $ title + runK env $ hook title + where + hook = mTitleChanged . mHooks . mConfig $ env +-- }}} diff --git a/Hbro/Keys.hs b/Hbro/Keys.hs --- a/Hbro/Keys.hs +++ b/Hbro/Keys.hs @@ -1,80 +1,54 @@ {-# LANGUAGE DoRec #-} module Hbro.Keys ( --- * Key event callbacks - withKeys, - simpleKeyEventCallback, --- * Key event handlers - simpleKeyEventHandler, - advancedKeyEventHandler, +-- * Other -- * Util + stringify, keyToString, - keysListToMap + manageSequentialKeys ) where -- {{{ Imports +import Hbro.Core import Hbro.Types +import Hbro.Util ---import Control.Monad -import Control.Monad.Trans +import Control.Monad hiding(forM_) +--import Control.Monad.Trans -import qualified Data.Map as M -import qualified Data.Set as S +--import Data.Foldable +import Data.IORef +--import qualified Data.Map as M +--import qualified Data.Set as S import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Gdk.Keys -import Graphics.UI.Gtk.WebKit.WebView -import System.Console.CmdArgs (whenLoud, whenNormal) -import System.Glib.Signals +import Prelude hiding(mapM_) + +--import System.Console.CmdArgs (whenLoud) +--import System.Glib.Signals -- }}} -instance Ord Modifier where - m <= m' = fromEnum m <= fromEnum m' --- | Retrieve modifiers and pressed keys, and forward them to a handler. -withKeys :: ([Modifier] -> String -> IO ()) -> EventM EKey Bool -withKeys handler = do - value <- eventKeyVal - modifiers <- eventModifier - - liftIO $ maybe (return ()) (\string -> handler modifiers string) (keyToString value) - - return False - --- | Look for a callback associated to the given modifiers and pressed keys and trigger it, if any. -simpleKeyEventCallback :: KeysMap -> KeyEventCallback -simpleKeyEventCallback keysMap modifiers keys = do - whenLoud $ putStr ("Key pressed: " ++ show modifiers ++ keys ++ " ") - - case M.lookup (S.fromList modifiers, keys) keysMap of - Just callback -> callback >> (whenLoud $ putStrLn "(mapped)") >> return True - _ -> (whenLoud $ putStrLn "(unmapped)") >> return False - --- | Basic key handler which doesn't support sequential keystrokes. -simpleKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool -simpleKeyEventHandler callback _ _ = withKeys (\x y -> callback x y >> return ()) - --- | Key handler with sequential keystrokes support. -advancedKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool -advancedKeyEventHandler = advancedKeyEventHandler' [] - -advancedKeyEventHandler' :: String -> KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool -advancedKeyEventHandler' previousKeys callback oldID webView = withKeys $ \modifiers newKey -> do - let keys = previousKeys ++ newKey - let newHandler = \x -> do - rec newID <- after webView keyPressEvent $ advancedKeyEventHandler' x callback newID webView - return () - - signalDisconnect oldID - result <- callback modifiers keys +manageSequentialKeys :: (String -> K (String, Bool)) -> String -> K (String, Bool) +manageSequentialKeys handler keystroke = do + keysRef <- getState "Hbro.Keys.manageSequentialKeys" "" + keys <- io $ manageSequentialKeys' keysRef keystroke + (keys', result) <- handler keys case result of - True -> newHandler [] - _ -> case newKey of - "" -> newHandler [] - _ -> newHandler keys + True -> (io . modifyIORef keysRef $ const []) >> return ([], result) + _ -> return (keys', result) --- | Convert a keyVal to a String. +manageSequentialKeys' :: IORef String -> String -> IO String +manageSequentialKeys' previousKeys "" = do + writeIORef previousKeys [] + return [] +manageSequentialKeys' previousKeys keystroke = do + modifyIORef previousKeys (++ keystroke) + return =<< readIORef previousKeys + +-- | Convert 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 wrapped into "< >" is returned. -- For modifiers, Nothing is returned. @@ -98,6 +72,13 @@ "dead_diaeresis" -> Just "¨" x -> Just ('<':x ++ ">") +-- | Convert a Modifier to a String. +stringify :: Modifier -> String +stringify Control = "C-" +--stringify' Shift = "S-" +stringify Alt = "M-" +stringify _ = [] + -- | Convert key bindings list to a map. -keysListToMap :: KeysList -> KeysMap -keysListToMap = M.fromList . (map (\((a,b),c) -> ((S.fromList a, b), c))) +-- keysListToMap :: KeysList -> KeysMap +-- keysListToMap = M.fromList . (map (\(a, b) -> ((S.fromList a, b), c))) diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -1,6 +1,7 @@ module Main where -- {{{ Imports +import Hbro.Config import Hbro.Hbro import Hbro.Types @@ -10,11 +11,8 @@ -- | Default main function provided as example. main :: IO () main = do --- putStrLn "[WARNING] You are running the default configuration which provides hardly no feature." --- putStrLn "[WARNING] You should copy the example configuration files hbro.hs and ui.xml in ~/.config/hbro/hbro and start hacking them." - uiFile <- getDataFileName "examples/ui.xml" - launchHbro $ \d -> (defaultConfig d) { - mUIFile = uiFile + launchHbro $ defaultConfig { + mUIFile = const uiFile } diff --git a/Hbro/Prompt.hs b/Hbro/Prompt.hs new file mode 100644 --- /dev/null +++ b/Hbro/Prompt.hs @@ -0,0 +1,95 @@ +module Hbro.Prompt where + +-- {{{ Imports +import Hbro.Core +import Hbro.Types +import Hbro.Util + +import Control.Monad hiding(forM_, mapM_) +--import Control.Monad.Trans + +import Data.Foldable +import Data.IORef + +import Graphics.Rendering.Pango.Enums +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.Builder +import Graphics.UI.Gtk.Display.Label +import Graphics.UI.Gtk.Entry.Editable +import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.Layout.HBox + +import Network.URI + +import Prelude hiding(mapM_) + +import System.Console.CmdArgs (whenLoud) +-- }}} + +init :: Builder -> IO PromptBar +init builder = do + label <- builderGetObject builder castToLabel "promptDescription" + labelSetAttributes label [allItalic, allBold] + + entry <- builderGetObject builder castToEntry "promptEntry" + box <- builderGetObject builder castToHBox "promptBox" + callbackRef <- newIORef (const $ return () :: String -> K ()) + incrementalCallbackRef <- newIORef (const $ return () :: String -> K ()) + + return $ PromptBar box label entry callbackRef incrementalCallbackRef + +open :: String -> String -> K () +open newDescription defaultText = with (mPromptBar . mGUI) $ \(PromptBar promptBox description entry _ _) -> do + whenLoud . putStrLn $ "Opening prompt." + labelSetText description newDescription + entrySetText entry defaultText + + widgetShow promptBox + widgetGrabFocus entry + editableSetPosition entry (-1) + +-- | Close prompt, clean its content and callbacks +clean :: K () +clean = with (mPromptBar . mGUI) $ \(PromptBar box _ entry cRef iRef) -> do + widgetRestoreText entry StateNormal + widgetHide box + writeIORef cRef (const $ return ()) + writeIORef iRef (const $ return ()) + + +-- | Open prompt bar with given description and default value, +-- and register a callback to trigger at validation. +read :: String -- ^ Prompt description + -> String -- ^ Initial value + -> (String -> K ()) -- ^ Callback function to trigger when validating prompt value + -> K () +read = read' False + +-- | Same as 'prompt', but callback is triggered for each change in prompt's entry. +incrementalRead, iread :: String -> String -> (String -> K ()) -> K () +incrementalRead = read' True +-- | Alias for incrementalRead. +iread = incrementalRead + +read' :: Bool -> String -> String -> (String -> K ()) -> K () +read' incremental description startValue callback = do + open description startValue + with (mPromptBar . mGUI) $ \promptBar -> case incremental of + True -> writeIORef (mIncrementalCallbackRef promptBar) callback + _ -> writeIORef (mCallbackRef promptBar) callback + +-- | Same as "read" for URI values +readURI :: String -> String -> (URI -> K ()) -> K () +readURI description startValue callback = withK (mPromptBar . mGUI) $ \promptBar -> do + open description startValue + checkURI startValue + + io . writeIORef (mIncrementalCallbackRef promptBar) $ checkURI + io . writeIORef (mCallbackRef promptBar) $ mapM_ callback . parseURIReference + where + checkURI value = with (mEntry . mPromptBar . mGUI) $ \entry -> do + widgetModifyText entry StateNormal color + where + color = case isURIReference value of + True -> Color 0 65535 0 + _ -> Color 65535 0 0 diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -1,137 +1,89 @@ module Hbro.Socket where -- {{{ Imports +import Hbro.Core hiding(getURI) import Hbro.Util import Hbro.Types +import Control.Concurrent import Control.Monad hiding(mapM_) -import Control.Monad.Reader hiding(mapM_) import Data.ByteString.Char8 (pack, unpack) -import Data.Foldable -import qualified Data.Map as Map - -import Graphics.UI.Gtk.General.General -import Graphics.UI.Gtk.WebKit.WebView hiding(webViewGetUri, webViewLoadUri) - -import Network.URI +--import Data.Foldable +import qualified Data.Map as M import Prelude hiding(mapM_) import System.Console.CmdArgs (whenNormal, whenLoud) import System.FilePath +import System.Posix.Process +import System.Posix.Types import System.ZMQ -- }}} --- | Create a response socket to listen for commands. --- Loops on listenToSocket until "Quit" command is received. -openRepSocket :: Context -> String -> (Socket Rep -> IO ()) -> IO () -openRepSocket context socketURI listen = do - whenNormal $ putStrLn ("Opening socket at " ++ socketURI) - withSocket context Rep $ \repSocket -> do - bind repSocket socketURI - listen repSocket +-- | Open a response-socket at configured location, named hbro., and start listening for commands +open :: K () +open = do +-- Resolve socket URI + pid <- io getProcessID + socketURI <- with (mSocketDir . mConfig) $ resolve >=> (return . (socketFile pid)) +-- Open socket and listen to commands + mapK (void . forkIO) $ withK mContext $ \context -> do + io . whenNormal . putStrLn . ("Opening socket at " ++) $ socketURI + mapK2 (withSocket context Rep) $ \sock -> do + io $ bind sock socketURI + readCommands sock + +-- | Close the response socket by sending it the command "QUIT". +-- Typically called when exiting application. +close :: K () +close = getURI >>= \uri -> do + (io . whenLoud . putStrLn . ("Closing socket " ++) . (++ " ...")) uri + (void . (`sendCommand` "QUIT")) uri + + -- | Listen for incoming requests from response socket. -- Parse received commands and feed the corresponding callback, if any. -listenToCommands :: Environment -> CommandsMap -> Socket Rep -> IO () -listenToCommands environment commands repSocket = do - message <- receive repSocket [] - let message' = unpack message +readCommands :: Socket Rep -> K () +readCommands sock = do + message <- io $ unpack `fmap` receive sock [] - case words message' of + case words message of -- Empty command - [] -> send repSocket (pack "ERROR Unknown command") [] + [] -> io $ send sock (pack "ERROR Unknown command") [] -- Exit command - ["QUIT"] -> do - whenLoud $ putStrLn "Receiving QUIT command" - send repSocket (pack "OK") [] + ["QUIT"] -> io $ do + whenLoud . putStrLn $ "Receiving QUIT command" + send sock (pack "OK") [] -- Valid command - command:arguments -> do - whenLoud $ putStrLn ("Receiving command: " ++ message') - case Map.lookup command commands of - Just callback -> callback arguments repSocket environment - _ -> send repSocket (pack "ERROR Unknown command") [] + command:arguments -> withK (M.fromList . mCommands . mConfig) $ \commands -> do + io . whenLoud . putStrLn . ("Receiving command: " ++) $ message + case M.lookup command commands of + Just callback -> callback arguments >>= io . (send'' sock) . pack + _ -> io $ send sock (pack "ERROR Unknown command") [] - listenToCommands environment commands repSocket + readCommands sock --- | Close the response socket by sending it the command "QUIT". --- Typically called when exiting application. -closeSocket :: Context -> String -> IO () -closeSocket context socketURI = void $ sendCommand context socketURI "QUIT" +getURI :: K String +getURI = with (mSocketDir . mConfig) $ \dir -> do + dir' <- resolve dir + (`socketFile` dir') `fmap` getProcessID -- | Return the socket path to use for the given browser's process ID. -socketFile :: String -> String -> String -socketFile pid socketDir = "ipc://" ++ socketDir "hbro." ++ pid +socketFile :: ProcessID -> String -> String +socketFile pid socketDir = "ipc://" ++ socketDir "hbro." ++ show pid -- | Send a single command (through a Request socket) to the given Response socket, -- and return the answer. -sendCommand :: Context -> String -> String -> IO String -sendCommand context socketURI command = withSocket context Req $ \reqSocket -> do - connect reqSocket socketURI - send reqSocket (pack command) [] - receive reqSocket [] >>= return . unpack +sendCommand :: String -> String -> K String +sendCommand socketURI command = with mContext $ \context -> withSocket context Req $ \sock -> do + connect sock socketURI + send sock (pack command) [] + unpack `fmap` receive sock [] -- | Same as 'sendCommand', but for all running instances of the browser. -sendCommandToAll :: Context -> FilePath -> String -> IO [String] -sendCommandToAll context socketDir command = getAllProcessIDs >>= mapM (\pid -> sendCommand context (socketFile pid socketDir) command) - --- | List of default supported requests. -defaultCommandsList :: CommandsList -defaultCommandsList = [ - -- Get information - ("GET_URI", \_arguments repSocket browser -> liftIO $ do - getUri <- postGUISync $ webViewGetUri (mWebView $ mGUI browser) - case getUri of - Just uri -> send repSocket ((pack . show) uri) [] - _ -> send repSocket (pack "ERROR No URL opened") [] ), - - ("GET_TITLE", \_arguments repSocket browser -> liftIO $ do - getTitle <- postGUISync $ webViewGetTitle (mWebView $ mGUI browser) - case getTitle of - Just title -> send repSocket (pack title) [] - _ -> send repSocket (pack "ERROR No title") [] ), - - ("GET_FAVICON_URI", \_arguments repSocket browser -> liftIO $ do - getUri <- postGUISync $ webViewGetIconUri (mWebView $ mGUI browser) - case getUri of - Just uri -> send repSocket (pack uri) [] - _ -> send repSocket (pack "ERROR No favicon uri") [] ), - - ("GET_LOAD_PROGRESS", \_arguments repSocket browser -> liftIO $ do - progress <- postGUISync $ webViewGetProgress (mWebView $ mGUI browser) - send repSocket (pack (show progress)) [] ), - - - -- Trigger actions - ("LOAD_URI", \arguments repSocket browser -> liftIO $ case arguments of - uri:_ -> do - postGUIAsync $ mapM_ (webViewLoadUri (mWebView (mGUI browser))) (parseURIReference uri) - send repSocket (pack "OK") [] - _ -> send repSocket (pack "ERROR: argument needed.") [] ), - - ("STOP_LOADING", \_arguments repSocket browser -> liftIO $do - postGUIAsync $ webViewStopLoading (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ), - - ("RELOAD", \_arguments repSocket browser -> liftIO $ do - postGUIAsync $ webViewReload (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ), - - ("GO_BACK", \_arguments repSocket browser -> liftIO $ do - postGUIAsync $ webViewGoBack (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ), - - ("GO_FORWARD", \_arguments repSocket browser -> liftIO $ do - postGUIAsync $ webViewGoForward (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ), - - ("ZOOM_IN", \_arguments repSocket browser -> liftIO $ do - postGUIAsync $ webViewZoomIn (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ), - - ("ZOOM_OUT", \_arguments repSocket browser -> liftIO $ do - postGUIAsync $ webViewZoomOut (mWebView $ mGUI browser) - send repSocket (pack "OK") [] ) - ] - +sendCommandToAll :: String -> K [String] +sendCommandToAll command = withK (mSocketDir . mConfig) $ \dir -> do + dir' <- io $ resolve dir + (io getAllProcessIDs) >>= mapM ((`sendCommand` command) . (`socketFile` dir')) diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -1,17 +1,24 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hbro.Types where -- {{{ Imports +import Control.Monad.Reader + +import Data.Dynamic +import Data.IORef import Data.Map -import Data.Set +--import Data.Set import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Entry -import Graphics.UI.Gtk.Layout.HBox +import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.Gdk.EventM +import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow +import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window @@ -20,83 +27,123 @@ import System.Console.CmdArgs import System.Glib.Attributes -import System.Glib.Signals +--import System.Glib.Signals import System.ZMQ -- }}} +-- | Base type for high-level actions, mnemonics: K(it) from WebKit +type K = KT IO --- | Various directories used to store some runtime and static files. -data CommonDirectories = CommonDirectories { - mHome :: FilePath, -- ^ Home directory - mTemporary :: FilePath, -- ^ Temporary files directory - mConfiguration :: FilePath, -- ^ Configuration directory - mData :: FilePath -- ^ Data directory -} - --- | The whole set of parameters and elements of the browser. +newtype KT m a = KT (ReaderT Environment m a) + deriving (Functor, Monad, MonadFix, MonadIO, MonadReader Environment, MonadTrans) + +-- | The whole set of parameters, elements and states of the application data Environment = Environment { - mOptions :: CliOptions, -- ^ Commandline options - mConfig :: Config, -- ^ Configuration parameters (constants) provided by user - mGUI :: GUI, -- ^ Graphical widgets - mContext :: Context -- ^ ZMQ context + mState :: IORef (Map String Dynamic), -- ^ + mOptions :: CliOptions, -- ^ Commandline options + mConfig :: Config, -- ^ Custom configuration provided by user + mGUI :: GUI, -- ^ Graphical widgets + mContext :: Context -- ^ ZeroMQ context } --- | Supported commandline options +-- | Set of commandline options data CliOptions = CliOptions { - mURI :: Maybe String, -- ^ URI to load at start-up - mVanilla :: Bool, -- ^ Bypass custom configuration file - mDenyReconf :: Bool, -- ^ Do not recompile browser even if configuration file has changed - mForceReconf :: Bool, -- ^ Force recompilation even if configuration file hasn't changed - mDyreDebug :: Bool, -- ^ Look for a custom configuration file in working directory - mMasterBinary :: Maybe String -- ^ + mURI :: Maybe String, -- ^ URI to load at start-up + mVanilla :: Bool, -- ^ Bypass custom configuration file + mRecompile :: Bool, -- ^ Force recompilation and do not launch browser + mDenyReconf :: Bool, -- ^ Do not recompile browser even if configuration file has changed + mForceReconf :: Bool, -- ^ Force recompilation even if configuration file hasn't changed + mDyreDebug :: Bool, -- ^ Look for a custom configuration file in current working directory + mMasterBinary :: Maybe String -- ^ Path to the master binary, used by Dyre } deriving (Data, Typeable, Show, Eq) - -data Config = {-forall a.-} Config { - mCommonDirectories :: CommonDirectories, -- ^ Custom directories used to store various runtime and static files +-- | Custom parameters provided by the user +data Config = Config { + --mCommonDirectories :: CommonDirectories, -- ^ Custom directories used to store various runtime and static files + mSocketDir :: RefDirs -> FilePath, -- ^ Directory where 0MQ sockets will be created ("/tmp" for example) + mUIFile :: RefDirs -> FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder) mHomePage :: String, -- ^ Startup page - mSocketDir :: FilePath, -- ^ Directory where 0MQ will be created ("/tmp" for example) - mUIFile :: FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder) - mKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool, -- ^ Key event handler, which forwards keystrokes to mKeyEventCallback - mKeyEventCallback :: Environment -> KeyEventCallback, -- ^ Main key event callback, assumed to deal with each keystroke separately mWebSettings :: [AttrOp WebSettings], -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation) - mSetup :: Environment -> IO (), -- ^ Custom startup instructions - mCommands :: CommandsList, -- ^ Custom commands to use with IPC sockets - mDownloadHook :: Environment -> URI -> String -> Int -> IO (), -- ^ Function triggered on a download request - mError :: Maybe String -- ^ Error - --mCustom :: a +-- mKeyEventHandler :: KeyEventCallback -> ConnectId WebView -> WebView -> EventM EKey Bool, -- ^ Key event handler, which forwards keystrokes to mKeyEventCallback +-- mKeyEventCallback :: Environment -> KeyEventCallback, -- ^ Main key event callback, assumed to deal with each keystroke separately + mCommands :: CommandsList, -- ^ Commands recognized through 0MQ sockets + mHooks :: Hooks -- ^ Set of functions triggered on specific events } +type Config' = Either String Config + + +-- | Set of functions to be triggered when some events occur +data Hooks = Hooks { + mBackForward :: URI -> WebPolicyDecision -> K (), -- ^ Previous/next page has been requested + mDownload :: URI -> String -> Int -> K (), -- ^ A download has been requested + mFormResubmitted :: URI -> WebPolicyDecision -> K(), -- ^ A form has been resubmitted + mFormSubmitted :: URI -> WebPolicyDecision -> K (), -- ^ A form has been submitted + mKeyPressed :: String -> K (), -- ^ + mLinkClicked :: Button -> URI -> WebPolicyDecision -> K (), -- ^ A link has been clicked + mLoadFinished :: K (), -- ^ Load has finished + mMIMEDisposition :: URI -> String -> WebPolicyDecision -> K (), + mNewWindow :: URI -> K (), -- ^ A new window has been requested + mOtherNavigation :: URI -> WebPolicyDecision -> K (), -- ^ + mReload :: URI -> WebPolicyDecision -> K (), -- ^ A reload of the current page has been requested + mStartUp :: K (), -- ^ At start-up + mTitleChanged :: String -> K () -- ^ Title has changed +} + +-- | Graphical elements data GUI = GUI { mWindow :: Window, -- ^ Main window - mInspectorWindow :: Window, -- ^ WebInspector window + mInspectorWindow :: Window, -- ^ Web-inspector window mScrollWindow :: ScrolledWindow, -- ^ ScrolledWindow containing the webview mWebView :: WebView, -- ^ Browser's webview mPromptBar :: PromptBar, -- ^ Prompt bar mStatusBar :: HBox, -- ^ Status bar's horizontal box + mNotificationBar :: NotificationBar, -- ^ Bar used to display various notifications mBuilder :: Builder -- ^ Builder object created from XML file } +-- | Prompt-bar elements data PromptBar = PromptBar { - mBox :: HBox, - mDescription :: Label, -- ^ Description of current prompt - mEntry :: Entry -- ^ Prompt entry + mBox :: HBox, -- ^ Layout box + mDescription :: Label, -- ^ Description of current prompt + mEntry :: Entry, -- ^ Prompt entry + mCallbackRef :: IORef (String -> K ()), -- ^ + mIncrementalCallbackRef :: IORef (String -> K ()) -- ^ } +-- | Notification-bar elements +data NotificationBar = NotificationBar { + mLabel :: Label, -- ^ Content + mTimer :: IORef (Maybe HandlerId) -- ^ Timer handler +} --- | List of bound keys. --- All callbacks are fed with the Environment instance. --- +-- | Set of reference directories, typically used to build FilePath-s +data RefDirs = RefDirs { + mHome :: FilePath, -- ^ Home directory + mTemporary :: FilePath, -- ^ Temporary files directory + mConfiguration :: FilePath, -- ^ Configuration directory + mData :: FilePath -- ^ Data directory +} + +type PortableFilePath = RefDirs -> FilePath + -- Note 1 : for modifiers, lists are used for convenience purposes, -- but are transformed into sets in hbro's internal machinery, -- so that order and repetition don't matter. --- --- Note 2 : for printable characters accessed via the shift modifier, --- you do have to include Shift in modifiers list. -type KeysList = [(([Modifier], String), IO ())] -type KeysMap = Map (Set Modifier, String) (IO ()) +-- | List of bound keys. +-- All callbacks are fed with the Environment instance. +type KeysList = [(String, K ())] +type KeysMap = Map String (K ()) type KeyEventCallback = [Modifier] -> String -> IO Bool --data KeyMode = CommandMode | InsertMode -type CommandsList = [(String, ([String] -> Socket Rep -> Environment -> IO ()))] -type CommandsMap = Map String ([String] -> Socket Rep -> Environment -> IO ()) +type CommandsList = [(String, ([String] -> K String))] +type CommandsMap = Map String ([String] -> K String) + +-- | +data Button = ButtonL | ButtonM | ButtonR + +-- Boolean datatypes +data CaseSensitivity = CaseSensitive | CaseInsensitive +data Direction = Forward | Backward +data Wrap = Wrap | NoWrap diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -1,42 +1,69 @@ module Hbro.Util ( +-- * General purpose + io, + resolve, -- * Process management spawn, getAllProcessIDs, --- * WebKit functions redefinition - webFrameGetUri, - webViewGetUri, - webViewLoadUri, +-- * Boolean data-types conversion + isCaseSensitive, + isForward, + isWrapped, +-- * Common pango attributes + allItalic, + allBold, -- * Misc + send'', labelSetMarkupTemporary, dmenu, errorHandler ) where -- {{{ Imports ---import Hbro.Types +import Hbro.Types +import Control.Exception --import Control.Monad.Reader import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +--import Data.IORef import Data.List -import Data.IORef +import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.General.General -import qualified Graphics.UI.Gtk.WebKit.WebFrame as WebKit -import qualified Graphics.UI.Gtk.WebKit.WebView as WebKit -import Network.URI - import System.Console.CmdArgs +import System.Directory +import System.Environment.XDG.BaseDir import qualified System.Info as Sys import System.IO -import System.IO.Error +import System.IO.Error hiding(try) import System.Posix.Process +import System.Posix.Types import System.Process +import System.ZMQ -- }}} +io :: MonadIO m => IO a -> m a +io = liftIO + +send'' :: Socket a -> ByteString -> IO () +send'' x y = send x y [] + +-- | +resolve :: (RefDirs -> a) -> IO a +resolve f = do + homeDir <- getHomeDirectory + tmpDir <- getTemporaryDirectory + configDir <- getUserConfigDir "hbro" + dataDir <- getUserDataDir "hbro" + + return . f $ RefDirs homeDir tmpDir configDir dataDir + -- {{{ Process management -- | Run external command and won't kill when parent process exit. spawn :: String -> [String] -> IO () @@ -46,31 +73,13 @@ spawn' command = createProcess command { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return () -- | Return the list of process IDs corresponding to all running instances of the browser. -getAllProcessIDs :: IO [FilePath] +getAllProcessIDs :: IO [ProcessID] getAllProcessIDs = do (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] [] (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] myPid <- getProcessID - return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids' --- }}} - --- {{{ Webkit functions redefinition --- | Replacement for Graphics.UI.Gtk.WebKit.WebFrame(webFrameGetUri), using the Network.URI type. -webFrameGetUri :: WebKit.WebFrame -> IO (Maybe URI) -webFrameGetUri frame = (>>= parseURI) `fmap` WebKit.webFrameGetUri frame - --- | Replacement for Graphics.UI.Gtk.WebKit.WebView(webViewGetUri), using the Network.URI type. -webViewGetUri :: WebKit.WebView -> IO (Maybe URI) -webViewGetUri webView = (>>= parseURI) `fmap` WebKit.webViewGetUri webView - --- | Replacement for Graphics.UI.Gtk.WebKit.WebView(webViewLoadUri), using the Network.URI type. -webViewLoadUri :: WebKit.WebView -> URI -> IO () -webViewLoadUri webView uri = do - whenLoud $ putStrLn ("Loading URI: " ++ show uri) - case uriScheme uri of - [] -> WebKit.webViewLoadUri webView ("http://" ++ show uri) - _ -> WebKit.webViewLoadUri webView (show uri) + return $ delete myPid . map (read :: String -> ProcessID) . nub . words $ pids ++ " " ++ pids' -- }}} -- | Set a temporary markup text to a label that disappears after some delay. @@ -93,7 +102,7 @@ hPutStr in_ input hClose in_ - output <- try $ hGetLine out + output <- try $ hGetLine out :: IO (Either IOError String) let output' = case output of Left _ -> Nothing Right x -> Just x @@ -106,3 +115,22 @@ when (isAlreadyInUseError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> is already opened and cannot be reopened.") when (isDoesNotExistError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> doesn't exist.") when (isPermissionError e) $ (whenNormal . putStrLn) ("ERROR: user doesn't have permission to open file <" ++ file ++ ">.") + +-- Boolean types conversion +isCaseSensitive :: CaseSensitivity -> Bool +isCaseSensitive CaseSensitive = True +isCaseSensitive _ = False + +isForward :: Direction -> Bool +isForward Forward = True +isForward _ = False + +isWrapped :: Wrap -> Bool +isWrapped Wrap = True +isWrapped _ = False + +-- Common pango attributes +allItalic, allBold :: PangoAttribute +allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic} +allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold} + diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -3,7 +3,7 @@ ==== -**In a nutshell**: *hbro* is a minimal KISS compliant browser written in Haskell and for linux, still in development but pretty usable. +**In a nutshell**: *hbro* is a minimal KISS compliant browser for linux written and configured in Haskell, still in development but pretty usable. Informations about versions, dependencies, source repositories and contacts can be found in hackage_. @@ -57,33 +57,10 @@ Apart from the programming language, if you happen to find a better alternative for one of these points, please note that suggestions are more than welcome :) . -.. How to install it ? - ------------------- - - Please note that despite being written in a multiplatform language, *hbro* will only run under a linux environment. - - The simplest way is using the haskell packaging system:: - - cabal install hbro - - Alternatively, you can download the hbro package from hackage, and install it with cabal-install. - - -.. Where to get the source ? - ------------------------- - - The latest source is hosted: - - * on github: ``git@github.com:k0ral/hbro.git`` - * on a personal server, which is unfortunately shutdown every european night: ``git://twyk.org/haskell-browser.git`` - - You can still retrieve the source from hackage at any time, however the very last commits may not be included. - - Configuration ------------- -By default, a pretty limited configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the *hbro-contrib_* package, including a featured and self-explanatory example of configuration file. +By default, a pretty limited configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the * hbro-contrib_ * package, including a featured and self-explanatory example of configuration file. Known bugs and limitations @@ -94,8 +71,8 @@ Flash videos make hbro freeze The demo webkit browser for haskell's binding has the same problem, so it doesn't seem to come from hbro itself. -Javascript's window.open requests open in the same window instead of spawning a new one. - This is due to this webkit's bug. +.. Javascript's window.open requests open in the same window instead of spawning a new one. + This is due to this webkit's bug. When toggling to source mode, current webpage is reloaded This is an undesired behavior since the webpage may have changed after reloading; webkit's API allows to get the content of the DOM but only inside the body tag; it is also possible to store the HTML source as it is downloaded, but then any further change in the DOM (for example triggered by javascript functions) wouldn't be visible. diff --git a/examples/ui.xml b/examples/ui.xml --- a/examples/ui.xml +++ b/examples/ui.xml @@ -39,13 +39,34 @@ False 5 - + False False + + + + + False + False + + + + + + + + False + 5 + + + + True + 0 + diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,6 +1,6 @@ Name: hbro -Version: 0.8.0.0 -Synopsis: A minimal KISS compliant browser +Version: 0.9.0.0 +Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ Category: Browser,Web @@ -38,15 +38,18 @@ network, pango, process, + transformers, unix, webkit, xdg-basedir, zeromq-haskell Exposed-modules: + Hbro.Config, Hbro.Core, Hbro.Gui, Hbro.Hbro, Hbro.Keys, + Hbro.Prompt, Hbro.Socket, Hbro.Types, Hbro.Util