hbro-1.1.2.0/0000755000000000000000000000000012105303361010763 5ustar0000000000000000hbro-1.1.2.0/Hbro.hs0000644000000000000000000000034012105303361012206 0ustar0000000000000000module Hbro ( module Hbro.Boot, module Hbro.Config, module Hbro.Core, module Hbro.Error, module Hbro.Util, ) where import Hbro.Boot import Hbro.Config import Hbro.Core import Hbro.Error import Hbro.Util hbro-1.1.2.0/LICENSE0000644000000000000000000000065312105303361011774 0ustar0000000000000000DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE Version 2, December 2004 Copyright (C) koral Everyone is permitted to copy and distribute verbatim or modified copies of this license document, and changing it is allowed as long as the name is changed. DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. You just DO WHAT THE FUCK YOU WANT TO. hbro-1.1.2.0/hbro.cabal0000644000000000000000000000405712105303361012707 0ustar0000000000000000Name: hbro Version: 1.1.2.0 Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ Category: Browser,Web License: OtherLicense License-file: LICENSE -- Copyright: Author: koral Maintainer: koral Cabal-version: >=1.8 Build-type: Simple Extra-source-files: README.rst Data-files: examples/ui.xml Source-repository head Type: git Location: git@github.com:k0ral/hbro.git Source-repository head Type: git Location: git@twyk.org/haskell-browser.git Library Build-depends: base == 4.*, bytestring, cond, containers, data-default, directory, dyre >= 0.8.8, filepath, glib, gtk >= 0.12.3, lens, monad-control, mtl, network, pango, process, transformers, transformers-base, unix, webkit, xdg-basedir, zeromq3-haskell >= 0.2 Exposed-modules: Hbro, Hbro.Boot, Hbro.Clipboard, Hbro.Config, Hbro.Core, Hbro.Error, Hbro.Gui, Hbro.IPC, Hbro.Keys, Hbro.Network, Hbro.Notification, Hbro.Options, Hbro.Prompt, Hbro.Util, Hbro.Gtk.ScrolledWindow, Hbro.Webkit.WebSettings, Hbro.Webkit.WebView Extensions: ConstraintKinds, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes Other-modules: Hbro.Dyre, Paths_hbro Ghc-options: -Wall Flag threaded Description: Build with -threaded Default: True Executable hbro Build-depends: hbro >= 1.1.1.0, base == 4.*, glib, gtk Main-is: Main.hs Hs-Source-Dirs: Hbro Ghc-options: -Wall if flag(threaded) Ghc-options: -threaded hbro-1.1.2.0/README.rst0000644000000000000000000000732612105303361012462 0ustar0000000000000000==== hbro ==== **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_. Design principles ----------------- `Do one thing well`_ A web browser is **not** a {window|bookmarks|history|download|passwords|package} manager, let alone an operating system. A web browser retrieves, renders and traverses web pages, period. `Keep It Simple, Stupid`_ The program should be written with simplicity in mind, and without obsession for performance, features or release frequency. It should not take time to start-up, consume much RAM or crash. Its code should be easy to understand (well, as long as you speak Haskell...) to encourage users to hack it. Simplicity provides lightness, scalability, stability and maintainability. Extensible Configuration system should allow users to implement extra features. External programs should be able to query/order *hbro*. Good defaults A default configuration, suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks, should be provided. Keyboard driven Keyboard control should be made as much convenient, with as little mouse intervention, as possible. Components and libraries used ----------------------------- Programming language : Haskell_ Modern, purely-functional language that makes it possible to work with a short, elegant and robust code. Layout engine : WebKit_ Webkit seems to be the only engine being open-source, (kind of) standards-compliant and providing a Haskell binding. It's not much of a choice, fortunately it's not that bad. UI toolkit : `GTK+`_ Given the above programming language and layout engine, there's no much choice left for the UI toolkit. Interprocess interface : ZeroMQ_ Socket-like interface that implements various convenient communication schemes like request-reply and publish-subscribe. Configuration system : Dyre_ Dynamic reconfiguration library for haskell programs. Suggestions about better alternatives for any of these points (except the programming language) are welcome. Configuration ------------- By default, a minimal configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the * hbro-contrib_ * package, including a well-commented example of configuration file. Known bugs and limitations -------------------------- Unfortunately, many problems/limitations are inherited from the *Haskell* binding for *webkit*/*gtk*. Until fixed in upstream, nothing can be done on *hbro* to work around them. Here's a summary of them: - segfaults when loading some webpages or enabling javascript/flash; - no proxy configuration; - no cookies management; - javascript's ``window.open`` requests open in the same window instead of spawning a new one; - toggling to source mode reloads current webpage (which may be undesired) Patches or suggestions are welcome to deal with the following issues. License ------- *hbro* is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name. .. _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 .. _Do-What-The-Fuck-You-Want-To public licence: http://en.wikipedia.org/wiki/WTFPL .. _Haskell: http://haskell.org/ .. _WebKit: http://www.webkit.org/ .. _GTK+: http://www.gtk.org/ .. _ZeroMQ: http://www.zeromq.org/ .. _Dyre: https://github.com/willdonnelly/dyre .. _hbro-contrib: http://hackage.haskell.org/package/hbro-contrib hbro-1.1.2.0/Setup.hs0000644000000000000000000000005612105303361012420 0ustar0000000000000000import Distribution.Simple main = defaultMain hbro-1.1.2.0/examples/0000755000000000000000000000000012105303361012601 5ustar0000000000000000hbro-1.1.2.0/examples/ui.xml0000644000000000000000000000564012105303361013745 0ustar0000000000000000 False 0 False 10 False False False False False 5 False False False False False 5 True 0 False False hbro-1.1.2.0/Hbro/0000755000000000000000000000000012105303361011655 5ustar0000000000000000hbro-1.1.2.0/Hbro/Keys.hs0000644000000000000000000001302312105303361013123 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell, TupleSections #-} -- | Key bindings model. -- Designed to be imported as @qualified@. module Hbro.Keys ( Tree(..), Stroke, Bindings, Mode(..), Status(..), mode, strokes, StatusReader(..), StatusWriter(..), StatusState, mkStroke, merge, lookup, deserialize, prefixMod, serialize, toString, mkBinding, toBindings) where -- {{{ Imports -- import Hbro.Util import Control.Lens import Control.Monad hiding(forM_) -- import Control.Monad.Error hiding(forM_) -- import Control.Monad.IO.Class -- import Control.Monad.Reader hiding(forM_) -- import Control.Monad.Trans.Control import Data.Default -- import Data.Foldable import Data.Functor -- import Data.Monoid import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Set (Set) import qualified Data.Set as S hiding(foldl) import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Gdk.Keys -- import Graphics.UI.Gtk.General.Enums import Prelude hiding(lookup, mapM_) -- }}} -- {{{ Types -- | A tree implementation that labels edges data Tree edge leaf = Empty | Leaf leaf | Branch (Map edge (Tree edge leaf)) deriving(Show) -- | A single keystroke, i.e. a set of modifiers and a single key (its string description) type Stroke = (Set Modifier, String) -- | List of keys bound to actions type Bindings m = Tree Stroke (m ()) data Mode = Normal | Insert deriving(Eq, Ord) -- | Global state data Status = Status { _mode :: Mode, -- ^ Current mode _strokes :: [Stroke] -- ^ Previous keystrokes } instance Default Status where def = Status Normal [] makeLenses ''Status -- | 'MonadReader' for 'Status' class StatusReader m where readStatus :: Simple Lens Status a -> m a -- | 'MonadWriter' for 'Status' class StatusWriter m where writeStatus :: Simple Lens Status a -> a -> m () -- | 'MonadState' for 'Status' type (StatusState m) = (StatusReader m, StatusWriter m) {-instance Monoid KeyMap where mempty = KeyBindings M.empty mappend (KeyBindings a) (KeyBindings b) = KeyBindings (mappend a b)-} instance Ord Modifier where compare x y = compare (show x) (show y) -- }}} mkStroke :: [Modifier] -> KeyVal -> Maybe Stroke mkStroke m k = Just . (S.fromList m,) =<< toString k --toTree :: Ord a => [([a], b)] -> Tree a b --toTree = foldl merge Empty . map toBranch toBranch :: Ord a => ([a], b) -> Tree a b toBranch ([], a) = Leaf a toBranch ((h:t), a) = Branch (M.fromList [(h, toBranch (t, a))]) -- | In case of conflicts, the rightmost operand is preferred merge :: Ord a => Tree a b -> Tree a b -> Tree a b merge Empty x = x merge x Empty = x merge (Leaf _) (Leaf b) = Leaf b merge (Leaf _) (Branch b) = Branch b merge (Branch _) (Leaf b) = Leaf b merge (Branch a) (Branch b) = Branch $ M.unionWith merge a b lookup :: Ord a => [a] -> Tree a b -> Maybe (Tree a b) lookup _ Empty = Nothing lookup [] (Leaf x) = Just (Leaf x) lookup [] x = Just x lookup _ (Leaf _) = Nothing lookup (h:t) (Branch m) = M.lookup h m >>= lookup t -- | Convert a KeyVal to a String. -- For printable characters, the corresponding String is returned, except for the space character for which "" is returned. -- For non-printable characters, the corresponding keyName wrapped into "< >" is returned. -- For modifiers, Nothing is returned. toString :: KeyVal -> Maybe String toString keyVal = case keyToChar keyVal of Just ' ' -> Just "" Just char -> Just [char] _ -> case keyName keyVal of "Caps_Lock" -> Nothing "Shift_L" -> Nothing "Shift_R" -> Nothing "Control_L" -> Nothing "Control_R" -> Nothing "Alt_L" -> Nothing "Alt_R" -> Nothing "Super_L" -> Nothing "Super_R" -> Nothing "Menu" -> Nothing "ISO_Level3_Shift" -> Nothing "dead_circumflex" -> Just "^" "dead_diaeresis" -> Just "ยจ" x -> Just ('<':x ++ ">") serialize :: Stroke -> String serialize (m, k) = S.foldr (++) "" (S.map serializeMod m) ++ k serializeMod :: Modifier -> String serializeMod Control = "C-" -- serializeMod Shift = "S-" serializeMod Alt = "M-" serializeMod _ = "" -- | Parse a 'String' representation of a keystrokes chain deserialize :: String -> Maybe [Stroke] deserialize "" = Just [] deserialize (' ':t) = deserialize t deserialize ('C':'-':t) = prefixMod Control =<< deserialize t deserialize ('M':'-':t) = prefixMod Alt =<< deserialize t -- deserialize ('S':'-':t) = prefixMod Shift =<< deserialize t deserialize (k:' ':t) = prepend k <$> deserialize t deserialize (k:t) = prefixVal k =<< deserialize t prefixMod :: Modifier -> [Stroke] -> Maybe [Stroke] prefixMod modifier ((m, keys):t) = Just ((S.insert modifier m, keys):t) prefixMod _ _ = Nothing prefixVal :: Char -> [Stroke] -> Maybe [Stroke] prefixVal k [] = Just [(S.empty, [k])] prefixVal k ((modifiers, keys):t) | S.null modifiers = Just ((modifiers, k:keys):t) | otherwise = Nothing prepend :: Char -> [Stroke] -> [Stroke] prepend k x = (S.empty, [k]):x mkBinding :: String -> m () -> Maybe (Bindings m) mkBinding keys action = toBranch . (, action) <$> deserialize keys toBindings :: [(String, m ())] -> Bindings m toBindings = foldl merge Empty . catMaybes . map (\(a, b) -> mkBinding a b) hbro-1.1.2.0/Hbro/IPC.hs0000644000000000000000000000367412105303361012636 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | Designed to be imported as @qualified@. module Hbro.IPC where -- {{{ Imports -- import Hbro.Error import Hbro.Util import Control.Lens hiding(Context) import Control.Monad.Base -- import Control.Monad.Error hiding(mapM_) -- import Control.Monad.Writer import Data.ByteString.Char8 (pack, unpack) --import Data.Foldable import Data.Functor import Data.Map (Map) -- import Graphics.UI.Gtk.General.General import Prelude hiding(log, mapM_, read) -- import System.Posix.Types -- import System.Process import System.ZMQ3 hiding(close, context, init, message, receive, send, socket) import qualified System.ZMQ3 as ZMQ (receive, send) -- }}} -- {{{ Types data IPC = IPC { _context :: Context, _receiver :: Socket Rep} -- | 'MonadReader' for 'IPC' class IPCReader m where readIPC :: Simple Lens IPC a -> m a makeLenses ''IPC newtype CommandsMap m = CommandsMap { unwrap :: Map String ([String] -> m String) } -- }}} -- | Send message through given socket send :: (MonadBase IO m, Sender a) => Socket a -> String -> m () send socket payload = io $ ZMQ.send socket [] (pack payload) -- | Wait for a message to be received from given socket read :: (MonadBase IO m, Receiver a) => Socket a -> m String read socket = io $ unpack <$> ZMQ.receive socket -- | Send a single command to the given socket (which must be 'Rep'), and return the answer sendCommand :: (MonadBase IO m, IPCReader m) => String -> String -> m String sendCommand socketURI command = do theContext <- readIPC context io $ withSocket theContext Req $ \socket -> do connect socket socketURI send socket command read socket -- | Same as 'sendCommand', but for all running instances of the browser. {-sendCommandToAll :: (MonadBase IO m, ConfigReader m m, IPCReader m) => String -> m [String] sendCommandToAll command = do dir <- readConfig socketDir getAllProcessIDs >>= mapM ((`sendCommand` command) . (`socketPath` dir))-} hbro-1.1.2.0/Hbro/Util.hs0000644000000000000000000000537312105303361013136 0ustar0000000000000000module Hbro.Util where -- {{{ Imports import Control.Concurrent import Control.Exception import Control.Monad hiding(mapM_) import Control.Monad.Base -- import Control.Monad.Error hiding(mapM_) -- import Control.Monad.Reader hiding(mapM_) import Control.Monad.Trans.Control -- import Data.Foldable import Data.Functor import Data.List import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.General.General -- import qualified Network.URI as N import Prelude hiding(log, mapM_) import System.FilePath import qualified System.Info as Sys -- import System.IO import System.Posix.Process import System.Posix.Types import System.Process -- }}} -- {{{ Aliases/shortcuts -- | Alias for 'liftIO' io :: MonadBase IO m => IO a -> m a io = liftBase -- | Like 'forkIO' using 'MVar' as thread control fork :: (MonadBaseControl IO m) => m () -> m (MVar ()) fork f = do mvar <- io newEmptyMVar liftBaseWith $ \runInIO -> void . forkIO $ finally (void $ runInIO f) (putMVar mvar ()) return mvar -- | Like '()' with first argument in IO to build platform-dependent paths. (>/>) :: (MonadBase IO m) => IO FilePath -> FilePath -> m FilePath (>/>) a b = io $ ( b) <$> a -- }}} -- {{{ Process management -- | Run external command and won't kill when parent process exit. spawn :: MonadBase IO 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 :: MonadBase IO 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' -- }}} {-errorHandler :: (MonadBase IO m, MonadReader r m, HasOptions r) => FilePath -> IOError -> m () errorHandler file e = do when (isAlreadyInUseError e) $ unlessQuiet . io . putStrLn $ "ERROR: file <" ++ file ++ "> is already opened and cannot be reopened." when (isDoesNotExistError e) $ unlessQuiet . io . putStrLn $ "ERROR: file <" ++ file ++ "> doesn't exist." when (isPermissionError e) $ unlessQuiet . io . putStrLn $ "ERROR: user doesn't have permission to open file <" ++ file ++ ">."-} -- Common pango attributes allItalic, allBold :: PangoAttribute allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic} allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold} postGUISync' :: (MonadBaseControl IO m) => m a -> m a postGUISync' f = control $ \runInIO -> postGUISync (runInIO f) hbro-1.1.2.0/Hbro/Core.hs0000644000000000000000000003317212105303361013107 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeFamilies #-} module Hbro.Core where -- {{{ Imports import qualified Hbro.Clipboard as Clipboard import Hbro.Config import Hbro.Error import Hbro.Gtk.ScrolledWindow (Axis(..), Position(..)) import qualified Hbro.Gtk.ScrolledWindow as SW import Hbro.Gui as GUI import qualified Hbro.Keys as Keys import Hbro.IPC import Hbro.Network import Hbro.Notification import Hbro.Options (CliOptions, OptionsReader) import qualified Hbro.Options as Options import Hbro.Prompt (PromptReader) import qualified Hbro.Prompt as Prompt import Hbro.Util as H import qualified Hbro.Webkit.WebView as W import Control.Applicative import Control.Conditional hiding(unless) import Control.Lens hiding((??)) import Control.Monad import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_, unless) import Control.Monad.Reader hiding(forM_, mapM_, unless) import Control.Monad.Writer hiding(forM_, mapM_, unless) import Control.Monad.Trans.Control import Data.Default -- import Data.Foldable -- import Data.Functor import Data.IORef import qualified Data.Map as M import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame as W import Graphics.UI.Gtk.WebKit.WebInspector import Graphics.UI.Gtk.WebKit.WebView as W import Graphics.UI.Gtk.Windows.Window import Network.URI (URI, uriScheme) import qualified Network.URI as N import Prelude hiding(concat, mapM_) import qualified System.Glib.Attributes as G -- }}} -- {{{ Types --newtype (Monad m) => KT m a = KT { unKT :: ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config (KT m))) (ReaderT (GUI (KT m)) (ReaderT IPC m))))) a} -- deriving (Applicative, Functor, Monad, MonadWriter String) --type K = KT IO newtype K a = K { unKT :: ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config K)) (ReaderT (GUI K) (ReaderT IPC (ReaderT (IORef Keys.Status) IO)))))) a} deriving (Applicative, Functor, Monad, MonadBase IO, MonadError HError, MonadWriter String) instance MonadBaseControl IO K where newtype StM K a = StK { unStK :: StM (ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config K)) (ReaderT (GUI K) (ReaderT IPC (ReaderT (IORef Keys.Status) IO))))))) a } liftBaseWith f = K . liftBaseWith $ \runInBase -> f $ liftM StK . runInBase . unKT restoreM = K . restoreM . unStK instance ConfigReader K K where readConfig l = K $ (lift . lift . lift) ask >>= io . readIORef >>= return . view l instance ConfigWriter K K where writeConfig l v = K $ (lift . lift . lift) ask >>= io . (`modifyIORef` set l v) instance GUIReader K K where readGUI l = K $ (lift . lift . lift . lift) ask >>= return . view l instance IPCReader K where readIPC l = K $ (lift . lift . lift . lift . lift) ask >>= return . view l instance NotificationReader K where readNotification l = K $ (lift . lift . lift . lift) ask >>= return . view (notificationBar.l) instance OptionsReader K where readOptions l = K $ (lift . lift) ask >>= return . view l instance PromptReader K K where readPrompt l = K $ (lift . lift . lift . lift) ask >>= return . view (promptBar.l) instance Keys.StatusReader K where readStatus l = K $ (lift . lift . lift . lift . lift . lift) ask >>= io . readIORef >>= return . view l instance Keys.StatusWriter K where writeStatus l v = K $ (lift . lift . lift . lift . lift . lift) ask >>= io . (`modifyIORef` set l v) runK :: CliOptions -> Config K -> GUI K -> IPC -> K a -> IO ((Either HError a), String) runK options config gui ipc k = do config' <- newIORef config keysStatus <- newIORef def (`runReaderT` keysStatus) . (`runReaderT` ipc) . (`runReaderT` gui) . (`runReaderT` config'). (`runReaderT` options) . runWriterT . runErrorT $ unKT k data CaseSensitivity = CaseSensitive | CaseInsensitive data Direction = Forward | Backward data Wrap = Wrap | NoWrap data ZoomDirection = In | Out -- }}} -- {{{ Default configuration instance Default (Config K) where def = Config { _homePage = maybe undefined id . N.parseURI $ "https://duckduckgo.com/", _verbosity = Normal, _keyBindings = defaultKeyBindings, _commands = def, _onDownload = defaultDownload, _onKeyStroke = const $ return (), _onLinkClicked = defaultLinkClicked, _onLoadFinished = return (), _onLoadRequested = \uri -> load uri, _onNewWindow = \uri -> spawn "hbro" [show uri], _onResourceOpened = defaultResourceOpened, _onTitleChanged = \title -> readGUI mainWindow >>= io . (`G.set` [ windowTitle G.:= ("hbro | " ++ title)])} -- return ()} -- | List of default supported requests. instance Default (CommandsMap K) where def = CommandsMap . M.fromList $ [ -- 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 >>= load >> 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")] defaultDownload :: URI -> String -> Int -> K () defaultDownload _ _ _ = return () defaultLinkClicked :: (MonadBase IO m, MonadWriter String m, GUIReader n m) => MouseButton -> URI -> m () defaultLinkClicked MiddleButton uri = spawn "hbro" [show uri] defaultLinkClicked _ uri = load uri defaultKeyBindings :: M.Map Keys.Mode (Keys.Bindings K) defaultKeyBindings = M.singleton Keys.Normal $ Keys.toBindings [ -- 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 >=> load), ("M-v", Clipboard.with $ \uri -> spawn "hbro" [uri]), -- Display ("C-+", zoomIn), ("C--", zoomOut), -- ("", with (_window . _UI) windowFullscreen), -- ("", with (_window . _UI) windowUnfullscreen), ("C-b", toggleVisibility =<< readGUI statusBar), ("C-u", toggleSourceMode), -- Prompt ("C-o", Prompt.readURI "Open URI" "" load), ("M-o", getURI >>= \uri -> Prompt.readURI "Open URI " (show uri) load), -- 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 =<< Prompt.getEntryValue), ("C-N", void . searchText CaseInsensitive Backward Wrap =<< Prompt.getEntryValue), -- Misc ("", Prompt.hide), ("C-i", inspect), ("C-p", printPage), ("C-t", spawn "hbro" []), ("C-w", quit)] -- /!\ 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. defaultResourceOpened :: (MonadBase IO m, GUIReader n m) => URI -> String -> m ResourceAction defaultResourceOpened _uri mimetype = do canShow <- io . (`webViewCanShowMimeType` mimetype) =<< readGUI webView return (canShow ? Load ?? Download) -- }}} -- {{{ Util isCaseSensitive :: CaseSensitivity -> Bool isCaseSensitive CaseSensitive = True isCaseSensitive _ = False isForward :: Direction -> Bool isForward Forward = True isForward _ = False isWrapped :: Wrap -> Bool isWrapped Wrap = True isWrapped _ = False {-getState :: (MonadBase IO 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 modify $ \s -> s { _custom = M.insert key (toDyn defaultValue) customMap } return defaultValue-} -- }}} -- {{{ Getters getFaviconURI :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m URI getFaviconURI = W.getIconUri =<< readGUI webView getLoadProgress :: (MonadBase IO m, GUIReader n m) => m Double getLoadProgress = io . W.webViewGetProgress =<< readGUI webView getURI :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m URI getURI = W.getUri =<< readGUI webView getTitle :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m String getTitle = W.getTitle =<< readGUI webView -- }}} -- {{{ Browsing goHome :: (MonadBase IO m, GUIReader n m, ConfigReader n' m, MonadWriter String m) => m () goHome = load =<< readConfig homePage load :: (MonadBase IO m, GUIReader n m, MonadWriter String m) => URI -> m () load uri = do tell $ "Loading URI: " ++ (show uri') io . (`W.webViewLoadUri` uri') =<< readGUI webView where uri' = case uriScheme uri of [] -> "http://" ++ show uri _ -> show uri reload, reloadBypassCache :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m () reload = io . W.webViewReload =<< readGUI webView reloadBypassCache = io . W.webViewReloadBypassCache =<< readGUI webView stopLoading :: (MonadBase IO m, GUIReader n m, MonadWriter String m) => m () stopLoading = do io . W.webViewStopLoading =<< readGUI webView tell $ "Stopped loading" goBack, goForward :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m () goBack = do readGUI webView >>= io . W.webViewCanGoBack >>= (`unless` throwError CannotGoBack) io . W.webViewGoBack =<< readGUI webView goForward = do readGUI webView >>= io . W.webViewCanGoForward >>= (`unless` throwError CannotGoForward) readGUI webView >>= io . W.webViewGoForward -- }}} -- {{{ Display -- | Toggle source display. -- Current implementation forces a refresh of current web page, which may be undesired. toggleSourceMode :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m () toggleSourceMode = do v <- readGUI webView io . W.webViewSetViewSourceMode v =<< (io $ not <$> W.webViewGetViewSourceMode v) reload zoomIn, zoomOut :: (MonadBase IO m, GUIReader n m) => m () zoomIn = io . W.webViewZoomIn =<< readGUI webView zoomOut = io . W.webViewZoomOut =<< readGUI webView scroll :: (MonadBase IO m, GUIReader n m) => Axis -> Position -> m () scroll axis percentage = SW.scroll axis percentage =<< readGUI scrollWindow -- | Show web inspector for current webpage. inspect :: (MonadBase IO m, GUIReader n m) => m () inspect = do inspector <- io . W.webViewGetInspector =<< readGUI webView io $ webInspectorInspectCoordinates inspector 0 0 -- }}} -- {{{ searchText :: (MonadBase IO m, GUIReader n m) => CaseSensitivity -> Direction -> Wrap -> String -> m Bool searchText s d w text = do v <- readGUI webView io $ W.webViewSearchText v text (isCaseSensitive s) (isForward d) (isWrapped w) searchText_ :: (MonadBase IO m, GUIReader n m) => CaseSensitivity -> Direction -> Wrap -> String -> m () searchText_ s d w text = searchText s d w text >> return () printPage :: (MonadBase IO m, GUIReader n m) => m () printPage = io . W.webFramePrint =<< io . W.webViewGetMainFrame =<< readGUI webView download :: (MonadBase IO m, ConfigReader m m) => URI -> m () download uri = do callback <- readConfig onDownload callback uri (show uri) 0 -- }}} quit :: (MonadBase IO m) => m () quit = io mainQuit -- {{{ Misc -- | Execute a javascript file on current webpage. executeJSFile :: (MonadBase IO m, MonadReader r m, MonadWriter String m) => FilePath -> WebView -> m () executeJSFile filePath webView' = do tell $ "Executing Javascript file: " ++ filePath script <- io $ readFile filePath let script' = unwords . map (++ "\n") . lines $ script io $ webViewExecuteScript webView' script' -- }}} -- | Save current web page to a file, -- along with all its resources in a separated directory. -- Doesn't work for now, because web_resource_get_data's binding is missing... _savePage :: String -> WebView -> IO () _savePage _path webView' = do frame <- webViewGetMainFrame webView' dataSource <- webFrameGetDataSource frame _mainResource <- webDataSourceGetMainResource dataSource _subResources <- webDataSourceGetSubresources dataSource return () hbro-1.1.2.0/Hbro/Gui.hs0000644000000000000000000001672012105303361012743 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} module Hbro.Gui ( Buildable(..), StatusBar(..), GUI(), GUIReader(..), mainWindow, inspectorWindow, scrollWindow, webView, promptBar, statusBar, notificationBar, builder, getObject, toggleVisibility, buildFrom, init) where -- {{{ Imports import Hbro.Notification import Hbro.Prompt (PromptBar(..), PromptReader(..)) import qualified Hbro.Prompt as Prompt import Hbro.Util import qualified Hbro.Webkit.WebView as WebView import Control.Applicative import Control.Conditional hiding(when) import Control.Lens hiding((??), view) import Control.Monad hiding(forM_, mapM_) import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) import Control.Monad.Trans.Control -- import Data.Foldable -- import Data.Functor import Data.IORef import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container import Graphics.UI.Gtk.Abstract.Box 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 import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.General.General as GTK import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebInspector import Graphics.UI.Gtk.WebKit.WebView hiding(webViewLoadUri) import Graphics.UI.Gtk.Windows.Window import Prelude hiding(init, mapM_) import System.Glib.Attributes hiding(get, set) import qualified System.Glib.Attributes as G (get, set) import System.Glib.Signals import System.Glib.Types -- }}} -- {{{ Types newtype StatusBar = StatusBar HBox instance GObjectClass StatusBar where toGObject (StatusBar h) = toGObject h unsafeCastGObject g = StatusBar $ unsafeCastGObject g instance ObjectClass StatusBar instance WidgetClass StatusBar data GUI m = GUI { _mainWindow :: Window, _inspectorWindow :: Window, _scrollWindow :: ScrolledWindow, -- ^ 'ScrolledWindow' containing the webview _webView :: WebView, _promptBar :: PromptBar m, _statusBar :: StatusBar, _notificationBar :: NotificationBar, _builder :: Builder -- ^ Builder object created from XML file } makeLenses ''GUI -- | 'MonadReader' for 'GUI' class (Monad m) => GUIReader n m | m -> n where readGUI :: Simple Lens (GUI n) a -> m a -- | UI elements that can be built from a @GtkBuilder@ object (that is: an XML file) class Buildable a where build :: (MonadBase IO m) => Builder -> m a instance (Monad m) => Buildable (PromptBar m) where build b = io $ do l <- builderGetObject b castToLabel "promptDescription" e <- builderGetObject b castToEntry "promptEntry" b' <- builderGetObject b castToHBox "promptBox" oC <- newIORef . const $ return () oV <- newIORef . const $ return () return $ PromptBar b' l e oC oV instance Buildable (WebView, ScrolledWindow) where build b = io $ do window <- builderGetObject b castToScrolledWindow "webViewParent" wv <- webViewNew containerAdd window wv return (wv, window) instance Buildable (Window, VBox) where build b = io $ do w <- builderGetObject b castToWindow "mainWindow" b' <- builderGetObject b castToVBox "windowBox" return (w, b') instance Buildable StatusBar where build b = io $ StatusBar <$> builderGetObject b castToHBox "statusBox" instance Buildable NotificationBar where build b = io $ NotificationBar <$> builderGetObject b castToLabel "notificationLabel" <*> newIORef Nothing instance (Monad m) => Buildable (GUI m) where build b = io $ do (webView', sWindow') <- build b (window', wBox') <- build b promptBar' <- build b statusBar' <- build b notificationBar' <- build b inspectorWindow' <- initWebInspector webView' wBox' return $ GUI window' inspectorWindow' sWindow' webView' promptBar' statusBar' notificationBar' b -- }}} -- {{{ Util -- | Return the casted GObject corresponding to the given name (set in the builder's XML file) getObject :: (MonadBase IO m, GUIReader n m, GObjectClass a) => (GObject -> a) -> String -> m a getObject cast name = do b <- readGUI builder io $ builderGetObject b cast name -- | Toggle a widget's visibility (provided for convenience). toggleVisibility :: (MonadBase IO m, WidgetClass a) => a -> m () toggleVisibility widget = io $ do visibility <- G.get widget widgetVisible visibility ? widgetHide widget ?? widgetShow widget -- }}} -- {{{ Initialization buildFrom :: (Monad n, MonadBase IO m) => FilePath -> m (GUI n) buildFrom uiFile = do b <- io builderNew io $ builderAddFromFile b uiFile build b init :: (MonadBase IO m, MonadBaseControl IO m, GUIReader m m, NotificationReader m, PromptReader m m, Error e, Show e, MonadError e m) => m () init = do w <- readGUI webView mw <- readGUI mainWindow initWindow mw initScrollWindow =<< readGUI scrollWindow Prompt.init =<< readGUI promptBar WebView.init w io $ windowSetDefault mw (Just w) -- Validate/cancel prompt e <- readGUI (promptBar.(Prompt.entry)) io . void $ on e keyPressEvent (f w) -- Show window io . widgetShowAll =<< readGUI mainWindow Prompt.hide return () where f w = do key <- eventKeyName when (key == "Return" || key == "Escape") $ io $ do --runInIO clean widgetGrabFocus w return () return False initScrollWindow :: (MonadBase IO m) => ScrolledWindow -> m () initScrollWindow window = io $ scrolledWindowSetPolicy window PolicyNever PolicyNever initWindow :: (MonadBase IO m) => Window -> m () initWindow window = io $ do windowSetDefaultSize window 800 600 widgetModifyBg window StateNormal (Color 0 0 10000) void $ onDestroy window GTK.mainQuit initWebInspector :: (MonadBase IO m) => WebView -> VBox -> m (Window) initWebInspector webView' windowBox = do inspector <- io $ webViewGetInspector webView' window' <- io windowNew io $ G.set window' [ windowTitle := "hbro | Web inspector" ] io . void . on inspector inspectWebView $ \_ -> do view <- webViewNew containerAdd window' view return view io . void . on inspector showWindow $ do widgetShowAll window' return True -- TODO: when does this signal happen ?! --_ <- on inspector finished $ return () -- Attach inspector to browser's main window _ <- io $ on inspector attachWindow $ do webview <- webInspectorGetWebView inspector case webview of Just view -> do widgetHide window' containerRemove window' view widgetSetSizeRequest view (-1) 250 boxPackEnd windowBox view PackNatural 0 widgetShow view return True _ -> return False -- Detach inspector in a distinct window _ <- io $ on inspector detachWindow $ do webview <- webInspectorGetWebView inspector _ <- case webview of Just view -> do containerRemove windowBox view containerAdd window' view widgetShowAll window' return True _ -> return False widgetShowAll window' return True return window' -- }}} hbro-1.1.2.0/Hbro/Dyre.hs0000644000000000000000000000301212105303361013110 0ustar0000000000000000-- | Dynamic reconfiguration. Designed to be imported as @qualified@. module Hbro.Dyre where -- {{{ Imports import Hbro.Options import Hbro.Util import Config.Dyre import Config.Dyre.Compile import Config.Dyre.Paths import Control.Lens import Control.Monad.Base import Control.Monad.Reader import System.IO -- }}} -- | Print various paths used for dynamic reconfiguration printPaths :: MonadBase IO m => m () printPaths = io $ do (a, b, c, d, e) <- getPaths (parameters $ const $ return ()) putStrLn $ unlines [ "Current binary: " ++ a, "Custom binary: " ++ b, "Config file: " ++ c, "Cache directory: " ++ d, "Lib directory: " ++ e, []] -- | Dynamic reconfiguration settings parameters :: (a -> IO ()) -> Params (Either String a) parameters main = defaultParams { projectName = "hbro", showError = const Left, realMain = main', ghcOpts = ["-threaded"], statusOut = hPutStrLn stderr, includeCurrentDirectory = False} where main' (Left e) = putStrLn e main' (Right x) = main x wrap :: (a -> IO ()) -> CliOptions -> a -> IO () wrap main opts args = do when (opts^.verbose) printPaths wrapMain ((parameters main) { configCheck = not $ opts^.vanilla }) $ Right args -- | Launch a recompilation of the configuration file recompile :: IO (Maybe String) recompile = do customCompile (parameters $ const $ return ()) getErrorString (parameters $ const $ return ()) hbro-1.1.2.0/Hbro/Clipboard.hs0000644000000000000000000000174612105303361014120 0ustar0000000000000000-- | Designed to be imported as @qualified@. module Hbro.Clipboard where -- {{{ Imports import Hbro.Error import Hbro.Util import Control.Monad.Base import Control.Monad.Error import Control.Monad.Trans.Control import Graphics.UI.Gtk.General.Clipboard -- }}} -- | Write given string to primary clipboard insert :: (MonadBase IO m) => String -> m () insert text = io $ clipboardGet selectionPrimary >>= (`clipboardSetText` text) -- | Feed given function with primary cliboard's content with :: (MonadBaseControl IO m, MonadError HError m) => (String -> m a) -> m () with f = do clip <- io $ clipboardGet selectionPrimary requestText clip f -- | Wrapping around 'clipboardRequestText' to be able to use any monad based on IO as callback requestText :: (MonadBaseControl IO m, ClipboardClass a, MonadError HError m) => a -> (String -> m b) -> m () requestText clip f = liftBaseWith $ \runInIO -> clipboardRequestText clip $ \x -> void . runInIO . maybe (throwError EmptyClipboard) f $ x hbro-1.1.2.0/Hbro/Prompt.hs0000644000000000000000000001420612105303361013475 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} -- | Designed to be imported as @qualified@. module Hbro.Prompt( PromptBar(..), onChanged, onValidated, entry, description, box, PromptReader(..), init, open, hide, clean, read, incrementalRead, iread, readURI, getEntryValue) where -- {{{ Imports import Hbro.Error -- import Hbro.Gui import Hbro.Network import Hbro.Notification import Hbro.Util import Control.Conditional hiding(when) import Control.Lens hiding((??)) import Control.Monad hiding(forM_, mapM_) import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_, when) import Control.Monad.Writer import Control.Monad.Trans.Control -- import Data.Foldable -- import Data.Functor import Data.IORef import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Widget -- import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Editable import Graphics.UI.Gtk.Entry.Entry import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Layout.HBox import Network.URI hiding(parseURIReference) import Prelude hiding(init, mapM_, read) import System.Glib.Signals -- }}} -- {{{ Types data PromptBar m = PromptBar { _box :: HBox, _description :: Label, _entry :: Entry, _onChanged :: IORef (String -> m ()), _onValidated :: IORef (String -> m ())} makeLenses ''PromptBar class (Monad m, Monad n) => PromptReader n m | m -> n where readPrompt :: Simple Lens (PromptBar n) a -> m a -- }}} -- Validate/cancel prompt onEntryValidated :: (MonadBase IO m, MonadBaseControl IO m, NotificationReader m, Error e, Show e, MonadError e m, EntryClass t) => t -> (String -> m ()) -> 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 :: (MonadBaseControl IO m, NotificationReader m, Error e, Show e, MonadError e m, EditableClass t, EntryClass t) => t -> (String -> m ()) -> 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) init :: (MonadBase IO m, MonadBaseControl IO m, NotificationReader m, Error e, Show e, MonadError e m) => PromptBar m -> m () init promptBar = do io $ labelSetAttributes l [allItalic, allBold] io $ labelSetAttributes l [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}] io $ widgetModifyBase entry' StateNormal $ Color 0 0 0 io $ widgetModifyText entry' StateNormal $ Color 32767 32767 32767 void . onEntryChanged entry' $ \v -> io (readIORef onChanged') >>= \f -> f v void . onEntryValidated entry' $ \v -> io (readIORef onValidated') >>= \f -> f v return () where l = _description promptBar entry' = _entry promptBar onChanged' = _onChanged promptBar onValidated' = _onValidated promptBar open :: (Functor m, MonadBase IO m, PromptReader n m, MonadWriter String m) => String -> String -> m () open newDescription defaultText = do tell "Opening prompt." e <- readPrompt entry io . (`labelSetText` newDescription) =<< readPrompt description io $ entrySetText e defaultText io . widgetShow =<< readPrompt box io $ widgetGrabFocus e io $ editableSetPosition e (-1) hide :: (MonadBase IO m, PromptReader n m) => m () hide = io . widgetHide =<< readPrompt box -- | Close prompt, clean its content and callbacks clean :: (MonadBase IO m, PromptReader n m) => m () clean = do e <- readPrompt entry io $ (`widgetRestoreText` StateNormal) e io . widgetModifyText e StateNormal $ Color 32767 32767 32767 hide readPrompt onChanged >>= io . (`writeIORef` return (return ())) readPrompt onValidated >>= io . (`writeIORef` return (return ())) return () -- | Open prompt bar with given description and default value, -- and register a callback to trigger at validation. read :: (MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => String -- ^ Prompt description -> String -- ^ Initial value -> (String -> m ()) -- ^ Function to trigger when validating prompt value -> m () read = read' False -- | Same as 'read', but callback is triggered for each change in prompt's entry. incrementalRead :: (MonadBase IO m, MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => String -> String -> (String -> m ()) -> m () incrementalRead = read' True -- | Alias for 'incrementalRead'. iread :: (MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => String -> String -> (String -> m ()) -> m () iread = incrementalRead read' :: (MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => Bool -> String -> String -> (String -> m ()) -> m () read' incremental description' startValue f = do clean open description' startValue when incremental $ readPrompt onChanged >>= io . (`writeIORef` f) readPrompt onValidated >>= io . (`writeIORef` (f >=> const clean)) return () -- | Same as 'read' for URI values readURI :: (MonadBase IO m, PromptReader m m, MonadError HError m, MonadWriter String m) => String -> String -> (URI -> m ()) -> m () readURI description' startValue callback = do clean open description' startValue checkURI startValue readPrompt onChanged >>= io . (`writeIORef` checkURI) readPrompt onValidated >>= io . (`writeIORef` (parseURIReference >=> callback >=> const clean)) return () where checkURI v = do e <- readPrompt entry io $ widgetModifyText e StateNormal color where color = (isURIReference v) ? green ?? red green = Color 0 65535 0 red = Color 65535 0 0 getEntryValue :: (MonadBase IO m, PromptReader n m) => m String getEntryValue = io . entryGetText =<< readPrompt entry hbro-1.1.2.0/Hbro/Main.hs0000644000000000000000000000021112105303361013067 0ustar0000000000000000module Main where -- {{{ Imports import Hbro -- }}} -- Default main function provided as example main :: IO () main = hbro $ return () hbro-1.1.2.0/Hbro/Config.hs0000644000000000000000000001045612105303361013424 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell, UndecidableInstances #-} module Hbro.Config where -- {{{ Imports import qualified Hbro.Keys as Key import Hbro.IPC import Hbro.Util -- import Control.Conditional import Control.Lens hiding(set) import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) -- import Control.Monad.Writer hiding(forM_, mapM_) -- import Data.Foldable (forM_, mapM_) -- import Data.Functor import Data.List import Data.Map (Map) import qualified Data.Map as M import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.WebKit.WebNavigationAction import Network.URI as N hiding(parseURI, parseURIReference) import Prelude hiding(mapM_) -- }}} -- {{{ Types data ResourceAction = Load | Download data Verbosity = Quiet | Normal | Verbose deriving(Eq, Show) -- | Custom settings provided by the user data Config m = Config { _homePage :: URI, -- ^ Startup page -- Parameters _verbosity :: Verbosity, -- ^ Logs verbosity -- Hooks _keyBindings :: Map Key.Mode (Key.Bindings m), -- ^ Key bindings _onDownload :: URI -> String -> Int -> m (), -- ^ Callback triggered when a download is requested _onKeyStroke :: [Key.Stroke] -> m (), -- ^ Callback triggered when a key is pressed _onLinkClicked :: MouseButton -> URI -> m (), -- ^ Callback triggered when a link is clicked _onLoadRequested :: URI -> m (), -- ^ Callback triggered when a load is requested _onLoadFinished :: m (), -- ^ Callback triggered when a load is finished _onNewWindow :: URI -> m (), -- ^ Callback triggered when a new window is requested _onResourceOpened :: URI -> String -> m ResourceAction, -- ^ Callback triggered when opening a non HTML resource _onTitleChanged :: String -> m (), -- ^ Callback triggered when document title is changed _commands :: CommandsMap m -- ^ Commands recognized through IPC system } makeLenses ''Config instance Show (Config m) where show c = "Home page = " ++ (show $ c^.homePage) ++ "\nVerbosity = " ++ (show $ c^.verbosity) -- | 'MonadReader' for 'Config' class (Monad m) => ConfigReader n m | m -> n where readConfig :: Simple Lens (Config n) a -> m a instance ConfigReader n ((->) (Config n)) where readConfig l = view l -- | 'MonadWriter' for 'Config' class (Monad m) => ConfigWriter n m | m -> n where writeConfig :: Simple Lens (Config n) a -> a -> m () -- | 'MonadState' for 'Config' type ConfigState n m = (ConfigReader n m, ConfigWriter n m) modifyConfig :: (ConfigState n m) => Simple Lens (Config n) a -> (a -> a) -> m () modifyConfig l f = writeConfig l . f =<< readConfig l 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" -- }}} -- | Run an action unless verbosity is 'Quiet' unlessQuiet :: (MonadBase IO m, ConfigReader n m) => m () -> m () unlessQuiet f = do quiet' <- readConfig verbosity case quiet' of Quiet -> return () _ -> f -- | Run an action when verbosity is 'Verbose' whenLoud :: (MonadBase IO m, ConfigReader n m) => m () -> m () whenLoud f = do verbose' <- readConfig verbosity case verbose' of Verbose -> f _ -> return () log, logV :: (MonadBase IO m, ConfigReader n m) => String -> m () log = unlessQuiet . io . putStrLn logV = whenLoud . io . putStrLn -- | Bind a keystrokes chain to a callback, in a given mode bind :: (MonadBase IO m, ConfigState m m) => Key.Mode -> String -> m () -> m () bind mode strokes action = case newBindings of Just b -> do oldValue <- readConfig keyBindings let newValue = M.insertWith Key.merge mode b oldValue void $ writeConfig keyBindings newValue return () _ -> return () where newBindings = Key.mkBinding strokes action hbro-1.1.2.0/Hbro/Options.hs0000644000000000000000000001376012105303361013653 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} -- | Commandline options tools. Designed to be imported as @qualified@. module Hbro.Options ( CliOptions(), OptionsReader(..), startURI, socketPath, help, quiet, verbose, version, vanilla, recompile, denyReconf, forceReconf, dyreDebug, usage, get, getStartURI, getSocketURI, getUIFile) where -- {{{ Imports import Hbro.Util import Control.Conditional import Control.Lens as L hiding((??)) import Control.Monad.Base import Control.Monad.Reader import Data.Default import Data.Functor import Data.List import Data.Maybe import Network.URI as N import Prelude hiding(log) import System.Console.GetOpt import System.Directory import System.Environment import System.Environment.XDG.BaseDir import System.FilePath import System.Posix.Process -- }}} -- {{{ Types -- | Available commandline options (cf @hbro -h@). data CliOptions = CliOptions { _startURI :: Maybe String, _socketPath :: Maybe FilePath, _UIFile :: Maybe FilePath, _help :: Bool, _quiet :: Bool, _verbose :: Bool, _version :: Bool, _vanilla :: Bool, _recompile :: Bool, _denyReconf :: Bool, _forceReconf :: Bool, _dyreDebug :: Bool} deriving(Eq) makeLenses ''CliOptions instance Show CliOptions where show opts = intercalate " " $ catMaybes [ return . ("URI=" ++) =<< view startURI opts, return . ("SOCKET=" ++) =<< view socketPath opts, return . ("UI_FILE=" ++) =<< view uIFile opts, view help opts ? Just "HELP" ?? Nothing, view quiet opts ? Just "QUIET" ?? Nothing, view verbose opts ? Just "VERBOSE" ?? Nothing, view version opts ? Just "VERSION" ?? Nothing, view vanilla opts ? Just "VANILLA" ?? Nothing, view recompile opts ? Just "RECOMPILE" ?? Nothing, view denyReconf opts ? Just "DENY_RECONFIGURATION" ?? Nothing, view forceReconf opts ? Just "FORCE_RECONFIGURATION" ?? Nothing, view dyreDebug opts ? Just "DYRE_DEBUG" ?? Nothing] instance Default CliOptions where def = CliOptions { _startURI = Nothing, _socketPath = Nothing, _UIFile = Nothing, _help = False, _quiet = False, _verbose = False, _version = False, _vanilla = False, _recompile = False, _denyReconf = False, _forceReconf = False, _dyreDebug = False} -- | 'MonadReader' for 'CliOptions' class OptionsReader m where readOptions :: Simple Lens CliOptions a -> m a instance (Monad m) => OptionsReader (ReaderT CliOptions m) where readOptions l = return . view l =<< ask instance OptionsReader ((->) CliOptions) where readOptions l = view l -- }}} description :: [OptDescr (CliOptions -> CliOptions)] description = [ Option ['h'] ["help"] (NoArg (set help True)) "Print this help", Option ['q'] ["quiet"] (NoArg (set quiet True)) "Do not print any log", Option ['v'] ["verbose"] (NoArg (set verbose True)) "Print detailed logs", Option ['V'] ["version"] (NoArg (set version True)) "Print version", Option ['1'] ["vanilla"] (NoArg (set vanilla True)) "Do not read custom configuration file", Option ['r'] ["recompile"] (NoArg (set recompile True)) "Only recompile configuration", Option ['s'] ["socket"] (ReqArg (\v -> set socketPath (Just v)) "PATH") "Where to open IPC socket", Option ['u'] ["ui"] (ReqArg (\v -> set uIFile (Just v)) "PATH") "Path to UI descriptor (XML file)", Option [] ["force-reconf"] (NoArg id) "Recompile configuration before starting the program", Option [] ["deny-reconf"] (NoArg id) "Do not recompile configuration even if it has changed", Option [] ["dyre-debug"] (NoArg id) "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program"] -- | Usage text (cf @hbro -h@) usage :: String usage = usageInfo "Usage: hbro [OPTIONS] [URI]" description -- | Get and parse commandline options get :: (MonadBase IO m) => m CliOptions get = io $ do options <- getOpt' Permute description <$> getArgs case options of (opts, input, _, []) -> return $ set startURI ((null $ concat input) ? Nothing ?? Just (concat input)) (foldl (flip id) def opts) (_, _, _, _) -> return def -- | Get URI passed in commandline, check whether it is a file path or an internet URI -- and return the corresponding normalized URI (that is: prefixed with "file://" or "http://") getStartURI :: (MonadBase IO m, OptionsReader m) => m (Maybe URI) getStartURI = do theURI <- readOptions startURI case theURI of Just uri -> do fileURI <- io $ doesFileExist uri case fileURI of True -> io getCurrentDirectory >>= return . N.parseURIReference . ("file://" ++) . ( uri) _ -> return $ N.parseURIReference uri _ -> return Nothing -- | Return socket URI used by this instance getSocketURI :: (MonadBase IO m, OptionsReader m) => m String getSocketURI = maybe getDefaultSocketURI (return . ("ipc://" ++)) =<< readOptions socketPath where getDefaultSocketURI = do dir <- io getTemporaryDirectory pid <- io getProcessID return $ "ipc://" ++ dir "hbro." ++ show pid -- | Return UI descriptor (XML file) used to build the GUI getUIFile :: (MonadBase IO m, OptionsReader m) => m FilePath getUIFile = maybe getDefaultUIFile return =<< readOptions uIFile where getDefaultUIFile = io (getUserConfigDir "hbro" >/> "ui.xml") hbro-1.1.2.0/Hbro/Boot.hs0000644000000000000000000003063712105303361013125 0ustar0000000000000000module Hbro.Boot (hbro) where -- {{{ Imports import Hbro.Config import Hbro.Core import qualified Hbro.Dyre as Dyre import Hbro.Error import Hbro.Gui (GUI, GUIReader(..)) import qualified Hbro.Gui as Gui import Hbro.IPC (IPC(..), IPCReader(..)) import qualified Hbro.IPC as IPC import qualified Hbro.Keys as Key import Hbro.Notification import Hbro.Options (CliOptions, OptionsReader(..)) import qualified Hbro.Options as Options import Hbro.Util import qualified Hbro.Webkit.WebSettings as WS import Hbro.Webkit.WebView -- import Control.Applicative import Control.Concurrent import Control.Conditional hiding(when, unless) import Control.Lens hiding((??)) import Control.Monad import Control.Monad.Base import Control.Monad.Error hiding(when) import Control.Monad.Reader hiding(when) import Control.Monad.Trans.Control import Data.Default import Data.Functor import Data.List import qualified Data.Map as M hiding(null) -- import Data.Maybe import Data.Version import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Gdk.EventM import qualified Graphics.UI.Gtk.General.General as GTK import qualified Graphics.UI.Gtk.WebKit.Download as W import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebView as W import Paths_hbro import Prelude hiding(init) import System.Exit import System.Glib.Signals import System.Posix.Files import System.Posix.Signals import System.ZMQ3 (Rep(..)) import qualified System.ZMQ3 as ZMQ -- }}} -- | Main function to call in the configuration file (cf file @Hbro/Main.hs@). -- First, commandline options are parsed, then configuration is dynamically applied. hbro :: K () -> IO () hbro setup = do opts <- Options.get when (opts^.Options.help) $ putStrLn Options.usage >> exitSuccess when (opts^.Options.version) $ putStrLn (showVersion version) >> exitSuccess when (opts^.Options.verbose) . putStrLn $ "Commandline options: " ++ show opts when (opts^.Options.recompile) $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) Dyre.wrap hbro' opts (setup, opts) hbro' :: (K (), CliOptions) -> IO () hbro' (customSetup, options) = do void $ installHandler sigINT (Catch onInterrupt) Nothing config <- runReaderT initConfig options gui <- runReaderT initGUI options (result, logs) <- withIPC options $ \ipc -> runK options config gui ipc $ main customSetup either print return result unless (options^.Options.quiet) . unless (null logs) $ putStrLn logs unless (options^.Options.quiet) $ putStrLn "Exiting..." -- {{{ Initialization initConfig :: (MonadBase IO m, OptionsReader m) => m (Config K) initConfig = do options <- readOptions id return $ id . (options^.Options.quiet ? set verbosity Quiet ?? id) . (options^.Options.verbose ? set verbosity Verbose ?? id) $ def initGUI :: (MonadBase IO m, OptionsReader m) => m (GUI K) initGUI = do file <- Options.getUIFile fallback <- io $ getDataFileName "examples/ui.xml" file' <- io $ firstReadableOf [file, fallback] case file' of Just f -> do io $ void GTK.initGUI Gui.buildFrom f _ -> io $ putStrLn "No UI file found." >> exitFailure where firstReadableOf [] = return Nothing firstReadableOf (x:y) = do isReadable <- fileAccess x True False False isReadable ? return (Just x) ?? firstReadableOf y withIPC :: (MonadBaseControl IO m) => CliOptions -> (IPC -> m a) -> m a withIPC options f = restoreM =<< (liftBaseWith $ \runInIO -> do ZMQ.withContext $ \c -> do ZMQ.withSocket c Rep $ \s -> do io . ZMQ.bind s =<< runReaderT Options.getSocketURI options runInIO $ f (IPC c s)) -- }}} main :: K () -> K () main customSetup = do threadSync <- fork socketMain Gui.init -- Bind hooks bindDownload =<< Gui.readGUI Gui.webView bindKeys bindLoadFinished =<< Gui.readGUI Gui.webView bindNavigationRequest =<< Gui.readGUI Gui.webView bindNewWebView =<< Gui.readGUI Gui.webView bindNewWindow =<< Gui.readGUI Gui.webView bindResourceOpened =<< Gui.readGUI Gui.webView bindTitleChanged =<< Gui.readGUI Gui.webView -- Default web settings WS.set webSettingsMonospaceFontFamily "consolas" WS.set webSettingsEnableDeveloperExtras True WS.set webSettingsEnableHtml5Database False WS.set webSettingsEnableHtml5LocalStorage False WS.set webSettingsEnablePageCache True WS.set webSettingsEnablePlugins False WS.set webSettingsEnablePrivateBrowsing False WS.set webSettingsEnableScripts False WS.set webSettingsEnableSpellChecking False WS.set webSettingsEnableSpatialNavigation True WS.set webSettingsEnableUniversalAccessFromFileUris True WS.set webSettingsEnableXssAuditor True WS.set webSettingsJSCanOpenWindowAuto False -- Apply custom setup customSetup config <- readConfig id logV $ "Start-up configuration: \n" ++ show config -- Load startpage startURI <- Options.getStartURI maybe goHome load startURI -- Main loop io GTK.mainGUI -- Clean & close void . (`IPC.sendCommand` "QUIT") =<< Options.getSocketURI io $ takeMVar threadSync -- | IPC thread that listens to commands from external world. socketMain :: K () socketMain = do socket <- readIPC IPC.receiver whileTrue $ do message <- IPC.read socket logV $ "Received command: " ++ message case words message of [] -> IPC.send socket "ERROR Empty command" >> return True "QUIT":[] -> IPC.send socket "OK" >> return False command:arguments -> do commands' <- IPC.unwrap <$> readConfig commands case M.lookup command commands' of Just callback -> (postGUISync' (callback arguments) >>= IPC.send socket) `catchError` (\_ -> IPC.send socket "ERROR") _ -> IPC.send socket "ERROR Unknown command" return True return () where whileTrue f = do result <- f result ? whileTrue f ?? return () onInterrupt :: (MonadBase IO m) => m () onInterrupt = io (putStrLn "Received SIGINT." >> GTK.mainQuit) -- {{{ Signals handlers -- Triggered in 2 cases: -- 1/ Javascript window.open() -- 2/ Context menu "Open in new window" bindNewWebView :: (MonadBase IO m, ConfigReader m m, MonadBaseControl IO m, MonadError HError m) => WebView -> m () bindNewWebView webView = do void . liftBaseWith $ \runInIO -> on webView W.createWebView $ \_frame -> do webView' <- webViewNew void . on webView' W.webViewReady $ return True void . on webView' W.navigationPolicyDecisionRequested $ \_ request _ decision -> do void . runInIO $ do callback <- readConfig onNewWindow uri <- networkRequestGetUri request logV $ "New webview <" ++ show uri ++ ">" callback uri webPolicyDecisionIgnore decision return True return webView' bindDownload :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m () bindDownload webView = do void . liftBaseWith $ \runInIO -> on webView W.downloadRequested $ \d -> do amount <- W.downloadGetTotalSize d --notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show size ++ ")" void . runInIO $ do uri <- downloadGetUri d filename <- downloadGetSuggestedFilename d callback <- readConfig onDownload logV $ "Requested download <" ++ show uri ++ ">" callback uri filename amount return False bindLoadFinished :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, Error e, Show e, MonadError e m) => WebView -> m () bindLoadFinished webView = do void . liftBaseWith $ \runInIO -> on webView W.loadFinished $ \_frame-> do void . runInIO $ do callback <- readConfig onLoadFinished logV "Load finished" callback `catchError` \e -> (io $ print e) -- >> notify 5000 (show e) return () bindNavigationRequest :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m () bindNavigationRequest webView = do liftBaseWith $ \runInIO -> void . on webView W.navigationPolicyDecisionRequested $ \_frame request action decision -> do reason <- io $ webNavigationActionGetReason action button <- io $ toMouseButton <$> webNavigationActionGetButton action case (reason, button) of (WebNavigationReasonLinkClicked, Just b) -> void . runInIO $ do callback <- readConfig onLinkClicked uri <- networkRequestGetUri request logV $ "Link clicked <" ++ show uri ++ ">" callback b uri io $ webPolicyDecisionIgnore decision _ -> {-void . runInIO $ do callback <- readConfig onLoadRequested uri <- networkRequestGetUri request logV $ "Requested load <" ++ show uri ++ ">" callback uri-} io $ webPolicyDecisionUse decision return True where toMouseButton 1 = Just LeftButton toMouseButton 2 = Just MiddleButton toMouseButton 3 = Just RightButton toMouseButton _ = Nothing bindNewWindow :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m () bindNewWindow webView = do liftBaseWith $ \runInIO -> void . on webView W.newWindowPolicyDecisionRequested $ \_frame request _action decision -> do void . runInIO $ do callback <- readConfig onNewWindow uri <- networkRequestGetUri request logV $ "New window request <" ++ show uri ++ ">" callback uri webPolicyDecisionIgnore decision return True --either (\e -> io . putStrLn $ "WARNING: wrong URI given, unable to open new window.") (const $ return ()) result bindResourceOpened :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m () bindResourceOpened webView = do liftBaseWith $ \runInIO -> void . on webView W.mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> do void . runInIO $ do callback <- readConfig onResourceOpened uri <- networkRequestGetUri request logV $ "Opening resource [MIME type=" ++ mimetype ++ " | uri=" ++ show uri ++ "]" action <- callback uri mimetype case action of Load -> io $ webPolicyDecisionUse decision _ -> io $ webPolicyDecisionDownload decision return True bindTitleChanged :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m () bindTitleChanged webView = do liftBaseWith $ \runInIO -> void . on webView W.titleChanged $ \_frame title -> void . runInIO $ do logV $ "Title changed to: " ++ title callback <- readConfig onTitleChanged callback title bindKeys :: (MonadBaseControl IO m, Key.StatusState m, ConfigReader m m, GUIReader m m, NotificationReader m, Error e, Show e, MonadError e m) => m () bindKeys = do wv <- readGUI Gui.webView liftBaseWith $ \runInIO -> void . on wv keyPressEvent $ do modifiers <- eventModifier keyVal <- eventKeyVal case (Key.mkStroke modifiers keyVal) of Just newStroke -> void . io . runInIO $ do oldStrokes <- Key.readStatus Key.strokes theMode <- Key.readStatus Key.mode theBindings <- readConfig keyBindings f <- readConfig onKeyStroke let allStrokes = oldStrokes ++ [newStroke] f allStrokes logV $ "Pressed keys: " ++ (intercalate " " . map Key.serialize) allStrokes case (Key.lookup allStrokes =<< M.lookup theMode theBindings) of Just (Key.Leaf callback) -> Key.writeStatus Key.strokes [] >> callback `catchError` \e -> (io $ print e) >> notify 5000 (show e) Just (Key.Branch _) -> Key.writeStatus Key.strokes allStrokes _ -> return () --} return () _ -> return () return False hbro-1.1.2.0/Hbro/Network.hs0000644000000000000000000000075112105303361013645 0ustar0000000000000000-- | Functions from 'Network.URI' rewritten with 'MonadError' instead of 'Maybe'. module Hbro.Network where -- {{{ Imports import Hbro.Error import Control.Monad.Error import Network.URI as N -- }}} 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 hbro-1.1.2.0/Hbro/Notification.hs0000644000000000000000000000274412105303361014646 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Hbro.Notification where -- {{{ Imports import Hbro.Util import Control.Lens import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) import Data.Foldable import Data.IORef import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.General.General import Prelude hiding(mapM_) -- }}} -- {{{ Types data NotificationBar = NotificationBar { _label :: Label, _timer :: IORef (Maybe HandlerId)} makeLenses ''NotificationBar -- | 'MonadReader' for 'NotificationBar' class NotificationReader m where readNotification :: Simple Lens NotificationBar a -> m a -- | 'MonadWriter' for 'NotificationBar' class (Monad m) => NotificationWriter m where writeNotification :: Simple Lens NotificationBar a -> a -> m a -- | 'MonadState' for 'NotificationBar' type NotificationState m = (NotificationReader m, NotificationWriter m) -- }}} notify :: (Functor m, MonadBase IO m, NotificationReader m, Error e, MonadError e m) => Int -> String -> m () notify duration text = do label' <- readNotification label handler <- readNotification timer io $ do labelSetAttributes label' [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}] labelSetMarkup label' text mapM_ timeoutRemove =<< readIORef handler newID <- io $ timeoutAdd (labelSetMarkup label' "" >> return False) duration io . void $ writeIORef handler (Just newID) return () hbro-1.1.2.0/Hbro/Error.hs0000644000000000000000000000271212105303361013304 0ustar0000000000000000module Hbro.Error where -- {{{ Imports import Control.Monad.Error import Data.Maybe import Graphics.UI.Gtk.WebKit.Download import Graphics.UI.Gtk.WebKit.NetworkRequest import System.IO.Error -- }}} data HError = CannotGoBack | CannotGoForward | EmptyCallback | EmptyClipboard | EmptyDownloadURI Download | EmptyRequestURI NetworkRequest | EmptySuggestedFileName Download | InvalidIconURI | InvalidPageTitle | InvalidPageURI | InvalidURI String | IOE IOError | OtherError String instance Error HError where strMsg = OtherError 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 (EmptyClipboard) = "Empty clipboard." show (EmptySuggestedFileName _) = "No suggested name for this download." show (EmptyRequestURI _) = "Invalid request URI." show EmptyCallback = "No callback defined." show (OtherError s) = show s hbro-1.1.2.0/Hbro/Gtk/0000755000000000000000000000000012105303361012402 5ustar0000000000000000hbro-1.1.2.0/Hbro/Gtk/ScrolledWindow.hs0000644000000000000000000000214112105303361015673 0ustar0000000000000000module Hbro.Gtk.ScrolledWindow where -- {{{ Imports import Hbro.Util import Control.Monad.Base import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow -- }}} data Axis = Horizontal | Vertical data Position = Absolute Double | Relative Double getAdjustment :: (MonadBase IO m) => Axis -> ScrolledWindow -> m Adjustment getAdjustment Horizontal = io . scrolledWindowGetHAdjustment getAdjustment Vertical = io . scrolledWindowGetVAdjustment -- | General scrolling command. scroll :: (MonadBase IO 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) hbro-1.1.2.0/Hbro/Webkit/0000755000000000000000000000000012105303361013102 5ustar0000000000000000hbro-1.1.2.0/Hbro/Webkit/WebView.hs0000644000000000000000000000440312105303361015007 0ustar0000000000000000-- | Rewrite many 'Graphics.UI.Gtk.WebKit.WebView' functions in a monadic way. -- Designed to be imported as @qualified@. module Hbro.Webkit.WebView where -- {{{ Imports import Hbro.Error import Hbro.Network --import Hbro.Types import Hbro.Util import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_) -- import Control.Monad.Reader hiding(forM_, mapM_) -- import Data.Foldable (forM_, mapM_) -- import Data.Functor import Graphics.UI.Gtk.Abstract.Widget import qualified Graphics.UI.Gtk.General.General as GTK import qualified Graphics.UI.Gtk.WebKit.Download as W import Graphics.UI.Gtk.WebKit.NetworkRequest (NetworkRequest) import qualified Graphics.UI.Gtk.WebKit.NetworkRequest as W import Graphics.UI.Gtk.WebKit.WebView (WebView) 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 :: (MonadBase IO m) => WebView -> m () init webView = io $ do set webView [ widgetCanDefault := True ] void . on webView W.closeWebView $ GTK.mainQuit >> return False -- {{{ Monad-agnostic version of various WebKit functions getUri :: (MonadBase IO m, MonadError HError m) => WebView -> m URI getUri = maybe (throwError InvalidPageURI) parseURI <=< io . W.webViewGetUri getTitle :: (MonadBase IO m, MonadError HError m) => WebView -> m String getTitle = maybe (throwError InvalidPageTitle) return <=< io . W.webViewGetTitle getIconUri :: (MonadBase IO m, MonadError HError m) => WebView -> m URI getIconUri = maybe (throwError InvalidIconURI) parseURI <=< io . W.webViewGetUri networkRequestGetUri :: NetworkRequest -> forall m. (MonadBase IO m, MonadError HError m) => m URI networkRequestGetUri r = parseURIReference =<< maybe (throwError $ EmptyRequestURI r) return =<< io (W.networkRequestGetUri r) downloadGetUri :: (MonadBase IO m, MonadError HError m) => W.Download -> m URI downloadGetUri d = parseURI =<< maybe (throwError $ EmptyDownloadURI d) return =<< io (W.downloadGetUri d) downloadGetSuggestedFilename :: (MonadBase IO m, MonadError HError m) => W.Download -> m String downloadGetSuggestedFilename d = maybe (throwError $ EmptySuggestedFileName d) return =<< io (W.downloadGetSuggestedFilename d) -- }}} hbro-1.1.2.0/Hbro/Webkit/WebSettings.hs0000644000000000000000000000211412105303361015672 0ustar0000000000000000-- | Designed to be imported as @qualified@. module Hbro.Webkit.WebSettings where -- {{{ Imports import Hbro.Gui import Hbro.Util import Control.Monad import Control.Monad.Base import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import System.Glib.Attributes as G -- }}} set :: (MonadBase IO m, GUIReader n m) => Attr WebSettings a -> a -> m () set element newValue = modify_ element $ const newValue modify :: (MonadBase IO m, GUIReader n m) => Attr WebSettings a -> (a -> a) -> m a modify element modifier = do w <- readGUI webView settings <- io $ webViewGetWebSettings w oldValue <- io $ get settings element io $ G.set settings [element := modifier oldValue] io $ webViewSetWebSettings w settings return oldValue modify_ :: (MonadBase IO m, GUIReader n m) => Attr WebSettings a -> (a -> a) -> m () modify_ e m = void $ modify e m toggle :: (MonadBase IO m, GUIReader n m) => Attr WebSettings Bool -> m Bool toggle = (`modify` not) toggle_ :: (MonadBase IO m, GUIReader n m) => Attr WebSettings Bool -> m () toggle_ = (`modify_` not)