diff --git a/Hbro.hs b/Hbro.hs new file mode 100644 --- /dev/null +++ b/Hbro.hs @@ -0,0 +1,21 @@ +module Hbro ( + module Hbro.Boot, + module Hbro.Core, + module Hbro.Default, + module Hbro.Gui, + module Hbro.Keys, + module Hbro.Socket, + module Hbro.Types, + module Hbro.Util, + module Hbro.Webkit.WebView +) where + +import Hbro.Boot +import Hbro.Core +import Hbro.Default +import Hbro.Gui +import Hbro.Keys +import Hbro.Socket +import Hbro.Types +import Hbro.Util +import Hbro.Webkit.WebView diff --git a/Hbro/Boot.hs b/Hbro/Boot.hs --- a/Hbro/Boot.hs +++ b/Hbro/Boot.hs @@ -1,47 +1,56 @@ -module Hbro.Boot ( --- * Commandline options - getOptions, --- * Dynamic reconfiguration - printDyrePaths, - recompile, --- * Boot - hbro -) where +{-# LANGUAGE FlexibleContexts, RankNTypes #-} +module Hbro.Boot where -import qualified Hbro.Hbro as Hbro +-- {{{ Imports +import Hbro.Core +import qualified Hbro.Gui as Gui +import qualified Hbro.Prompt as Prompt +import qualified Hbro.Socket as Socket import Hbro.Types import Hbro.Util +import Hbro.Webkit.WebView as WebView +import Control.Concurrent import qualified Config.Dyre as D import Config.Dyre.Compile import Config.Dyre.Paths +import Control.Applicative import Control.Monad +import Control.Monad.Error +import Control.Monad.Reader +-- import Data.Functor +import Data.IORef +-- import Data.Maybe + import Graphics.UI.Gtk.General.General hiding(initGUI) +import Network.URI as N + import System.Console.CmdArgs +import System.Directory +import System.FilePath import System.Exit import System.IO import System.Posix.Signals - - - +import qualified System.ZMQ as ZMQ +-- }}} -- {{{ Commandline options -cliOptions :: CliOptions -cliOptions = CliOptions { - mURI = def &= name "u" &= name "uri" &= typ "URI" &= help "URI to open at start-up" &= explicit, - mVanilla = def &= name "1" &= name "vanilla"&= help "Do not read custom configuration file." &= explicit, - mRecompile = def &= name "r" &= name "recompile" &= help "Force recompilation and do not launch browser." &= explicit, - mDenyReconf = def &= name "deny-reconf" &= help "Deny recompilation even if the configuration file has changed." &= explicit, - mForceReconf = def &= name "force-reconf" &= help "Force recompilation even if the configuration file hasn't changed." &= explicit, - mDyreDebug = def &= name "dyre-debug" &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation." &= explicit, - mMasterBinary = def &= name "dyre-master-binary" &= explicit -} +baseOptions :: CliOptions +baseOptions = CliOptions { + __startURI = def &= explicit &= name "u" &= name "uri" &= typ "URI" &= help "URI to open at start-up", + __vanilla = def &= explicit &= name "1" &= name "vanilla" &= help "Do not read custom configuration file.", + __recompile = def &= explicit &= name "r" &= name "recompile" &= help "Force recompilation and do not launch browser.", + __denyReconf = def &= explicit &= name "deny-reconf" &= help "Deny recompilation even if the configuration file has changed.", + __forceReconf = def &= explicit &= name "force-reconf" &= help "Force recompilation even if the configuration file hasn't changed.", + __dyreDebug = def &= explicit &= name "dyre-debug" &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation.", + __masterBinary = def &= explicit &= name "dyre-master-binary"} -getOptions :: IO CliOptions -getOptions = cmdArgs $ cliOptions +-- | Available commandline options (cf hbro -h). +cliOptions :: Mode (CmdArgs CliOptions) +cliOptions = cmdArgsMode $ baseOptions &= verbosityArgs [explicit, name "verbose", name "v"] [] &= versionArg [ignore] &= help "A minimal KISS-compliant browser." @@ -50,57 +59,91 @@ -- }}} -- {{{ Dynamic reconfiguration +-- | Print various paths used for dynamic reconfiguration 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, []] +printDyrePaths = do + (a, b, c, d, e) <- getPaths dyreParameters + putStrLn $ unlines [ + "Current binary: " ++ a, + "Custom binary: " ++ b, + "Config file: " ++ c, + "Cache directory: " ++ d, + "Lib directory: " ++ e, []] +-- | Dynamic reconfiguration settings +dyreParameters :: D.Params (Either String (Config, Setup, CliOptions)) +dyreParameters = D.defaultParams { + D.projectName = "hbro", + D.showError = \_ -> Left, + D.realMain = realMain, + D.ghcOpts = ["-threaded"], + D.statusOut = hPutStrLn stderr, + D.includeCurrentDirectory = False} + -- | Launch a recompilation of the configuration file recompile :: IO (Maybe String) recompile = do - customCompile dyreParameters - getErrorString dyreParameters + customCompile dyreParameters + getErrorString dyreParameters +-- }}} -showError :: (Config', a) -> String -> (Config', a) -showError (_, x) message = (Left message, x) +-- | Main function to call in the configuration file (cf 'Hbro.Main') +-- First parse commandline options, then perform dynamic reconfiguration process +hbro :: Config -> Setup -> IO () +hbro config startUp = do + options <- cmdArgsRun cliOptions -dyreParameters :: D.Params (Config', CliOptions) -dyreParameters = D.defaultParams { - D.projectName = "hbro", - D.showError = showError, - D.realMain = realMain, - D.ghcOpts = ["-threaded"], - D.statusOut = hPutStrLn stderr -} --- }}} + when (_recompile options) $ + recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) --- | Browser's main function. --- To be called in main function with a proper configuration. --- See Hbro.Main for an example. -hbro :: Config -> IO () -hbro config = do - options <- getOptions - - when (mRecompile options) $ - recompile - >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) - - case mVanilla options of - True -> D.wrapMain dyreParameters{ D.configCheck = False } (Right config, options) - _ -> D.wrapMain dyreParameters (Right config, options) + D.wrapMain dyreParameters{ D.configCheck = not $ _vanilla options } $ Right (config, startUp, options) -realMain :: (Config', CliOptions) -> IO () -realMain (Left e, _) = putStrLn e -realMain config = do +-- | Entry point called after dynamic recompilation. +realMain :: Either String (Config, Setup, CliOptions) -> IO () +realMain (Left e) = putStrLn e +realMain (Right (config, Setup customSetup, options)) = do void $ installHandler sigINT (Catch interruptHandler) Nothing whenLoud printDyrePaths - Hbro.main config + gui <- runReaderT Gui.build' config + hooks <- Hooks <$> newIORef Nothing <*> newIORef Nothing <*> newIORef Nothing + startURI <- getStartURI options + keys <- newIORef "" + zmqContext <- ZMQ.init 1 + result <- runErrorT . (`runReaderT` Context options config gui zmqContext hooks keys) $ do + threadSync <- fork Socket.open + + Gui.setupWindow + Gui.setupScrollWindow + Prompt.setup + WebView.setup + customSetup + + maybe goHome loadURI startURI -- Load home page + io mainGUI -- Main loop + + Socket.close + io $ takeMVar threadSync + + either print return result + + ZMQ.term zmqContext + logNormal "Exiting..." + + +-- +getStartURI :: CliOptions -> IO (Maybe URI) +getStartURI options = case (__startURI options) of + Just uri -> do + fileURI <- doesFileExist uri + case fileURI of + True -> getCurrentDirectory >>= return . N.parseURIReference . ("file://" ++) . ( uri) + _ -> return $ N.parseURIReference uri + _ -> return Nothing + + +-- interruptHandler :: IO () interruptHandler = logVerbose "Received SIGINT." >> mainQuit - diff --git a/Hbro/Clipboard.hs b/Hbro/Clipboard.hs new file mode 100644 --- /dev/null +++ b/Hbro/Clipboard.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Designed to be imported as @qualified@. +module Hbro.Clipboard where + +-- {{{ Imports +-- import Hbro.Core +import Hbro.Types +import Hbro.Util + +import Control.Monad.Error +import Control.Monad.IO.Class +import Control.Monad.Trans.Control + +import Graphics.UI.Gtk.General.Clipboard +-- }}} + + +--requestText :: (ClipboardClass a, MonadIO m, MonadError HError m, MonadBaseControl IO m) => a -> ClipboardHook -> m () +requestText clip f = liftBaseWith $ \runInIO -> clipboardRequestText clip $ \x -> void . runInIO . maybe (throwError $ OtherError "Empty clipboard") f $ x + +-- | Write given String to primary clipboard. +insert :: (MonadIO m) => String -> m () +insert text = io $ clipboardGet selectionPrimary >>= (`clipboardSetText` text) + +with :: (MonadIO m, MonadBaseControl IO m, MonadError HError m) => (String -> m ()) -> m () +with f = do + clip <- io $ clipboardGet selectionPrimary + requestText clip f diff --git a/Hbro/Config.hs b/Hbro/Config.hs deleted file mode 100644 --- a/Hbro/Config.hs +++ /dev/null @@ -1,159 +0,0 @@ -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 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.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." - --- | 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,219 +1,54 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DoRec #-} -module Hbro.Core ( --- * 'K'-monad - runK, - mapK, - mapK2, --- * Util - with, - withK, - withTitle, - withURI, --- * Read state - getFaviconURI, - getLoadProgress, - getTitle, - getURI, - getState, --- * Browse - goBack, - goForward, - goHome, - loadURI, - reload, - reloadBypassCache, - stopLoading, --- * Display - zoomIn, - zoomOut, - Axis(..), - Position(..), - scroll, --- * Misc - notify, - searchText, - toggleSourceMode, - printPage, - executeJSFile -) where +{-# LANGUAGE FlexibleContexts, RankNTypes #-} +module Hbro.Core where -- {{{ Imports import Hbro.Types -import Hbro.Util +import Hbro.Util as H +import Hbro.Webkit.WebView as WebView +import Control.Monad.Error hiding(forM_, mapM_) 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 Data.Default +-- import Data.Foldable +-- import Data.Functor -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 -import Network.URI - -import Prelude hiding(mapM_) - -import System.Console.CmdArgs --- }}} - --- {{{ '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) +import Prelude hiding(concat, mapM_) -- }}} -- {{{ Util -with :: (Environment -> a) -> (a -> IO b) -> K b -with selector callback = withK selector $ io . callback - -withK :: (Environment -> a) -> (a -> K b) -> K b -withK selector callback = callback =<< asks selector - -withTitle :: (String -> K ()) -> K () -withTitle callback = (mapM_ callback) =<< getTitle - -withURI :: (URI -> K ()) -> K () -withURI callback = (mapM_ callback) =<< getURI - -getFaviconURI :: K (Maybe URI) -getFaviconURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetIconUri - -getLoadProgress :: K Double -getLoadProgress = with (mWebView . mGUI) webViewGetProgress - -getURI :: K (Maybe URI) -getURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetUri - -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 +{-getState :: (MonadIO m, MonadError HError m, Typeable a) => String -> a -> m a +getState key defaultValue = do + customMap <- gets _custom + let result = fromDynamic =<< M.lookup key customMap 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 - logVerbose $ "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" + modify $ \s -> s { _custom = M.insert key (toDyn defaultValue) customMap } + return defaultValue-} -- }}} --- {{{ 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 +goHome :: (MonadIO m, MonadReader r m, HasConfig r, HasWebView r, MonadError HError m) => m () +goHome = loadURI =<< asks _homePage --- | 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) --- }}} +quit :: (MonadIO m) => m () +quit = io mainQuit -- {{{ Misc -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 () +executeJSFile :: (MonadIO m) => FilePath -> WebView -> m () executeJSFile filePath webView = do - whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath) - script <- readFile filePath - let script' = unwords . map (\line -> line ++ "\n") . lines $ script + logNormal $ "Executing Javascript file: " ++ filePath + script <- io $ readFile filePath + let script' = unwords . map (++ "\n") . lines $ script - webViewExecuteScript webView script' + io $ webViewExecuteScript webView script' -- }}} - -- | Save current web page to a file, -- along with all its resources in a separated directory. diff --git a/Hbro/Default.hs b/Hbro/Default.hs new file mode 100644 --- /dev/null +++ b/Hbro/Default.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +module Hbro.Default where + +-- {{{ Import +import qualified Hbro.Clipboard as Clipboard +import Hbro.Core +import Hbro.Keys +import Hbro.Gtk.ScrolledWindow +import Hbro.Gui +import qualified Hbro.Prompt as Prompt +import Hbro.Types +import Hbro.Util +import Hbro.Webkit.WebView + +import Control.Applicative +import Control.Conditional +import Control.Monad.Error hiding(mapM_) +import Control.Monad.Reader hiding(mapM_) +-- import Control.Monad.State hiding(mapM_) +-- import Control.Monad.Trans.Control + +import Data.Default +-- import Data.Foldable +-- import Data.Functor + +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.General.General +import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.Gdk.EventM +import Graphics.UI.Gtk.WebKit.WebPolicyDecision +import Graphics.UI.Gtk.WebKit.WebNavigationAction +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.Windows.Window + +import Prelude hiding(mapM_) + +-- import Network.URI (URI) +import qualified Network.URI as N + +import System.Directory +import System.Environment.XDG.BaseDir +import System.Glib.Attributes +-- }}} + +-- | Default configuration. +-- Homepage: DuckDuckGo, socket directory: system's temporary directory, +-- UI file: ~/.config/hbro/, Webkit's default websettings, default key/command bindings. +instance Default Config where + def = Config { + __homePage = maybe undefined id . N.parseURI $ "https://duckduckgo.com/", + __socketDir = getTemporaryDirectory, + __UIFile = getUserConfigDir "hbro" >/> "ui.xml", + __commands = def} + +instance Default Setup where + def = Setup $ do + _ <- afterKeyPressed $ emacsKeyHandler def [] + _ <- onNavigationRequest $ def + _ <- onNewWebView $ def + _ <- onNewWindow $ def + _ <- onResourceOpened $ def + _ <- onTitleChanged $ def + return () + +instance Default NewWindowHook where + def = NewWindowHook $ \_frame request _action decision -> do + io $ webPolicyDecisionIgnore decision + uri <- networkRequestGetUri request + logVerbose $ "New window request: " ++ show uri + spawn "hbro" ["-u", show uri] + + --either (\e -> io . putStrLn $ "WARNING: wrong URI given, unable to open new window.") (const $ return ()) result + +instance Default NavigationHook where + def = let f WebNavigationReasonLinkClicked (Just MiddleButton) uri decision = io $ webPolicyDecisionIgnore decision >> spawn "hbro" ["-u", show uri] + f _ _ _ decision = io $ webPolicyDecisionUse decision + in NavigationHook f + +-- /!\ 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. +instance Default ResourceOpenedHook where + def = ResourceOpenedHook $ \_uri mimetype decision -> do + canShow <- io . (`webViewCanShowMimeType` mimetype) =<< asks _webview + io $ (canShow ? webPolicyDecisionUse ?? webPolicyDecisionDownload) decision + +instance Default TitleChangedHook where + def = TitleChangedHook $ \title -> asks _mainWindow >>= io . (`set` [ windowTitle := ("hbro | " ++ title)]) + + +-- | Default key bindings. +instance Default KeysList where + def = KeysList [ + -- 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), + -- Copy/paste + ("C-c", getURI >>= Clipboard.insert . show >> notify 5000 "URI copied to clipboard"), + ("M-c", getTitle >>= Clipboard.insert >> notify 5000 "Page title copied to clipboard"), + ("C-v", Clipboard.with $ parseURIReference >=> loadURI), + ("M-v", Clipboard.with $ \uri -> spawn "hbro" ["-u", uri]), + -- Display + ("C-+", zoomIn), + ("C--", zoomOut), + -- ("", with (_window . _UI) windowFullscreen), + -- ("", with (_window . _UI) windowUnfullscreen), + ("C-b", toggleVisibility =<< asks _statusBar), + ("C-u", toggleSourceMode), + -- Prompt + ("C-o", Prompt.readURI "Open URI" "" loadURI), + ("M-o", getURI >>= \uri -> Prompt.readURI "Open URI " (show uri) loadURI), + -- Search + ("/", Prompt.iread "Search " "" $ searchText_ CaseInsensitive Forward Wrap), + ("C-f", Prompt.iread "Search " "" $ searchText_ CaseInsensitive Forward Wrap), + ("?", Prompt.iread "Search " "" $ searchText_ CaseInsensitive Backward Wrap), + ("C-n", void . searchText CaseInsensitive Forward Wrap =<< io . entryGetText . _entry =<< asks _promptBar), + ("C-N", void . searchText CaseInsensitive Backward Wrap =<< io . entryGetText . _entry =<< asks _promptBar), + -- Misc + ("", io . widgetHide . _box =<< asks _promptBar), + ("C-i", showWebInspector), + ("C-p", printPage), + ("C-t", spawn "hbro" []), + ("C-w", quit)] + + +-- | List of default supported requests. +instance Default CommandsList where + def = CommandsList [ + -- Get information + ("GET_URI", \_arguments -> show <$> getURI), + ("GET_TITLE", \_arguments -> show <$> getTitle), + ("GET_FAVICON_URI", \_arguments -> show <$> getFaviconURI), + ("GET_LOAD_PROGRESS", \_arguments -> show <$> getLoadProgress), + -- Trigger actions + ("LOAD_URI", \arguments -> case arguments of + uri:_ -> parseURIReference uri >>= loadURI >> return "OK" + _ -> return "ERROR Argument needed."), + ("STOP_LOADING", \_arguments -> stopLoading >> return "OK"), + ("RELOAD", \_arguments -> reload >> return "OK"), + ("GO_BACK", \_arguments -> goBack >> return "OK"), + ("GO_FORWARD", \_arguments -> goForward >> return "OK"), + ("ZOOM_IN", \_arguments -> zoomIn >> return "OK"), + ("ZOOM_OUT", \_arguments -> zoomOut >> return "OK")] diff --git a/Hbro/Gtk/Entry.hs b/Hbro/Gtk/Entry.hs new file mode 100644 --- /dev/null +++ b/Hbro/Gtk/Entry.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts, RankNTypes #-} +module Hbro.Gtk.Entry where + +-- {{{ Imports +import Hbro.Types +import Hbro.Util + +-- import Control.Arrow +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.Trans.Control + +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.Entry.Editable +import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.Gdk.EventM + +import System.Glib.Signals +-- }}} + +-- Validate/cancel prompt +onEntryValidated :: (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r, EntryClass t) => t -> EntryHook -> m (ConnectId t) +onEntryValidated entry f = liftBaseWith $ \runInIO -> on entry keyPressEvent $ do + key <- eventKeyName + io $ when (key == "Return") $ do + void . runInIO $ (io (entryGetText entry) >>= f) `catchError` \e -> io (print e) >> notify 5000 (show e) + return False + +-- Incremental behavior +onEntryChanged :: (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r, EditableClass t, EntryClass t) => t -> EntryHook -> m (ConnectId t) +onEntryChanged entry f = liftBaseWith $ \runInIO -> on entry editableChanged $ do + void . runInIO $ (io (entryGetText entry) >>= f) `catchError` \e -> io (print e) >> notify 5000 (show e) diff --git a/Hbro/Gtk/ScrolledWindow.hs b/Hbro/Gtk/ScrolledWindow.hs new file mode 100644 --- /dev/null +++ b/Hbro/Gtk/ScrolledWindow.hs @@ -0,0 +1,35 @@ +module Hbro.Gtk.ScrolledWindow where + +-- {{{ Imports +import Hbro.Util +import Hbro.Types + +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Graphics.UI.Gtk.Misc.Adjustment +import Graphics.UI.Gtk.Scrolling.ScrolledWindow +-- }}} + +getAdjustment :: (MonadIO m) => Axis -> ScrolledWindow -> m Adjustment +getAdjustment Horizontal = io . scrolledWindowGetHAdjustment +getAdjustment Vertical = io . scrolledWindowGetVAdjustment + + +-- | General scrolling command. +scroll' :: (MonadIO m) => Axis -> Position -> ScrolledWindow -> m () +scroll' axis percentage scrollWindow = io $ do + adj <- io . getAdjustment axis $ scrollWindow + page <- io $ adjustmentGetPageSize adj + current <- io $ adjustmentGetValue adj + lower <- io $ adjustmentGetLower adj + upper <- io $ 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) + + io $ adjustmentSetValue adj $ limit (shift percentage) + +scroll :: (MonadIO m, MonadReader r m, HasScrollWindow r) => Axis -> Position -> m () +scroll axis percentage = scroll' axis percentage =<< asks _scrollwindow diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE DoRec #-} -module Hbro.Gui ( - getObject, - initGUI, - showWebInspector, - toggleVisibility -) where +{-# LANGUAGE DoRec, FlexibleContexts, FlexibleInstances #-} +module Hbro.Gui where -- {{{ Imports -import Hbro.Core +--import Hbro.Core import Hbro.Util import qualified Hbro.Prompt as Prompt import Hbro.Types +import Hbro.Webkit.WebView +import Control.Conditional import Control.Monad hiding(forM_, mapM_) +import Control.Monad.IO.Class +import Control.Monad.Reader --import Data.Foldable -import Data.IORef +import Data.Functor import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container @@ -28,13 +27,11 @@ import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebInspector -import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView hiding(webViewLoadUri) import Graphics.UI.Gtk.Windows.Window import Prelude hiding(mapM_) -import System.Console.CmdArgs (whenNormal) import System.Glib.Attributes import System.Glib.Signals import System.Glib.Types @@ -42,92 +39,81 @@ -- 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 +getObject :: (MonadIO m, MonadReader r m, HasGUI r, GObjectClass a) => (GObject -> a) -> String -> m a +getObject cast name = do + builder <- asks _builder + io $ builderGetObject builder cast name -initGUI :: (RefDirs -> FilePath) -> [AttrOp WebSettings] -> IO GUI -initGUI xmlPath settings = do - void GTK.initGUI +build' :: (MonadIO m, MonadReader r m, HasConfig r) => m GUI +build' = do + xmlPath <- asks _UIFile + io $ void GTK.initGUI -- Load XML - xmlPath' <- resolve xmlPath - whenNormal . putStr . ("Loading GUI from " ++) . (++ "... ") $ xmlPath' - builder <- builderNew - builderAddFromFile builder xmlPath' --- Initialize components - (webView, sWindow) <- initWebView builder settings - (window, wBox) <- initWindow builder webView - promptBar <- Prompt.init builder - statusBar <- initStatusBar builder - notificationBar <- initNotificationBar builder + xmlPath' <- io xmlPath + logNormal $ "Loading GUI from " ++ xmlPath' ++ "... " + builder <- io builderNew + io $ builderAddFromFile builder xmlPath' +-- Build components + (webView, sWindow) <- build builder + (window, wBox) <- build builder + promptBar <- build builder + statusBar <- build builder + notificationBar <- build builder inspectorWindow <- initWebInspector webView wBox -- Show window - widgetShowAll window - widgetHide (mBox promptBar) - - whenNormal $ putStrLn "Done." - return $ GUI { - mWindow = window, - mInspectorWindow = inspectorWindow, - mScrollWindow = sWindow, - mWebView = webView, - mPromptBar = promptBar, - mStatusBar = statusBar, - mNotificationBar = notificationBar, - mBuilder = builder + io $ widgetShowAll window + io $ widgetHide (_box promptBar) + + logNormal "Done." + return $ GUI { + __mainWindow = window, + __inspectorWindow = inspectorWindow, + __scrollWindow = sWindow, + __webView = webView, + __promptBar = promptBar, + __statusBar = statusBar, + __notificationBar = notificationBar, + __builder = builder } -initWebView :: Builder -> [AttrOp WebSettings] -> IO (WebView, ScrolledWindow) -initWebView builder settings = do --- 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 --- - _ <- on webView closeWebView $ GTK.mainQuit >> return False - - return (webView, window) +setupScrollWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m () +setupScrollWindow = do + window <- asks _scrollWindow + io $ scrolledWindowSetPolicy window PolicyNever PolicyNever -initWindow :: Builder -> WebView -> IO (Window, VBox) -initWindow builder webView = do - window <- builderGetObject builder castToWindow "mainWindow" - windowSetDefault window $ Just webView - windowSetDefaultSize window 800 600 - widgetModifyBg window StateNormal (Color 0 0 10000) - _ <- onDestroy window GTK.mainQuit - - box <- builderGetObject builder castToVBox "windowBox" - - return (window, box) - -initStatusBar :: Builder -> IO HBox -initStatusBar builder = builderGetObject builder castToHBox "statusBox" +instance Buildable (Window, VBox) where + build builder = io $ do + window <- builderGetObject builder castToWindow "mainWindow" + box <- builderGetObject builder castToVBox "windowBox" + return (window, box) -initNotificationBar :: Builder -> IO NotificationBar -initNotificationBar builder = do - label <- builderGetObject builder castToLabel "notificationLabel" - timer <- newIORef Nothing - return $ NotificationBar label timer +setupWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m () +setupWindow = do + window <- asks _mainWindow + io . windowSetDefault window . Just =<< asks _webView + io $ windowSetDefaultSize window 800 600 + io $ widgetModifyBg window StateNormal (Color 0 0 10000) + io . void $ onDestroy window GTK.mainQuit +instance Buildable StatusBar where + build builder = io $ StatusBar <$> builderGetObject builder castToHBox "statusBox" + +instance Buildable NotificationBar where + build builder = io $ NotificationBar <$> builderGetObject builder castToLabel "notificationLabel" + -- {{{ Web inspector -initWebInspector :: WebView -> VBox -> IO (Window) +initWebInspector :: (MonadIO m) => WebView -> VBox -> m (Window) initWebInspector webView windowBox = do - inspector <- webViewGetInspector webView - inspectorWindow <- windowNew - set inspectorWindow [ windowTitle := "hbro | Web inspector" ] + inspector <- io $ webViewGetInspector webView + inspectorWindow <- io windowNew + io $ set inspectorWindow [ windowTitle := "hbro | Web inspector" ] - _ <- on inspector inspectWebView $ \_ -> do + _ <- io $ on inspector inspectWebView $ \_ -> do view <- webViewNew containerAdd inspectorWindow view return view - _ <- on inspector showWindow $ do + _ <- io $ on inspector showWindow $ do widgetShowAll inspectorWindow return True @@ -135,9 +121,9 @@ --_ <- on inspector finished $ return () -- Attach inspector to browser's main window - _ <- on inspector attachWindow $ do - getWebView <- webInspectorGetWebView inspector - case getWebView of + _ <- io $ on inspector attachWindow $ do + webview <- webInspectorGetWebView inspector + case webview of Just view -> do widgetHide inspectorWindow containerRemove inspectorWindow view @@ -148,9 +134,9 @@ _ -> return False -- Detach inspector in a distinct window - _ <- on inspector detachWindow $ do - getWebView <- webInspectorGetWebView inspector - _ <- case getWebView of + _ <- io $ on inspector detachWindow $ do + webview <- webInspectorGetWebView inspector + _ <- case webview of Just view -> do containerRemove windowBox view containerAdd inspectorWindow view @@ -162,21 +148,12 @@ return True return inspectorWindow - --- | Show web inspector for current webpage. -showWebInspector :: K () -showWebInspector = do - inspector <- with (mWebView . mGUI) webViewGetInspector - io $ webInspectorInspectCoordinates inspector 0 0 -- }}} - -- {{{ Util -- | Toggle a widget's visibility (provided for convenience). -toggleVisibility :: WidgetClass a => a -> IO () -toggleVisibility widget = do +toggleVisibility :: (MonadIO m, WidgetClass a) => a -> m () +toggleVisibility widget = io $ do visibility <- get widget widgetVisible - case visibility of - False -> widgetShow widget - _ -> widgetHide widget + visibility ? widgetHide widget ?? widgetShow widget -- }}} diff --git a/Hbro/Hbro.hs b/Hbro/Hbro.hs deleted file mode 100644 --- a/Hbro/Hbro.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DoRec #-} -module Hbro.Hbro where - --- {{{ Imports ---import Hbro.Config -import Hbro.Core -import Hbro.Gui -import Hbro.Keys -import qualified Hbro.Prompt as Prompt -import qualified Hbro.Socket as Socket -import Hbro.Types -import Hbro.Util - ---import Control.Concurrent -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.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.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.FilePath -import System.Glib.Signals ---import System.Posix.Process -import qualified System.ZMQ as ZMQ --- }}} - - --- At this point, the reconfiguration process is done -main :: (Config', CliOptions) -> IO () -main (Left e, _) = putStrLn e -main (Right config, options) = do --- Initialize GUI, state and IPC socket - gui <- initGUI (mUIFile config) (mWebSettings config) - state <- newIORef (M.empty :: M.Map String Dynamic) - - ZMQ.withContext 1 $ \context -> main' (Environment state options config gui context) - whenNormal . putStrLn $ "Exiting..." - -main' :: Environment -> IO () -main' 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) - - void $ after webView keyPressEvent (onKeyPressed environment) - void $ on entry keyPressEvent (onPromptKeyPress environment) - void $ on entry editableChanged (onPromptChanged environment) - --- Set start-up page - startURI <- case (mURI options) of - Just uri -> do - fileURI <- doesFileExist uri - case fileURI of - True -> getCurrentDirectory >>= \dir -> return $ parseURIReference ("file://" ++ dir uri) - _ -> return $ parseURIReference uri - _ -> return Nothing - - runK environment $ do - Socket.open - - -- Custom start-up - mStartUp . mHooks $ config - -- Load home page - maybe goHome loadURI startURI - -- Main loop - io mainGUI - - Socket.close --- }}} - --- {{{ Hooks -onDownload :: Environment -> Download -> IO Bool -onDownload environment download = do - uri <- fmap (>>= parseURI) . downloadGetUri $ download - filename <- downloadGetSuggestedFilename download - size <- downloadGetTotalSize download - - case (uri, filename) of - (Just uri', Just filename') -> do - logVerbose . ("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 <$> eventKeyVal - - io . forM_ key' $ \key -> do - let keystrokes = (++ key) . concat . map stringify $ modifiers - logVerbose $ "Key pressed: " ++ keystrokes - 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 - logVerbose $ "Title changed: " ++ title - runK env $ (mTitleChanged . mHooks . mConfig $ env) title --- }}} diff --git a/Hbro/Keys.hs b/Hbro/Keys.hs --- a/Hbro/Keys.hs +++ b/Hbro/Keys.hs @@ -1,28 +1,23 @@ -{-# LANGUAGE DoRec #-} -module Hbro.Keys ( --- * Other - defaultKeyHandler, - emacsKeyHandler, --- * Util - stringify, - keyToString, -) where +{-# LANGUAGE DoRec, FlexibleContexts, RankNTypes #-} +module Hbro.Keys where -- {{{ Imports -import Hbro.Core import Hbro.Types import Hbro.Util import Control.Monad hiding(forM_) ---import Control.Monad.Trans +import Control.Monad.Error hiding(forM_) +--import Control.Monad.IO.Class +import Control.Monad.Reader hiding(forM_) +import Control.Monad.Trans.Control --import Data.Foldable +import Data.Functor 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 Prelude hiding(mapM_) @@ -31,31 +26,6 @@ --import System.Glib.Signals -- }}} --- | Look for a callback associated to the given keystrokes and trigger it, if any. -defaultKeyHandler :: KeysList -> String -> K (String, Bool) -defaultKeyHandler keysList keystrokes = case M.lookup keystrokes (M.fromList keysList) of - Just callback -> callback >> return (keystrokes, True) - _ -> return (keystrokes, False) - --- | Emacs-like key handler. -emacsKeyHandler :: KeysList -- ^ Key bindings - -> [String] -- ^ List of prefix keys - -> String - -> K (String, Bool) -emacsKeyHandler keysList prefixes keystrokes = do - keysRef <- getState "Hbro.Keys.manageSequentialKeys" "" - io $ modifyIORef keysRef (++ keystrokes) - chainedKeys <- io $ readIORef keysRef - - case elem chainedKeys prefixes of - True -> do - io $ modifyIORef keysRef (++ " ") - return (chainedKeys ++ " ", False) - _ -> do - io $ writeIORef keysRef [] - defaultKeyHandler keysList chainedKeys - - -- | 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. @@ -80,12 +50,32 @@ "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 _ = [] + + +-- | Look for a callback associated to the given keystrokes and trigger it, if any. +defaultKeyHandler :: KeysList -> KeyHook +defaultKeyHandler (KeysList keysList) keystrokes = case M.lookup keystrokes (M.fromList keysList) of + Just callback -> callback + _ -> return () + +-- | Emacs-like key handler. +emacsKeyHandler :: (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, HasKeys r, MonadError HError m, MonadBaseControl IO m) + => KeysList -- ^ Key bindings + -> [String] -- ^ List of prefix keys + -> String + -> m () +emacsKeyHandler keysList prefixes keystrokes = do + keys <- asks _keys + chainedKeys <- (++ keystrokes) <$> io (readIORef keys) + + case elem chainedKeys prefixes of + True -> do + io $ writeIORef keys $ chainedKeys ++ " " + _ -> do + io $ writeIORef keys "" + defaultKeyHandler keysList chainedKeys + + -- | Convert key bindings list to a map. -- keysListToMap :: KeysList -> KeysMap diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -1,18 +1,13 @@ module Main where -- {{{ Imports -import Hbro.Boot -import Hbro.Config -import Hbro.Types +import Hbro +import Data.Default + import Paths_hbro -- }}} -- | Default main function provided as example. main :: IO () -main = do - uiFile <- getDataFileName "examples/ui.xml" - - hbro $ defaultConfig { - mUIFile = const uiFile - } +main = hbro (def { __UIFile = getDataFileName "examples/ui.xml" }) def diff --git a/Hbro/Prompt.hs b/Hbro/Prompt.hs --- a/Hbro/Prompt.hs +++ b/Hbro/Prompt.hs @@ -1,12 +1,19 @@ +{-# LANGUAGE FlexibleContexts, RankNTypes #-} +-- | Designed to be imported as @qualified@. module Hbro.Prompt where -- {{{ Imports -import Hbro.Core +--import Hbro.Core import Hbro.Types import Hbro.Util +import Hbro.Gtk.Entry +import Control.Conditional hiding(when) import Control.Monad hiding(forM_, mapM_) ---import Control.Monad.Trans +import Control.Monad.Error hiding(forM_, mapM_, when) +--import Control.Monad.IO.Class +import Control.Monad.Reader hiding(forM_, mapM_, when) +import Control.Monad.Trans.Control import Data.Foldable import Data.IORef @@ -17,77 +24,113 @@ import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Editable import Graphics.UI.Gtk.Entry.Entry +import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox -import Network.URI +import Network.URI hiding(parseURIReference) import Prelude hiding(mapM_) + +import System.Glib.Signals -- }}} -init :: Builder -> IO PromptBar -init builder = do - label <- builderGetObject builder castToLabel "promptDescription" - labelSetAttributes label [allItalic, allBold] +instance Buildable PromptBar where + build builder = io $ do + label <- builderGetObject builder castToLabel "promptDescription" + entry <- builderGetObject builder castToEntry "promptEntry" + box <- builderGetObject builder castToHBox "promptBox" - 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 + return $ PromptBar box label entry -open :: String -> String -> K () -open newDescription defaultText = with (mPromptBar . mGUI) $ \(PromptBar promptBox description entry _ _) -> do +setup :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasPromptBar r, HasHooks r, HasWebView r, MonadError HError m) => m () +setup = do + label <- asks _promptDescription + io $ labelSetAttributes label [allItalic, allBold] + io $ labelSetAttributes label [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}] + + entry <- asks _promptEntry + io $ widgetModifyBase entry StateNormal $ Color 0 0 0 + io $ widgetModifyText entry StateNormal $ Color 32767 32767 32767 + +-- Validate/cancel prompt + webView <- asks _webview + io . void . on entry keyPressEvent $ do + key <- eventKeyName + when (key == "Return" || key == "Escape") $ io $ do + --runInIO clean + widgetGrabFocus webView + return () + return False + return () + + +open :: (MonadIO m, MonadReader r m, HasPromptBar r) => String -> String -> m () +open newDescription defaultText = do logVerbose "Opening prompt." - labelSetText description newDescription - entrySetText entry defaultText - - widgetShow promptBox - widgetGrabFocus entry - editableSetPosition entry (-1) + entry <- asks _promptEntry + io . (`labelSetText` newDescription) =<< asks _promptDescription + io $ entrySetText entry defaultText + io . widgetShow =<< asks _promptBox + io $ widgetGrabFocus entry + io $ 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 ()) - - +clean :: (MonadIO m, MonadReader r m, HasHooks r, HasPromptBar r, MonadBaseControl IO m) => m () +clean = do + entry <- asks _promptEntry + io $ widgetRestoreText entry StateNormal + io $ widgetModifyText entry StateNormal $ Color 32767 32767 32767 + io . widgetHide =<< asks _promptBox + + asks _promptChanged >>= \ref -> io $ readIORef ref >>= mapM_ signalDisconnect >> writeIORef ref Nothing + asks _promptValidated >>= \ref -> io $ readIORef ref >>= mapM_ signalDisconnect >> writeIORef ref Nothing + -- | 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 :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasPromptBar r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) + => String -- ^ Prompt description + -> String -- ^ Initial value + -> EntryHook -- ^ Function to trigger when validating prompt value + -> m () read = read' False --- | Same as 'prompt', but callback is triggered for each change in prompt's entry. -incrementalRead, iread :: String -> String -> (String -> K ()) -> K () +-- | Same as 'read', but callback is triggered for each change in prompt's entry. +incrementalRead, iread :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m) => String -> String -> EntryHook -> m () incrementalRead = read' True -- | Alias for incrementalRead. iread = incrementalRead -read' :: Bool -> String -> String -> (String -> K ()) -> K () -read' incremental description startValue callback = do +read' :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m) => Bool -> String -> String -> EntryHook -> m () +read' incremental description startValue f = do + clean open description startValue - with (mPromptBar . mGUI) $ \promptBar -> case incremental of - True -> writeIORef (mIncrementalCallbackRef promptBar) callback - _ -> writeIORef (mCallbackRef promptBar) callback + (PromptBar { _entry = entry }) <- asks _promptBar --- | Same as "read" for URI values -readURI :: String -> String -> (URI -> K ()) -> K () -readURI description startValue callback = withK (mPromptBar . mGUI) $ \promptBar -> do + when incremental $ onEntryChanged entry f >>= \i -> asks _promptChanged >>= io . (`writeIORef` Just i) + onEntryValidated entry (f >=> const clean) >>= \i -> asks _promptValidated >>= io . (`writeIORef` Just i) + return () + + +-- | Same as 'read' for URI values +readURI :: (MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadBaseControl IO m, MonadIO m, MonadError HError m) + => String -> String -> EntryURIHook -> m () +readURI description startValue callback = do + clean open description startValue checkURI startValue - - io . writeIORef (mIncrementalCallbackRef promptBar) $ checkURI - io . writeIORef (mCallbackRef promptBar) $ mapM_ callback . parseURIReference + + (PromptBar { _entry = entry }) <- asks _promptBar + id1 <- onEntryChanged entry $ checkURI + id2 <- onEntryValidated entry $ parseURIReference >=> callback >=> const clean + asks _promptChanged >>= io . (`writeIORef` Just id1) + asks _promptValidated >>= io . (`writeIORef` Just id2) + return () where - checkURI value = with (mEntry . mPromptBar . mGUI) $ \entry -> do - widgetModifyText entry StateNormal color + checkURI :: EntryHook + checkURI value = do + (PromptBar { _entry = entry }) <- asks _promptBar + io $ widgetModifyText entry StateNormal color where - color = case isURIReference value of - True -> Color 0 65535 0 - _ -> Color 65535 0 0 + color = (isURIReference value) ? green ?? red + green = Color 0 65535 0 + red = Color 65535 0 0 diff --git a/Hbro/Socket.hs b/Hbro/Socket.hs --- a/Hbro/Socket.hs +++ b/Hbro/Socket.hs @@ -1,88 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Designed to be imported as @qualified@. module Hbro.Socket where - + -- {{{ Imports -import Hbro.Core hiding(getURI) +-- import Hbro.Core import Hbro.Util import Hbro.Types -import Control.Concurrent import Control.Monad hiding(mapM_) +import Control.Monad.Error hiding(mapM_) +-- import Control.Monad.IO.Class +import Control.Monad.Reader hiding(mapM_) +import Control.Monad.Trans.Control import Data.ByteString.Char8 (pack, unpack) --import Data.Foldable +import Data.Functor import qualified Data.Map as M -import Prelude hiding(log, mapM_) +import Graphics.UI.Gtk.General.General +import Prelude hiding(log, mapM_, read) + import System.FilePath import System.Posix.Process import System.Posix.Types -import System.ZMQ +import qualified System.ZMQ as ZMQ -- }}} - --- | Open a response-socket at configured location, named hbro., and start listening for commands -open :: K () + +-- | Open a response-socket at configured location, named hbro., and start listening for commands. +open :: (MonadBaseControl IO m, MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => m () 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 - logNormal $ "Opening socket at " ++ socketURI - mapK2 (withSocket context Rep) $ \sock -> do - io $ bind sock socketURI - readCommands sock + socketDir <- asks _socketDir + path <- socketPath pid <$> io socketDir + socket <- io . (`ZMQ.socket` ZMQ.Rep) =<< asks _ZMQContext + logNormal $ "Opening socket at " ++ path + io $ ZMQ.bind socket path + readCommands socket + io $ ZMQ.close socket + return () -- | Close the response socket by sending it the command "QUIT". --- Typically called when exiting application. -close :: K () -close = getURI >>= \uri -> do - logVerbose . ("Closing socket " ++) . (++ " ...") $ uri - void . (`sendCommand` "QUIT") $ uri - +-- Typically called when exiting application. +close :: (Functor m, MonadIO m, MonadReader r m, HasConfig r, HasZMQContext r) => m () +close = do + uri <- getPath + logVerbose $ "Closing socket " ++ show uri ++ "..." + void $ sendCommand uri "QUIT" -- | Listen for incoming requests from response socket. -- Parse received commands and feed the corresponding callback, if any. -readCommands :: Socket Rep -> K () -readCommands sock = do - message <- io $ unpack `fmap` receive sock [] +readCommands :: (Functor m, MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => ZMQ.Socket ZMQ.Rep -> m () +readCommands socket = do + message <- read socket + logVerbose $ "Received command: " ++ message case words message of -- Empty command - [] -> io $ send sock (pack "ERROR Unknown command") [] + [] -> send socket "ERROR Unknown command" -- Exit command - ["QUIT"] -> io $ do - logVerbose "Receiving QUIT command" - send sock (pack "OK") [] + ["QUIT"] -> send socket "OK" -- Valid command - command:arguments -> withK (M.fromList . mCommands . mConfig) $ \commands -> do - logVerbose . ("Receiving command: " ++) $ message - case M.lookup command commands of - Just callback -> callback arguments >>= io . (send'' sock) . pack - _ -> io $ send sock (pack "ERROR Unknown command") [] + command:arguments -> do + (CommandsList commands) <- asks _commands + case M.lookup command (M.fromList commands) of + Just callback -> (postGUISync' (callback arguments) >>= send socket) `catchError` (\_ -> send socket "ERROR") + _ -> send socket "ERROR Unknown command" - readCommands sock - -getURI :: K String -getURI = with (mSocketDir . mConfig) $ \dir -> do - dir' <- resolve dir - (`socketFile` dir') `fmap` getProcessID - + readCommands socket + +postGUISync' :: (MonadBaseControl IO m) => m a -> m a +postGUISync' f = control $ \runInIO -> postGUISync (runInIO f) + +-- | Return socket URI used for the current process. +getPath :: (Functor m, MonadIO m, MonadReader r m, HasConfig r) => m String +getPath = do + dir <- asks _socketDir + pid <- io getProcessID + socketPath pid <$> io dir + -- | Return the socket path to use for the given browser's process ID. -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 :: 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 [] - +socketPath :: ProcessID -> FilePath -> String +socketPath pid socketDir = "ipc://" ++ socketDir "hbro." ++ show pid + +-- | +send :: (MonadIO m) => ZMQ.Socket a -> String -> m () +send socket payload = io $ ZMQ.send socket (pack payload) [] + +read :: (MonadIO m) => ZMQ.Socket a -> m String +read socket = io $ unpack <$> ZMQ.receive socket [] + +-- | Send a single command (through a Request socket) to the given Response socket, and return the answer. +sendCommand :: (MonadIO m, MonadReader r m, HasZMQContext r) => String -> String -> m String +sendCommand socketURI command = do + context <- asks _ZMQContext + io $ ZMQ.withSocket context ZMQ.Req $ \socket -> do + ZMQ.connect socket socketURI + send socket command + read socket + -- | Same as 'sendCommand', but for all running instances of the browser. -sendCommandToAll :: String -> K [String] -sendCommandToAll command = withK (mSocketDir . mConfig) $ \dir -> do - dir' <- io $ resolve dir - (io getAllProcessIDs) >>= mapM ((`sendCommand` command) . (`socketFile` dir')) +sendCommandToAll :: (MonadIO m, MonadReader r m, HasConfig r, HasZMQContext r) => String -> m [String] +sendCommandToAll command = do + dir <- asks _socketDir + dir' <- io dir + (io getAllProcessIDs) >>= mapM ((`sendCommand` command) . (`socketPath` dir')) diff --git a/Hbro/Types.hs b/Hbro/Types.hs --- a/Hbro/Types.hs +++ b/Hbro/Types.hs @@ -1,16 +1,21 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, RankNTypes, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} module Hbro.Types where -- {{{ Imports +-- import Control.Applicative +import Control.Monad.Error import Control.Monad.Reader +import Control.Monad.Trans.Control import Data.Dynamic import Data.IORef import Data.Map +import Data.Maybe +import Data.Monoid --import Data.Set +import Graphics.UI.Gtk.Abstract.Object +import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Entry @@ -18,132 +23,322 @@ import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow +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.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.Windows.Window import Network.URI import System.Console.CmdArgs -import System.Glib.Attributes hiding(get) ---import System.Glib.Signals -import System.ZMQ +import System.Glib.GObject +import System.Glib.Signals +import System.IO.Error +import qualified System.ZMQ as ZMQ -- }}} --- | Base type for high-level actions, mnemonics: K(it) from WebKit -type K = KT IO +-- {{{ Error +data HError = + CannotGoBack + | CannotGoForward + | EmptyCallback + | EmptyDownloadURI Download + | EmptyRequestURI NetworkRequest + | EmptySuggestedFileName Download + | InvalidIconURI + | InvalidPageTitle + | InvalidPageURI + | InvalidURI String + | IOE IOError + | OtherError String -newtype KT m a = KT (ReaderT Environment m a) - deriving (Functor, Monad, MonadFix, MonadIO, MonadReader Environment, MonadTrans) +instance Error HError where + strMsg = OtherError --- | The whole set of parameters, elements and states of the application -data Environment = Environment { - mState :: IORef (Map String Dynamic), -- ^ - mOptions :: CliOptions, -- ^ Commandline options - mConfig :: Config, -- ^ Custom configuration provided by user - mGUI :: GUI, -- ^ Graphical widgets - mContext :: Context -- ^ ZeroMQ context +instance Show HError where + show CannotGoBack = "Unable to go back: already at oldest page." + show CannotGoForward = "Unable to go forward: already at newest page." + show (IOE e) = "IO error: " ++ ioeGetLocation e ++ ": " ++ fromMaybe "" (ioeGetFileName e) ++ " " ++ ioeGetErrorString e + show InvalidIconURI = "No favicon URI." + show InvalidPageTitle = "No page title." + show InvalidPageURI = "Invalid page URI." + show (InvalidURI s) = show s + show (EmptyDownloadURI _) = "Invalid download URI." + show (EmptySuggestedFileName _) = "No suggested name for this download." + show (EmptyRequestURI _) = "Invalid request URI." + show EmptyCallback = "No callback defined." + show (OtherError s) = show s +-- }}} + +data Context = Context { + __options :: CliOptions, -- ^ Commandline options + __config :: Config, -- ^ Custom configuration provided by user + __UI :: GUI, + __ZMQContext :: ZMQ.Context, + __hooks :: Hooks, + __keys :: IORef String } --- | Set of commandline options +-- {{{ Commandline options +-- | Available commandline options (cf hbro -h). data CliOptions = CliOptions { - 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 + __startURI :: Maybe String, + __vanilla :: Bool, + __recompile :: Bool, + __denyReconf :: Bool, + __forceReconf :: Bool, + __dyreDebug :: Bool, + __masterBinary :: Maybe String } deriving (Data, Typeable, Show, Eq) --- | 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 - mWebSettings :: [AttrOp WebSettings], -- ^ WebSettings' attributes to use with webkit (see Webkit.WebSettings documentation) --- 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 +class HasOptions m where + _startURI :: m -> Maybe String + _vanilla :: m -> Bool + _recompile :: m -> Bool +instance HasOptions CliOptions where + _startURI = __startURI + _vanilla = __vanilla + _recompile = __recompile --- | 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 +instance HasOptions Context where + _startURI = __startURI . __options + _vanilla = __vanilla . __options + _recompile = __recompile . __options +-- }}} + +-- {{{ Configuration types +-- | Custom settings provided by the user. +data Config = Config { + __socketDir :: IO FilePath, -- ^ Directory where ZeroMQ sockets will be created ("/tmp" for example) + __UIFile :: IO FilePath, -- ^ Path to XML file describing UI (used by GtkBuilder) + __homePage :: URI, -- ^ Startup page + __commands :: CommandsList -- ^ Commands recognized through 0MQ sockets } --- | Graphical elements + +class HasConfig m where + _socketDir :: m -> IO FilePath + _UIFile :: m -> IO FilePath + _homePage :: m -> URI + _commands :: m -> CommandsList + +instance HasConfig Config where + _socketDir = __socketDir + _UIFile = __UIFile + _homePage = __homePage + _commands = __commands + +instance HasConfig Context where + _socketDir = __socketDir . __config + _UIFile = __UIFile . __config + _homePage = __homePage . __config + _commands = __commands . __config + + +class HasKeys m where + _keys :: m -> IORef String + +instance HasKeys Context where + _keys = __keys + +class HasZMQContext m where + _ZMQContext :: m -> ZMQ.Context + +instance HasZMQContext Context where + _ZMQContext = __ZMQContext +-- }}} + +-- {{{ UI types +-- | UI elements that can be built from GtkBuilder. +class Buildable a where + build :: Builder -> ((MonadIO m) => m a) + + data GUI = GUI { - mWindow :: Window, -- ^ Main 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 + __mainWindow :: Window, + __inspectorWindow :: Window, + __scrollWindow :: ScrolledWindow, -- ^ 'ScrolledWindow' containing the webview + __webView :: WebView, + __promptBar :: PromptBar, + __statusBar :: StatusBar, -- ^ Status bar's horizontal box + __notificationBar :: NotificationBar, + __builder :: Builder -- ^ Builder object created from XML file } --- | Prompt-bar elements +newtype StatusBar = StatusBar HBox + +instance GObjectClass StatusBar where + toGObject (StatusBar h) = toGObject h + unsafeCastGObject g = StatusBar $ unsafeCastGObject g + +instance ObjectClass StatusBar +instance WidgetClass StatusBar + +class HasGUI m where + _mainWindow :: m -> Window + _inspectorWindow :: m -> Window + _scrollWindow :: m -> ScrolledWindow + _webView :: m -> WebView + _promptBar :: m -> PromptBar + _statusBar :: m -> StatusBar + _notificationBar :: m -> NotificationBar + _builder :: m -> Builder + + +instance HasGUI GUI where + _mainWindow = __mainWindow + _inspectorWindow = __inspectorWindow + _scrollWindow = __scrollWindow + _webView = __webView + _promptBar = __promptBar + _statusBar = __statusBar + _notificationBar = __notificationBar + _builder = __builder + + +instance HasGUI Context where + _mainWindow = __mainWindow . __UI + _inspectorWindow = __inspectorWindow . __UI + _scrollWindow = __scrollWindow . __UI + _webView = __webView . __UI + _promptBar = __promptBar . __UI + _statusBar = __statusBar . __UI + _notificationBar = __notificationBar . __UI + _builder = __builder . __UI + + +class HasWebView m where + _webview :: m -> WebView + +instance (HasGUI m) => HasWebView m where + _webview = _webView + + +class HasScrollWindow m where + _scrollwindow :: m -> ScrolledWindow + +instance (HasGUI m) => HasScrollWindow m where + _scrollwindow = _scrollWindow + + data PromptBar = PromptBar { - mBox :: HBox, -- ^ Layout box - mDescription :: Label, -- ^ Description of current prompt - mEntry :: Entry, -- ^ Prompt entry - mCallbackRef :: IORef (String -> K ()), -- ^ - mIncrementalCallbackRef :: IORef (String -> K ()) -- ^ + _box :: HBox, + _description :: Label, + _entry :: Entry } --- | Notification-bar elements +class HasPromptBar m where + _promptBox :: m -> HBox + _promptDescription :: m -> Label + _promptEntry :: m -> Entry + +instance HasPromptBar PromptBar where + _promptBox = _box + _promptDescription = _description + _promptEntry = _entry + +instance HasPromptBar GUI where + _promptBox = _box . _promptBar + _promptDescription = _description . _promptBar + _promptEntry = _entry . _promptBar + +instance HasPromptBar Context where + _promptBox = _box . _promptBar . __UI + _promptDescription = _description . _promptBar . __UI + _promptEntry = _entry . _promptBar . __UI + + data NotificationBar = NotificationBar { - mLabel :: Label, -- ^ Content - mTimer :: IORef (Maybe HandlerId) -- ^ Timer handler + _label :: Label -- ^ Content } --- | 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 +class HasNotificationBar m where + _notificationbar :: m -> NotificationBar + +instance (HasGUI m) => HasNotificationBar m where + _notificationbar = _notificationBar +-- }}} + +-- {{{ Hooks +data Hooks = Hooks { + __notificationTimer :: IORef (Maybe HandlerId), + __promptChanged :: IORef (Maybe (ConnectId Entry)), + __promptValidated :: IORef (Maybe (ConnectId Entry)) } -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. +class HasHooks m where +-- _custom :: IORef (Map String Dynamic) + _notificationTimer :: m -> IORef (Maybe HandlerId) + _promptChanged :: m -> IORef (Maybe (ConnectId Entry)) + _promptValidated :: m -> IORef (Maybe (ConnectId Entry)) + +instance HasHooks (a, Hooks) where + _notificationTimer = __notificationTimer . snd + _promptChanged = __promptChanged . snd + _promptValidated = __promptValidated . snd + + +instance HasHooks Context where + _notificationTimer = __notificationTimer . __hooks + _promptChanged = __promptChanged . __hooks + _promptValidated = __promptValidated . __hooks + + +newtype Setup = Setup (forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, HasKeys r, MonadError HError m, MonadBaseControl IO m) => m ()) +type ClipboardHook = String -> (forall m. (MonadIO m, MonadError HError m, MonadBaseControl IO m) => m ()) +type EntryHook = String -> (forall r m. (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r) => m ()) +type EntryURIHook = URI -> (forall r m. (MonadIO m, MonadError HError m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r) => m ()) +newtype DownloadHook = DownloadHook (URI -> String -> Int -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m, MonadBaseControl IO m) => m ()) +type KeyHook = String -> forall r m. (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r, HasKeys r) => m () +newtype LoadFinishedHook = LoadFinishedHook (forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m, MonadBaseControl IO m) => m ()) +newtype NavigationHook = NavigationHook (NavigationReason -> Maybe MouseButton -> URI -> WebPolicyDecision -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ()) +newtype NewWebViewHook = NewWebViewHook (WebFrame -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m WebView) +newtype NewWindowHook = NewWindowHook (WebFrame -> NetworkRequest -> WebNavigationAction -> WebPolicyDecision -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ()) +newtype ResourceOpenedHook = ResourceOpenedHook (URI -> String -> WebPolicyDecision -> forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ()) +newtype TitleChangedHook = TitleChangedHook (String -> forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ()) +-- }}} + +-- {{{ Missing instances from webkit +instance Eq NavigationReason where + a == b = (fromEnum a) == (fromEnum b) + +instance Show NavigationReason where + show WebNavigationReasonLinkClicked = "Link clicked" + show WebNavigationReasonFormSubmitted = "Form submitted" + show WebNavigationReasonBackForward = "Back/forward" + show WebNavigationReasonReload = "Reload" + show WebNavigationReasonFormResubmitted = "Form resubmitted" + show WebNavigationReasonOther = "Other" +-- }}} + +-- {{{ Keys +-- Note: for modifiers, lists are used for convenience purposes, +-- but are transformed into sets internally, so that order and repetition don't matter. -- | 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 +-- All callbacks are fed with the Context instance. +newtype KeysList = KeysList (forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m, MonadBaseControl IO m) => [(String, m ())]) -type CommandsList = [(String, ([String] -> K String))] -type CommandsMap = Map String ([String] -> K String) +instance Monoid KeysList where + mempty = KeysList [] + mappend (KeysList a) (KeysList b) = KeysList (mappend a b) --- | -data Button = ButtonL | ButtonM | ButtonR +--type KeysMap = (MonadIO m, MonadReader Context m) => Map String (m ()) +--data KeyMode = CommandMode | InsertMode +-- }}} +newtype CommandsList = CommandsList ((Functor m, MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m) => [(String, ([String] -> m String))]) +type CommandsMap = (MonadIO m, MonadReader Context m) => Map String ([String] -> m String) + -- Boolean datatypes data CaseSensitivity = CaseSensitive | CaseInsensitive data Direction = Forward | Backward data Wrap = Wrap | NoWrap + +data Axis = Horizontal | Vertical +data Position = Absolute Double | Relative Double diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -1,91 +1,74 @@ -module Hbro.Util ( --- * General purpose - io, - logNormal, - logVerbose, - resolve, --- * Process management - spawn, - getAllProcessIDs, --- * Boolean data-types conversion - isCaseSensitive, - isForward, - isWrapped, --- * Common pango attributes - allItalic, - allBold, --- * Misc - send'', - labelSetMarkupTemporary, - dmenu, - errorHandler -) where +{-# LANGUAGE FlexibleContexts #-} +module Hbro.Util where -- {{{ Imports import Hbro.Types +import Control.Concurrent import Control.Exception ---import Control.Monad.Reader -import Control.Monad -import Control.Monad.IO.Class +import Control.Monad hiding(mapM_) +import Control.Monad.Error hiding(mapM_) +import Control.Monad.Reader hiding(mapM_) +--import Control.Monad.IO.Class +import Control.Monad.Trans.Control -import Data.ByteString (ByteString) ---import Data.IORef +import Data.Foldable +import Data.Functor +import Data.IORef import Data.List import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Display.Label +import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.General.General +import Graphics.UI.Gtk.WebKit.Download as W +import Graphics.UI.Gtk.WebKit.NetworkRequest as W -import Prelude hiding(log) +import Network.URI (URI) +import qualified Network.URI as N +import Prelude hiding(log, mapM_) + import System.Console.CmdArgs -import System.Directory -import System.Environment.XDG.BaseDir +import System.FilePath import qualified System.Info as Sys -import System.IO +-- import System.IO import System.IO.Error hiding(try) import System.Posix.Process import System.Posix.Types import System.Process -import System.ZMQ -- }}} - +-- | Alias for 'liftIO' io :: MonadIO m => IO a -> m a io = liftIO -send'' :: Socket a -> ByteString -> IO () -send'' x y = send x y [] +-- | Like 'forkIO' using 'MVar' as thread control +fork :: (MonadIO m, MonadBaseControl IO m) => m () -> m (MVar ()) +fork f = do + mvar <- io newEmptyMVar + void . liftBaseWith $ \runInIO -> forkIO $ finally (void $ runInIO f) (putMVar mvar ()) + return mvar +-- | Like '' with first argument in IO to build platform-dependent paths. +(>/>) :: (MonadIO m) => IO FilePath -> FilePath -> m FilePath +(>/>) a b = io $ ( b) <$> a + logNormal, logVerbose :: (MonadIO m) => String -> m () logNormal = io . whenNormal . putStrLn logVerbose = io . whenLoud . putStrLn --- | -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 () -spawn command options = spawn' (proc command options) - -spawn' :: CreateProcess -> IO () -spawn' command = createProcess command { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return () +spawn :: MonadIO m => String -> [String] -> m () +spawn command options = io . void $ createProcess (proc command options) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True } -- | Return the list of process IDs corresponding to all running instances of the browser. -getAllProcessIDs :: IO [ProcessID] -getAllProcessIDs = do - (_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] [] - (_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] - myPid <- getProcessID +getAllProcessIDs :: MonadIO m => m [ProcessID] +getAllProcessIDs = do + (_, pids, _) <- io $ readProcessWithExitCode "pidof" ["hbro"] [] + (_, pids', _) <- io $ readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] [] + myPid <- io $ getProcessID return $ delete myPid . map (read :: String -> ProcessID) . nub . words $ pids ++ " " ++ pids' -- }}} @@ -101,29 +84,29 @@ where clear = labelSetMarkup label "" --- | Open dmenu with given input and return selected entry. -dmenu :: [String] -- ^ dmenu's commandline options - -> String -- ^ dmenu's input - -> IO (Maybe String) -- ^ Selected entry -dmenu options input = do - (in_, out, err, pid) <- runInteractiveProcess "dmenu" options Nothing Nothing - hPutStr in_ input - hClose in_ - - output <- try $ hGetLine out :: IO (Either IOError String) - let output' = case output of - Left _ -> Nothing - Right x -> Just x - - hClose out >> hClose err >> (void $ waitForProcess pid) - return output' - errorHandler :: FilePath -> IOError -> IO () errorHandler file e = do 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 ++ ">.") + +parseURIReference :: (MonadError HError m) => String -> m URI +parseURIReference uri = maybe (throwError $ InvalidURI uri) return $ N.parseURIReference uri + +parseURI :: (MonadError HError m) => String -> m URI +parseURI uri = maybe (throwError $ InvalidURI uri) return $ N.parseURI uri + +networkRequestGetUri :: (MonadIO m, MonadError HError m) => NetworkRequest -> m URI +networkRequestGetUri r = parseURIReference =<< maybe (throwError $ EmptyRequestURI r) return =<< io (W.networkRequestGetUri r) + +downloadGetUri :: (MonadIO m, MonadError HError m) => W.Download -> m URI +downloadGetUri d = parseURI =<< maybe (throwError $ EmptyDownloadURI d) return =<< io (W.downloadGetUri d) + +downloadGetSuggestedFilename :: (MonadIO m, MonadError HError m) => W.Download -> m String +downloadGetSuggestedFilename d = maybe (throwError $ EmptySuggestedFileName d) return =<< io (W.downloadGetSuggestedFilename d) + + -- Boolean types conversion isCaseSensitive :: CaseSensitivity -> Bool isCaseSensitive CaseSensitive = True @@ -141,4 +124,24 @@ allItalic, allBold :: PangoAttribute allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic} allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold} - + + + +notify :: (Functor m, MonadIO m, MonadReader r m, HasNotificationBar r, HasHooks r, MonadError HError m) => Int -> String -> m () +notify duration text = do + label <- _label <$> asks _notificationbar + handler <- asks _notificationTimer + + io $ labelSetAttributes label [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}] + io $ labelSetMarkup label text + io $ mapM_ timeoutRemove =<< readIORef handler + + newID <- io $ timeoutAdd (labelSetMarkup label "" >> return False) duration + io $ writeIORef handler $ Just newID + +-- | Convert a Modifier to a String. +stringify :: Modifier -> String +stringify Control = "C-" +--stringify' Shift = "S-" +stringify Alt = "M-" +stringify _ = [] diff --git a/Hbro/Webkit/WebSettings.hs b/Hbro/Webkit/WebSettings.hs new file mode 100644 --- /dev/null +++ b/Hbro/Webkit/WebSettings.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Designed to be imported as @qualified@. +module Hbro.Webkit.WebSettings where + +-- {{{ Imports +--import Hbro.Core +import Hbro.Types +import Hbro.Util + +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Graphics.UI.Gtk.WebKit.WebSettings +import Graphics.UI.Gtk.WebKit.WebView + +import System.Glib.Attributes +--- }}} + + +modify :: (MonadIO m, MonadReader r m, HasWebView r) => Attr WebSettings a -> (a -> a) -> m a +modify element modifier = do + webView <- asks _webview + settings <- io $ webViewGetWebSettings webView + oldValue <- io $ get settings element + io $ set settings [element := modifier oldValue] + io $ webViewSetWebSettings webView settings + return oldValue + +toggle :: (MonadIO m, MonadReader r m, HasWebView r) => Attr WebSettings Bool -> m Bool +toggle = (`modify` not) diff --git a/Hbro/Webkit/WebView.hs b/Hbro/Webkit/WebView.hs new file mode 100644 --- /dev/null +++ b/Hbro/Webkit/WebView.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +-- | Rewrite many 'Graphics.UI.Gtk.WebKit.WebView' functions in a monadic way. +module Hbro.Webkit.WebView where + +-- {{{ Imports +import Hbro.Keys +import Hbro.Types +import Hbro.Util + +import Control.Conditional +import Control.Monad.Error hiding(forM_, mapM_) +import Control.Monad.Reader hiding(forM_, mapM_) +import Control.Monad.Trans.Control + +import Data.Default +import Data.Foldable (forM_, mapM_) +import Data.Functor + +import Graphics.UI.Gtk.Abstract.Container +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.Builder +import Graphics.UI.Gtk.Gdk.EventM +import qualified Graphics.UI.Gtk.General.General as GTK +import Graphics.UI.Gtk.Scrolling.ScrolledWindow +import qualified Graphics.UI.Gtk.WebKit.WebFrame as W +import qualified Graphics.UI.Gtk.WebKit.Download as W +import qualified Graphics.UI.Gtk.WebKit.NetworkRequest as W +import Graphics.UI.Gtk.WebKit.WebInspector +import Graphics.UI.Gtk.WebKit.WebNavigationAction +import Graphics.UI.Gtk.WebKit.WebPolicyDecision +import Graphics.UI.Gtk.WebKit.WebView (WebView, webViewNew) +import qualified Graphics.UI.Gtk.WebKit.WebView as W + +import Network.URI as N hiding(parseURI, parseURIReference) + +import Prelude hiding(mapM_) + +import System.Glib.Attributes +import System.Glib.Signals +-- }}} + +-- {{{ Init +instance Buildable (WebView, ScrolledWindow) where + build builder = io $ do + window <- builderGetObject builder castToScrolledWindow "webViewParent" + webView <- W.webViewNew + containerAdd window webView + + return (webView, window) + +setup :: (MonadIO m, MonadReader r m, HasWebView r) => m () +setup = do + webView <- asks _webview + io $ webView `set` [ widgetCanDefault := True ] + io . void . on webView W.closeWebView $ GTK.mainQuit >> return False + +-- }}} + +-- {{{ Monad-agnostic version of various WebKit functions +webViewGetUri :: (MonadIO m, MonadError HError m) => W.WebView -> m URI +webViewGetUri = maybe (throwError InvalidPageURI) parseURI <=< io . W.webViewGetUri + +webViewGetTitle :: (MonadIO m, MonadError HError m) => W.WebView -> m String +webViewGetTitle = maybe (throwError InvalidPageTitle) return <=< io . W.webViewGetTitle + +webViewGetIconUri :: (MonadIO m, MonadError HError m) => W.WebView -> m URI +webViewGetIconUri = maybe (throwError InvalidIconURI) parseURI <=< io . W.webViewGetUri +-- }}} + +-- {{{ Getters +getFaviconURI :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m URI +getFaviconURI = webViewGetIconUri =<< asks _webview + +getLoadProgress :: (MonadIO m, MonadReader r m, HasWebView r) => m Double +getLoadProgress = io . W.webViewGetProgress =<< asks _webview + +getURI :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m URI +getURI = webViewGetUri =<< asks _webview + +getTitle :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m String +getTitle = webViewGetTitle =<< asks _webview +-- }}} + +-- {{{ Browsing +loadURI :: (MonadIO m, MonadReader r m, HasWebView r) => URI -> m () +loadURI uri = do + logVerbose $ "Loading URI: " ++ (show uri') + io . (`W.webViewLoadUri` uri') =<< asks _webview + where + uri' = case uriScheme uri of + [] -> "http://" ++ show uri + _ -> show uri + +reload, reloadBypassCache :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m () +reload = io . W.webViewReload =<< asks _webview +reloadBypassCache = io . W.webViewReloadBypassCache =<< asks _webview + +stopLoading :: (MonadIO m, MonadReader r m, HasWebView r) => m () +stopLoading = io . W.webViewStopLoading =<< asks _webview +-- notify 5000 "Stopped loading" + +goBack, goForward :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m () +goBack = do + view <- asks _webview + unlessM (io $ W.webViewCanGoBack view) $ throwError CannotGoBack + io $ W.webViewGoBack view +goForward = do + view <- asks _webview + unlessM (io $ W.webViewCanGoForward view) $ throwError CannotGoForward + io $ W.webViewGoForward view +-- }}} + +-- {{{ Display +-- | Toggle source display. +-- Current implementation forces a refresh of current web page, which may be undesired. +toggleSourceMode :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m () +toggleSourceMode = do + view <- asks _webview + io . W.webViewSetViewSourceMode view =<< (io $ not <$> W.webViewGetViewSourceMode view) + reload + +zoomIn, zoomOut :: (MonadIO m, MonadReader r m, HasWebView r) => m () +zoomIn = io . W.webViewZoomIn =<< asks _webview +zoomOut = io . W.webViewZoomOut =<< asks _webview + +-- | Show web inspector for current webpage. +showWebInspector :: (MonadIO m, MonadReader r m, HasWebView r) => m () +showWebInspector = do + inspector <- io . W.webViewGetInspector =<< asks _webview + io $ webInspectorInspectCoordinates inspector 0 0 +-- }}} + +-- {{{ Hooks +afterKeyPressed :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m, HasKeys r) => KeyHook -> m (ConnectId WebView) +afterKeyPressed f = do + webView <- asks _webView + liftBaseWith $ \runInIO -> after webView keyPressEvent $ do + modifiers <- eventModifier + key' <- keyToString <$> eventKeyVal + + io . forM_ key' $ \key -> do + let keystrokes = (++ key) . concat . map stringify $ modifiers + logVerbose $ "Key pressed: " ++ keystrokes + runInIO $ f keystrokes `catchError` \e -> (io $ print e) >> notify 5000 (show e) + return False + +-- | Triggered in 2 cases: +-- 1/ Javascript window.open() +-- 2/ Context menu "Open in new window" +onNewWebView :: (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, HasKeys r, MonadError HError m) => NewWebViewHook -> m (ConnectId WebView) +onNewWebView (NewWebViewHook f) = do + webView <- asks _webView + env <- ask + io $ on webView W.createWebView $ \frame -> do + result <- runErrorT . (`runReaderT` env) $ f frame + case result of + Left e -> print e >> webViewNew + Right r -> return r + + +instance Default NewWebViewHook where + def = NewWebViewHook $ \_frame -> do + --forM_ uri $ (runK env) . callback + webView <- io webViewNew + + io . void . on webView W.webViewReady $ return True + io . void . on webView W.navigationPolicyDecisionRequested $ \_ request _ decision -> do + W.networkRequestGetUri request >>= mapM_ (\uri -> spawn "hbro" ["-u", uri]) + webPolicyDecisionIgnore decision + return True + + return webView + + +onDownload :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => DownloadHook -> m (ConnectId WebView) +onDownload (DownloadHook f) = do + webView <- asks _webView + liftBaseWith $ \runInIO -> on webView W.downloadRequested $ \download -> do + void . runInIO $ do + uri <- downloadGetUri download + filename <- downloadGetSuggestedFilename download + size <- io $ W.downloadGetTotalSize download + + logVerbose $ "Requested download: " ++ show uri + notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show size ++ ")" + f uri filename size + return False + + +onLoadFinished :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => LoadFinishedHook -> m (ConnectId WebView) +onLoadFinished (LoadFinishedHook f) = do + webView<- asks _webView + liftBaseWith $ \runInIO -> on webView W.loadFinished $ \_frame-> void . runInIO $ do + f `catchError` \e -> (io $ print e) >> notify 5000 (show e) + +onNavigationRequest :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => NavigationHook -> m (ConnectId WebView) +onNavigationRequest (NavigationHook f) = do + webView <- asks _webView + liftBaseWith $ \runInIO -> on webView W.navigationPolicyDecisionRequested $ \_frame request action decision -> do + void . runInIO $ do + uri <- networkRequestGetUri request + reason <- io $ webNavigationActionGetReason action + button <- io $ webNavigationActionGetButton action + + logVerbose $ "Requested navigation to <" ++ show uri ++ "> caused by " ++ show reason + f reason (toMouseButton button) uri decision + return True + where + toMouseButton 1 = Just LeftButton + toMouseButton 2 = Just MiddleButton + toMouseButton 3 = Just RightButton + toMouseButton _ = Nothing + + +onNewWindow :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => NewWindowHook -> m (ConnectId WebView) +onNewWindow (NewWindowHook f) = do + webView <- asks _webView + liftBaseWith $ \runInIO -> on webView W.newWindowPolicyDecisionRequested $ \frame request action decision -> do + void $ runInIO (f frame request action decision) + return True + + +onResourceOpened :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => ResourceOpenedHook -> m (ConnectId WebView) +onResourceOpened (ResourceOpenedHook f) = do + webView <- asks _webView + liftBaseWith $ \runInIO -> on webView W.mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> do + void . runInIO $ do + uri <- networkRequestGetUri request + f uri mimetype decision + return True + + +onTitleChanged :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => TitleChangedHook -> m (ConnectId WebView) +onTitleChanged (TitleChangedHook f) = do + webView <- asks _webView + liftBaseWith $ \runInIO -> on webView W.titleChanged $ \_frame title -> void . runInIO $ do + logVerbose $ "Title changed to: " ++ title + f title +-- }}} + +-- | Wrapper around 'webViewSearchText', provided for convenience +searchText :: (MonadIO m, MonadReader r m, HasWebView r) => CaseSensitivity -> Direction -> Wrap -> String -> m Bool +searchText s d w text = do + view <- asks _webview + io $ W.webViewSearchText view text (isCaseSensitive s) (isForward d) (isWrapped w) + +searchText_ :: (MonadIO m, MonadReader r m, HasWebView r) => CaseSensitivity -> Direction -> Wrap -> String -> m () +searchText_ s d w text = searchText s d w text >> return () + +-- | Wrapper around 'webFramePrint' function, provided for convenience. +printPage :: (MonadIO m, MonadReader r m, HasWebView r) => m () +printPage = io . W.webFramePrint =<< io . W.webViewGetMainFrame =<< asks _webview 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 for linux written and configured in Haskell, still in development but pretty usable. +**In a nutshell**: *hbro* is a minimal KISS compliant browser for linux written, configured and extensible in Haskell. Informations about versions, dependencies, source repositories and contacts can be found in hackage_. @@ -11,23 +11,17 @@ Design principles ----------------- -Do only one thing... - Modern browsers include many features that could be easily externalized ; actually, life would even be easier if those features were independent and shared with all desktop applications. Such features are for instance tabs, bookmarks, history, downloads, adblocking, passwords saving, self-updating. A UNIX-compliant browser should just be flexible enough to call external tools for such jobs. - -... but do it well - Browsing well first implies making our way through the mess of web standards that are growing harder and sloppier; sometimes it means breaking some other golden rules, but there's no choice. - -Keep It Simple, Stupid - Simplicity is not only compatible with but also essential to a powerful application. It often comes together with lightweight, scalable and easy-to-hack qualities. +`Do one thing well`_ + Browsing is about retrieving, presenting and traversing web resources. Not about providing tabs, bookmarks, history, download management, adblocking, passwords saving, self-updating, ... There already exists standalone applications for most extra features one may think of, please reuse them. Hbro can be configured to call external programs for any task. -Robustness & stability - Let's spend our time in developing new features rather than in tracking rare bugs. Let's go slow but sure. +`Keep It Simple, Stupid`_ + Hbro is written with simplicity in mind, and without an obsession for performance, features or release frequency. It may not be the fastest browser, at least it starts-up almost instantly, doesn't consume all your RAM and doesn't crash. Simplicity makes *hbro* lightweight, scalable, stable, easy to maintain and hack. Its code is easy to understand to encourage users to hack it. -Extensibility and programmable interface - Targets are advanced users who have various expectations ; to be sure everyone is happy, configuration should use a programming language, and an interprocess interface should be available. As he who can do the most can do the least, the default configuration should be suitable for users that cannot afford/don't want to spend (waste ?) their time in tweaks. +Extensible + Targets are advanced users who have various expectations ; to be sure everyone is happy, hbro is configured using a programming language, and offers an interprocess interface. As he who can do the most can do the least, the default configuration should be suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks. Keyboard driven - Special attention should be given to allow keyboard control of the browser whenever possible ; however, this should not become an obsession in cases where mouse use is obviously a more convenient solution (yes, such cases do exist). + Special attention is given to allow keyboard control of the browser whenever possible and not in conflict with another design principle. Free software Hbro is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name :) . @@ -54,7 +48,7 @@ Dynamic reconfiguration library for haskell programs. -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 :) . +Suggestions about better alternatives for any of these points (except the programming language) are more than welcome :) . Configuration @@ -85,6 +79,8 @@ .. _hackage: http://hackage.haskell.org/package/hbro +.. _Do one thing well: http://en.wikipedia.org/wiki/Unix_philosophy +.. _Keep It Simple, Stupid: https://en.wikipedia.org/wiki/KISS_principle .. _suckless manifest: http://suckless.org/manifest/ .. _Do-What-The-Fuck-You-Want-To public licence: http://en.wikipedia.org/wiki/WTFPL .. _Haskell: http://haskell.org/ diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,13 +1,13 @@ Name: hbro -Version: 0.9.1.0 +Version: 1.0.0.0 Synopsis: Minimal KISS compliant browser --- Description: +-- Description: Homepage: http://projects.haskell.org/hbro/ Category: Browser,Web License: OtherLicense License-file: LICENSE --- Copyright: +-- Copyright: Author: koral Maintainer: koral at mailoo dot org @@ -28,12 +28,15 @@ base == 4.*, bytestring, cmdargs, + cond, containers, + data-default, directory, dyre, filepath, glib, gtk >= 0.12.3, + monad-control, mtl, network, pango, @@ -44,16 +47,21 @@ xdg-basedir, zeromq-haskell Exposed-modules: + Hbro, Hbro.Boot, - Hbro.Config, + Hbro.Default, + Hbro.Clipboard, Hbro.Core, Hbro.Gui, - Hbro.Hbro, Hbro.Keys, Hbro.Prompt, Hbro.Socket, Hbro.Types, - Hbro.Util + Hbro.Util, + Hbro.Gtk.Entry, + Hbro.Gtk.ScrolledWindow, + Hbro.Webkit.WebSettings, + Hbro.Webkit.WebView Ghc-options: -Wall Flag threaded @@ -61,14 +69,16 @@ Default: True Executable hbro - Build-depends: + Build-depends: hbro, base == 4.*, + data-default, directory, + glib, + gtk, mtl Main-is: Main.hs - Hs-Source-Dirs: Hbro + Hs-Source-Dirs: Hbro Ghc-options: -Wall if flag(threaded) Ghc-options: -threaded -