hbro 1.3.0.0 → 1.4.0.0
raw patch · 22 files changed
+315/−341 lines, 22 filesdep +directorydep +exceptionsdep +filepathdep −system-fileiodep ~classy-preludedep ~hbrodep ~resourcet
Dependencies added: directory, exceptions, filepath
Dependencies removed: system-fileio
Dependency ranges changed: classy-prelude, hbro, resourcet, time, webkitgtk3
Files
- README.rst +10/−10
- hbro.cabal +40/−39
- library/Graphics/UI/Gtk/WebKit/Extended.hs +101/−0
- library/Graphics/UI/Gtk/WebKit/Lifted.hs +0/−46
- library/Graphics/UI/Gtk/WebKit/Lifted/WebView.hs +0/−59
- library/Hbro/Boot.hs +19/−18
- library/Hbro/Clipboard.hs +11/−3
- library/Hbro/Core.hs +14/−16
- library/Hbro/Defaults.hs +14/−13
- library/Hbro/Dyre.hs +6/−2
- library/Hbro/Error.hs +5/−28
- library/Hbro/Event.hs +5/−5
- library/Hbro/Gui.hs +3/−4
- library/Hbro/Gui/MainView.hs +5/−4
- library/Hbro/Gui/NotificationBar.hs +3/−2
- library/Hbro/Gui/PromptBar.hs +20/−13
- library/Hbro/Keys.hs +2/−2
- library/Hbro/Logger.hs +8/−8
- library/Hbro/Options.hs +2/−2
- library/Hbro/Prelude.hs +0/−26
- library/Hbro/WebView/Signals.hs +28/−27
- library/Network/URI/Extended.hs +19/−14
README.rst view
@@ -2,7 +2,7 @@ hbro ==== -**In a nutshell**: *hbro* is a minimal, KISS compliant web browser for linux; it is written, configured and extensible in Haskell.+**In a nutshell**, *hbro* is a minimal web browser for linux. It is written, configured and extensible in Haskell. Information about versions, dependencies, source repositories and contacts can be found in hackage_. @@ -18,7 +18,7 @@ The application should be written with simplicity in mind, and without obsession for performance, features or release frequency. It should boot instantly, consume little memory and offer an uncluttered graphical interface. The code should be easy to grasp (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/command the web browser.+ Users should be able to implement extra features through an extension system, without digging into the internals of the application. External programs should be able to query/command the web browser. Good defaults The default behavior should be suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks.@@ -31,10 +31,10 @@ ----------------------------- Programming language : Haskell_- Modern, purely-functional language that makes it possible to work with a short, elegant and robust code.+ Modern, purely-functional language that makes it possible to work with a concise, elegant and robust code. Layout engine : WebKit_- Has to be open-source, be (kind of) standards-compliant, and provide a Haskell binding. WebKit is pretty much the only choice left.+ Has to be open-source, be (kind of) standards-compliant, and provide a Haskell binding. Considering those requirements, WebKit is pretty much the only game in town. HTTP client : WebKit_ Ideally, the HTTP client should be delegated to a distinct library (typically http-conduit_), but WebKit clearly wasn't designed to be used as a *mere* layout engine. So for now, it still handles all network connections.@@ -43,7 +43,7 @@ Given the 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.+ Socket-like interface that implements various communication schemes like request-reply and publish-subscribe. Configuration system : Dyre_ Dynamic reconfiguration library for haskell programs.@@ -52,8 +52,8 @@ Suggestions about better alternatives for any of these points (except the programming language) are welcome. -Installation-------------+Installation notes+------------------ Up until GHC 7.8, *hbro* requires the *integer-simple* package, which means you won't be able to build it using a standard GHC installation that uses the *integer-gmp* package. This distinction is `documented here`_, and the reason for this constraint is `explained there`_. @@ -63,7 +63,7 @@ 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 commented configuration file example.+By default, a minimal configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.hbro/hbro.hs`` to override it. Several extensions are provided with the * hbro-contrib_ * package, including a commented configuration file example. GUI layout@@ -72,8 +72,8 @@ The graphical layout is described in an XML file that is parsed by GtkBuilder_. This file is looked for in several places with the following order of priority: - the value from commandline option ``-U``;-- the file ``~/.config/hbro/ui.xml``;-- the file ``examples/ui.xml`` bundled with the package.+- the ``~/.hbro/ui.xml`` file;+- the ``examples/ui.xml`` file bundled with the package. At least the following widgets must be defined, with the adequate ``id`` attributes, for the browser to start:
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 1.3.0.0+Version: 1.4.0.0 Synopsis: Minimal extensible web-browser Description: Cf README Homepage: https://github.com/k0ral/hbro@@ -25,13 +25,16 @@ aeson, base == 4.*, bytestring,- classy-prelude >= 0.9.4,+ classy-prelude >= 0.12, cond, containers, data-default-class,+ directory, dyre >= 0.8.8, errors,+ exceptions, fast-logger,+ filepath, glib, gtk3 >= 0.13, -- http-conduit,@@ -48,14 +51,13 @@ pango, parsec, process,- resourcet,+ resourcet >= 1.1.5, safe, semigroups, stm-chans,- system-fileio, text, -- text-icu,- time,+ time >= 1.5, transformers, transformers-base, unix,@@ -66,40 +68,39 @@ Exposed-modules: Control.Monad.Logger.Extended- , Control.Monad.Reader.Extended- , Graphics.Rendering.Pango.Extended- , Graphics.UI.Gtk.General.General.Extended- , Hbro- , Hbro.Boot- , Hbro.Clipboard- , Hbro.Config- , Hbro.Core- , Hbro.Defaults- , Hbro.Error- , Hbro.Event- , Hbro.Gdk.KeyVal- , Hbro.Gui.Builder- , Hbro.Gui.MainView- , Hbro.Gui.NotificationBar- , Hbro.Gui.PromptBar- , Hbro.Gui.StatusBar- , Hbro.IPC- , Hbro.Keys- , Hbro.Keys.Model- , Hbro.Logger- , Hbro.Prelude- , Hbro.WebView.Signals- , Network.URI.Extended- , System.Glib.Attributes.Extended- , System.Process.Extended+ Control.Monad.Reader.Extended+ Graphics.Rendering.Pango.Extended+ Graphics.UI.Gtk.General.General.Extended+ Hbro+ Hbro.Boot+ Hbro.Clipboard+ Hbro.Config+ Hbro.Core+ Hbro.Defaults+ Hbro.Error+ Hbro.Event+ Hbro.Gdk.KeyVal+ Hbro.Gui.Builder+ Hbro.Gui.MainView+ Hbro.Gui.NotificationBar+ Hbro.Gui.PromptBar+ Hbro.Gui.StatusBar+ Hbro.IPC+ Hbro.Keys+ Hbro.Keys.Model+ Hbro.Logger+ Hbro.Prelude+ Hbro.WebView.Signals+ Network.URI.Extended+ System.Glib.Attributes.Extended+ System.Process.Extended Other-modules:- Graphics.UI.Gtk.WebKit.Lifted- , Graphics.UI.Gtk.WebKit.Lifted.WebView- -- , Hbro.CFunctions- , Hbro.Dyre- , Hbro.Gui- , Hbro.Options- , Paths_hbro+ Graphics.UI.Gtk.WebKit.Extended+ -- Hbro.CFunctions+ Hbro.Dyre+ Hbro.Gui+ Hbro.Options+ Paths_hbro -- Build-tools: hsc2hs -- C-sources: cbits/cbits.c -- Include-dirs: include@@ -114,7 +115,7 @@ Executable hbro Build-depends:- hbro >= 1.2.0.0,+ hbro >= 1.3.0.0, base == 4.* Main-is: Main.hs Hs-Source-Dirs: executable
+ library/Graphics/UI/Gtk/WebKit/Extended.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Some lifted functions from 'Graphics.UI.Gtk.WebKit'.+-- Designed to be imported as @qualified@.+module Graphics.UI.Gtk.WebKit.Extended+ ( -- * 'NetworkRequest'+ networkRequestGetUri+ -- * 'Download'+ , downloadGetUri+ -- * 'NetworkRequest'+ , downloadGetSuggestedFilename+ -- * 'WebDataSource'+ , dataSourceGetData+ -- * 'WebView'+ , webViewUri+ , webViewGetUri+ , webViewGetIconUri+ , webViewTryGetFaviconPixbuf+ , webViewGetTitle+ , loadHtmlString+ , loadString+ -- * Exceptions+ , WebKitException(..)+ -- * Re-export+ , module X+ ) where++-- {{{ Imports+import Hbro.Error+import Hbro.Prelude++import Graphics.UI.Gtk.Gdk.Pixbuf+import Graphics.UI.Gtk.General.General.Extended+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.WebDataSource as W+import Graphics.UI.Gtk.WebKit.WebView as X hiding (webViewGetIconUri,+ webViewGetTitle,+ webViewGetUri, webViewTryGetFaviconPixbuf,+ webViewUri)+import qualified Graphics.UI.Gtk.WebKit.WebView as W++import Network.URI.Extended++import System.Glib.Attributes+-- }}}++networkRequestGetUri :: (MonadIO m, MonadThrow m) => NetworkRequest -> m URI+networkRequestGetUri r = parseURIReference =<< io (W.networkRequestGetUri r) <!> UnavailableUri++downloadGetUri :: (MonadIO m, MonadThrow m) => W.Download -> m URI+downloadGetUri d = parseURI =<< io (W.downloadGetUri d) <!> UnavailableUri++downloadGetSuggestedFilename :: (MonadIO m, MonadThrow m) => W.Download -> m Text+downloadGetSuggestedFilename d = io (W.downloadGetSuggestedFilename d) <!> UnavailableFileName++dataSourceGetData :: (MonadIO m, MonadThrow m) => WebDataSource -> m ByteString+dataSourceGetData ds = io (webDataSourceGetData ds) <!> UnavailableData+++-- | 'W.webViewUri' with 'Text'+webViewUri :: ReadAttr WebView (Maybe Text)+webViewUri = W.webViewUri++webViewGetUri :: (MonadIO m, MonadThrow m) => WebView -> m URI+webViewGetUri = gSync . W.webViewGetUri >=> maybe (throwM UnavailableUri) return >=> parseURI++webViewGetIconUri :: (MonadIO m, MonadThrow m) => WebView -> m URI+webViewGetIconUri = gSync . W.webViewGetIconUri >=> maybe (throwM UnavailableUri) return >=> parseURI++webViewTryGetFaviconPixbuf :: (MonadIO m, MonadThrow m) => WebView -> Int -> Int -> m Pixbuf+webViewTryGetFaviconPixbuf webView width height = gSync (W.webViewTryGetFaviconPixbuf webView width height) >>= maybe (throwM UnavailableFavicon) return++webViewGetTitle :: (MonadIO m, MonadThrow m) => WebView -> m Text+webViewGetTitle = gSync . W.webViewGetTitle >=> maybe (throwM UnavailableTitle) return++loadHtmlString :: (MonadIO m) => Text -> URI -> WebView -> m ()+loadHtmlString html uri webView = gAsync $ W.webViewLoadHtmlString webView html (tshow uri)++loadString :: (MonadIO m) => Text -> URI -> WebView -> m ()+loadString html uri webView = gAsync $ W.webViewLoadString webView html Nothing (tshow uri)+++data WebKitException = UnavailableData+ | UnavailableFavicon+ | UnavailableFileName+ | UnavailableTitle+ | UnavailableUri+ deriving(Eq)++instance Exception WebKitException++instance Show WebKitException where+ show UnavailableData = "No data available in the web frame."+ show UnavailableFavicon = "No available favicon."+ show UnavailableFileName = "No file name available."+ show UnavailableTitle = "No available title."+ show UnavailableUri = "No URI available."
− library/Graphics/UI/Gtk/WebKit/Lifted.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--- | Some lifted functions from 'Graphics.UI.Gtk.WebKit'.--- Designed to be imported as @qualified@.-module Graphics.UI.Gtk.WebKit.Lifted (--- * 'NetworkRequest'- networkRequestGetUri,--- * 'Download'- downloadGetUri,--- * 'NetworkRequest'- downloadGetSuggestedFilename,--- * 'WebDataSource'- dataSourceGetData- ) where---- {{{ Imports-import Hbro.Error-import Hbro.Prelude--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.WebDataSource as W--import Network.URI.Extended--- }}}---- | Error message-unavailableData, unavailableFileName, unavailableURI :: Text-unavailableData = "No data available in the web frame."-unavailableFileName = "No file name available"-unavailableURI = "No URI available"--networkRequestGetUri :: (MonadIO m, MonadError Text m) => NetworkRequest -> m URI-networkRequestGetUri r = parseURIReferenceM =<< io (W.networkRequestGetUri r) <!> unavailableURI--downloadGetUri :: (MonadIO m, MonadError Text m) => W.Download -> m URI-downloadGetUri d = parseURIM =<< io (W.downloadGetUri d) <!> unavailableURI--downloadGetSuggestedFilename :: (MonadIO m, MonadError Text m) => W.Download -> m Text-downloadGetSuggestedFilename d = io (W.downloadGetSuggestedFilename d) <!> unavailableFileName--dataSourceGetData :: (MonadIO m, MonadError Text m) => WebDataSource -> m ByteString-dataSourceGetData ds = io (webDataSourceGetData ds) <!> unavailableData
− library/Graphics/UI/Gtk/WebKit/Lifted/WebView.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--- | Some lifted functions from 'Graphics.UI.Gtk.WebKit.WebView'.--- Designed to be imported as @qualified@.-module Graphics.UI.Gtk.WebKit.Lifted.WebView- ( webViewUri- , webViewGetUri- , webViewGetIconUri- , webViewTryGetFaviconPixbuf- , webViewGetTitle- , loadHtmlString- , loadString- , module Export- ) where---- {{{ Imports-import Hbro.Error-import Hbro.Prelude--import Graphics.UI.Gtk.Gdk.Pixbuf-import Graphics.UI.Gtk.General.General.Extended-import Graphics.UI.Gtk.WebKit.WebView as Export hiding (webViewGetIconUri, webViewGetTitle, webViewGetUri, webViewTryGetFaviconPixbuf,- webViewUri)-import qualified Graphics.UI.Gtk.WebKit.WebView as W--import System.Glib.Attributes--import Network.URI.Extended--- }}}---- | Error message-unavailableFavicon, unavailableURI, titleUnavailable :: Text-unavailableFavicon = "No available favicon."-unavailableURI = "No available URI."-titleUnavailable = "No available title."---- | 'W.webViewUri' with 'Text'-webViewUri :: ReadAttr WebView (Maybe Text)-webViewUri = W.webViewUri--webViewGetUri :: (MonadIO m, MonadError Text m) => WebView -> m URI-webViewGetUri = gSync . W.webViewGetUri >=> maybe (throwError unavailableURI) return >=> parseURIM--webViewGetIconUri :: (MonadIO m, MonadError Text m) => WebView -> m URI-webViewGetIconUri = gSync . W.webViewGetIconUri >=> maybe (throwError unavailableURI) return >=> parseURIM--webViewTryGetFaviconPixbuf :: (MonadIO m, MonadError Text m) => WebView -> Int -> Int -> m Pixbuf-webViewTryGetFaviconPixbuf webView width height = gSync (W.webViewTryGetFaviconPixbuf webView width height) >>= maybe (throwError unavailableFavicon) return--webViewGetTitle :: (MonadIO m, MonadError Text m) => WebView -> m Text-webViewGetTitle = gSync . W.webViewGetTitle >=> maybe (throwError titleUnavailable) return--loadHtmlString :: (MonadIO m) => Text -> URI -> WebView -> m ()-loadHtmlString html uri webView = gAsync $ W.webViewLoadHtmlString webView html (tshow uri)--loadString :: (MonadIO m) => Text -> URI -> WebView -> m ()-loadString html uri webView = gAsync $ W.webViewLoadString webView html Nothing (tshow uri)
library/Hbro/Boot.hs view
@@ -11,7 +11,6 @@ import Hbro.Core as Core import Hbro.Defaults import Hbro.Dyre as Dyre-import Hbro.Error import Hbro.Event import Hbro.Gui as Gui import Hbro.Gui.MainView@@ -28,14 +27,14 @@ import Data.Version hiding (Version) -import Filesystem- import Graphics.UI.Gtk.General.General as Gtk import Network.URI.Extended import qualified Paths_hbro as Package +import System.Directory+import System.Info import System.Posix.Process import System.Posix.Signals import qualified System.ZMQ4 as ZMQ (version)@@ -44,9 +43,9 @@ -- | What users can configure. data Settings = Settings { configuration :: Config- , commandMap :: forall m r . God r m => CommandMap m- , keyMap :: forall m r . God r m => KeyMap m- , startUp :: forall m r . God r m => m ()+ , commandMap :: forall m r . (God r m, MonadCatch m) => CommandMap m+ , keyMap :: forall m r . (God r m, MonadCatch m) => KeyMap m+ , startUp :: forall m r . (God r m, MonadCatch m) => m () } instance Default Settings where@@ -57,8 +56,9 @@ , startUp = debug "No start-up script defined" } + getDataFileName :: (MonadIO m, Functor m) => Text -> m FilePath-getDataFileName file = fpFromText . pack <$> io (Package.getDataFileName $ unpack file)+getDataFileName file = io (Package.getDataFileName $ unpack file) -- | Main function to call in the configuration file. Cf @Hbro/Main.hs@ as an example. hbro :: Settings -> IO ()@@ -84,9 +84,9 @@ logInterrupt = putStrLn "Received interrupt signal." -mainThread :: (ControlIO m, MonadThrow m, MonadThreadedLogger m, MonadResource m)+mainThread :: (ControlIO m, MonadCatch m, MonadThreadedLogger m, Alternative m, MonadResource m) => (Settings, CliOptions) -> Async () -> m ()-mainThread (settings, options) uiThread = void . runExceptT . logErrors $ do+mainThread (settings, options) uiThread = logErrors_ $ do uiFiles <- getUIFiles options (builder, mainView, promptBar, statusBar, notifBar) <- asum $ map Gui.initialize uiFiles @@ -122,7 +122,7 @@ -- | Return the list of available UI files (from configuration and package) getUIFiles :: (MonadIO m, Functor m) => CliOptions -> m [FilePath] getUIFiles options = do- fileFromConfig <- getAppConfigDirectory "hbro" >/> "ui.xml"+ fileFromConfig <- getAppUserDataDirectory "hbro" >/> "ui.xml" fileFromPackage <- getDataFileName "examples/ui.xml" return $ catMaybes [options^.uiFileL, Just fileFromConfig, Just fileFromPackage] @@ -130,24 +130,25 @@ getSocketURI :: (MonadIO m, Functor m) => CliOptions -> m Text getSocketURI options = maybe getDefaultSocketURI (return . normalize) $ options^.socketPathL where- normalize = ("ipc://" ++) . fpToText+ normalize = ("ipc://" ++) . pack getDefaultSocketURI = do- dir <- fpToText <$> io (getAppCacheDirectory "hbro")+ dir <- pack <$> io getTemporaryDirectory pid <- io getProcessID return $ "ipc://" ++ dir ++ "/hbro." ++ tshow pid -- | Parse 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 :: (MonadIO m, MonadError Text m) => URI -> m URI+getStartURI :: (MonadIO m, MonadThrow m) => URI -> m URI getStartURI uri = do- fileURI <- io . isFile . fpFromText $ tshow uri- workingDir <- io getWorkingDirectory+ fileURI <- io . doesFileExist $ show uri+ workingDir <- pack <$> io getCurrentDirectory - parseURIReferenceM ("file://" ++ fpToText workingDir ++ "/" ++ tshow uri) <| fileURI |> return uri+ parseURIReference ("file://" ++ workingDir ++ "/" ++ tshow uri) <| fileURI |> return uri -- maybe abort return =<< logErrors (parseURIReference fileURI') printVersions :: IO () printVersions = do (a, b, c) <- ZMQ.version- putStrLn $ "hbro v" ++ pack (showVersion Package.version)- putStrLn $ "0MQ library v" ++ intercalate "." (map tshow [a, b, c])+ putStrLn $ "hbro-" ++ pack (showVersion Package.version)+ putStrLn $ "compiled by " ++ pack compilerName ++ "-" ++ pack (showVersion compilerVersion)+ putStrLn $ "using zeromq-" ++ intercalate "." (map tshow [a, b, c])
library/Hbro/Clipboard.hs view
@@ -16,6 +16,14 @@ -- }}} +data ClipboardException = EmptyClipboard SelectionTag deriving(Eq)++instance Exception ClipboardException++instance Show ClipboardException where+ show (EmptyClipboard tag) = "Empty clipboard [" ++ show tag ++ "]"++ -- | Write given 'Text' to the selection-primary clipboard write :: (BaseIO m, MonadLogger m) => Text -> m () write = write' selectionPrimary@@ -27,15 +35,15 @@ gSync (clipboardGet tag) >>= gAsync . (`clipboardSetText` text) -- | Read clipboard's content. Both 'selectionPrimary' and 'selectionClipboard' are inspected (in this order).-read :: (BaseIO m, Alternative m, MonadError Text m) => m Text+read :: (BaseIO m, Alternative m, MonadThrow m) => m Text read = read' selectionPrimary <|> read' selectionClipboard -- | Return the content from the given clipboard.-read' :: (Alternative m, MonadError Text m, BaseIO m) => SelectionTag -> m Text+read' :: (Alternative m, MonadThrow m, BaseIO m) => SelectionTag -> m Text read' tag = do clipboard <- gSync $ clipboardGet tag result <- newEmptyMVar gAsync . clipboardRequestText clipboard $ putMVar result - takeMVar result <!> ("Empty clipboard [" ++ tshow tag ++ "]")+ takeMVar result <!> EmptyClipboard tag
library/Hbro/Core.hs view
@@ -37,12 +37,10 @@ ) where -- {{{ Imports-import Graphics.UI.Gtk.WebKit.Lifted-import Graphics.UI.Gtk.WebKit.Lifted.WebView+import Graphics.UI.Gtk.WebKit.Extended import Hbro.Config as Config import Hbro.Dyre-import Hbro.Error -- import Hbro.Gui as Gui import Hbro.Gui.MainView import Hbro.Logger@@ -81,31 +79,31 @@ -- }}} -- {{{ Getters-getCurrentURI :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m URI+getCurrentURI :: (MonadIO m, MonadReader r m, Has MainView r, MonadThrow m) => m URI getCurrentURI = webViewGetUri =<< getWebView -getFaviconURI :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m URI+getFaviconURI :: (MonadIO m, MonadReader r m, Has MainView r, MonadThrow m) => m URI getFaviconURI = webViewGetIconUri =<< getWebView -getFavicon :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => Int -> Int -> m Pixbuf+getFavicon :: (MonadIO m, MonadReader r m, Has MainView r, MonadThrow m) => Int -> Int -> m Pixbuf getFavicon w h = (\v -> webViewTryGetFaviconPixbuf v w h) =<< getWebView getLoadProgress :: (MonadIO m, MonadReader r m, Has MainView r) => m Double getLoadProgress = gSync . webViewGetProgress =<< getWebView -getPageTitle :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m Text+getPageTitle :: (MonadIO m, MonadReader r m, Has MainView r, MonadThrow m) => m Text getPageTitle = webViewGetTitle =<< getWebView -- | Return the HTML code of the current webpage.-getPageData :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m ByteString+getPageData :: (MonadIO m, MonadReader r m, Has MainView r, MonadThrow m) => m ByteString getPageData = dataSourceGetData =<< io . webFrameGetDataSource =<< io . webViewGetMainFrame =<< getWebView -- }}} -- {{{ Browsing-goHome :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, Has (TVar Config) r, MonadError Text m) => m ()+goHome :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, Has (TVar Config) r, MonadThrow m) => m () goHome = load =<< Config.get homePageL -load :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m) => URI -> m ()+load :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m) => URI -> m () load uri = do debug $ "Loading URI: " ++ tshow uri -- void . logErrors $ do@@ -126,7 +124,7 @@ -- } --- load' :: (MonadBaseControl IO m, MonadReader GUI m, HasHTTPClient t, MonadError Text m) => URI -> m ()+-- load' :: (MonadBaseControl IO m, MonadReader GUI m, HasHTTPClient t, MonadThrow m) => URI -> m () -- load' uri = do -- page <- Client.retrieve uri -- -- render page =<< Client.getURI@@ -169,13 +167,13 @@ spawnHbro :: (MonadIO m, MonadLogger m) => m () spawnHbro = do executable <- getHbroExecutable- spawn (fpToText executable) []+ spawn (pack executable) [] -- | Spawn another browser instance and load the given URI at start-up. spawnHbro' :: (MonadIO m, MonadLogger m) => URI -> m () spawnHbro' uri = do executable <- getHbroExecutable- spawn (fpToText executable) ["-u", tshow uri]+ spawn (pack executable) ["-u", tshow uri] -- | Terminate the program. quit :: (MonadIO m) => m ()@@ -183,13 +181,13 @@ -- {{{ Misc-saveWebPage :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m) => FilePath -> m ()-saveWebPage file = writeFileE' file =<< getPageData+saveWebPage :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m) => FilePath -> m ()+saveWebPage file = writeFile file =<< getPageData -- | Execute a javascript file on current webpage. executeJSFile :: (MonadIO m, MonadLogger m) => FilePath -> WebView -> m () executeJSFile filePath webView' = do- debug $ "Executing Javascript file: " ++ fpToText filePath+ debug $ "Executing Javascript file: " ++ pack filePath script <- readFile filePath let script' = asText . unwords . map (++ "\n") . lines $ script
library/Hbro/Defaults.hs view
@@ -11,7 +11,6 @@ import Hbro.Clipboard as Clipboard import Hbro.Config (Config) import Hbro.Core-import Hbro.Error import Hbro.Event import Hbro.Gdk.KeyVal import Hbro.Gui as Gui@@ -43,21 +42,23 @@ import System.Glib.Attributes.Extended -- }}} --- | A 'God' monad has access to everything.-type God r m = (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m, MonadReader r m, Has (TVar Config) r, Has PromptBar r, Has NotificationBar r, Has StatusBar r, Has Gtk.Builder r, Has (Signal KeyMapPressed) r, Has MainView r, Alternative m)+-- | A 'God' monad has access to everything, and obviously never throws errors.+type God r m = (ControlIO m, MonadLogger m, MonadResource m, MonadReader r m, Has (TVar Config) r, Has PromptBar r, Has NotificationBar r, Has StatusBar r, Has Gtk.Builder r, Has (Signal KeyMapPressed) r, Has MainView r, Alternative m) -defaultLinkClickedHandler :: (MonadIO m, MonadLogger m, MonadError Text m, MonadReader r m, Has MainView r)+defaultLinkClickedHandler :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader r m, Has MainView r) => Handler m LinkClicked defaultLinkClickedHandler (uri, Gtk.MiddleButton) = spawnHbro' uri defaultLinkClickedHandler (uri, _) = load uri -defaultLoadRequestedHandler :: (MonadIO m, MonadLogger m, MonadError Text m, MonadReader r m, Has MainView r) => URI -> m ()+defaultLoadRequestedHandler :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader r m, Has MainView r)+ => URI -> m () defaultLoadRequestedHandler = load defaultNewWindowHandler :: (MonadIO m, MonadLogger m) => URI -> m ()-defaultNewWindowHandler uri = spawnHbro' uri+defaultNewWindowHandler = spawnHbro' -defaultTitleChangedHandler :: (MonadIO m, MonadLogger m, MonadError Text m, MonadReader r m, Has Gtk.Builder r) => Text -> m ()+defaultTitleChangedHandler :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader r m, Has Gtk.Builder r)+ => Text -> m () defaultTitleChangedHandler title = getMainWindow >>= \w -> set w windowTitle ("hbro | " ++ title) >> return () -- /!\ NetworkRequest's Haskell binding is missing the function "webkit_network_request_get_message", which makes it rather useless...@@ -68,7 +69,7 @@ -- | List of default supported requests.-defaultCommandMap :: God r m => CommandMap m+defaultCommandMap :: (God r m, MonadCatch m) => CommandMap m defaultCommandMap = Map.fromList -- Get information [ "GET_URI" >: \_arguments -> Right . tshow <$> getCurrentURI@@ -77,7 +78,7 @@ , "GET_LOAD_PROGRESS" >: \_arguments -> Right . tshow <$> getLoadProgress -- Trigger actions , "LOAD_URI" >: \arguments -> case arguments of- uri:_ -> parseURIReferenceM uri >>= load >> return (Right "OK")+ uri:_ -> parseURIReference uri >>= load >> return (Right "OK") _ -> return . Left $ "Argument needed." , "STOP_LOADING" >: \_arguments -> stopLoading >> return (Right "OK") , "RELOAD" >: \_arguments -> reload >> return (Right "OK")@@ -89,7 +90,7 @@ ] -defaultKeyMap :: (God r m) => KeyMap m+defaultKeyMap :: (God r m, MonadCatch m) => KeyMap m defaultKeyMap = Map.fromList -- Browse [ [_Alt .| _Left] >: goBack@@ -107,8 +108,8 @@ -- Copy/paste , [_Control .| _c] >: getCurrentURI >>= Clipboard.write . tshow , [_Alt .| _c] >: getPageTitle >>= Clipboard.write- , [_Control .| _v] >: Clipboard.read >>= parseURIReferenceM >>= load- , [_Alt .| _v] >: Clipboard.read >>= parseURIReferenceM >>= spawnHbro'+ , [_Control .| _v] >: Clipboard.read >>= parseURIReference >>= load+ , [_Alt .| _v] >: Clipboard.read >>= parseURIReference >>= spawnHbro' -- Display , [_Control .| _plus] >: zoomIn , [_Control .| _minus] >: zoomOut@@ -127,7 +128,7 @@ , [_Control .| _h] >: gAsync . webViewUnMarkTextMatches =<< getWebView -- Misc --, (_Control .| _i) >: openInspector- , [_Control .| _s] >: promptM "Save webpage " "" >>= saveWebPage . fpFromText+ , [_Control .| _s] >: promptM "Save webpage " "" >>= saveWebPage . unpack , [_Alt .| _Print] >: printPage , [_Control .| _t] >: spawnHbro , [_Control .| _w] >: quit
library/Hbro/Dyre.hs view
@@ -19,6 +19,8 @@ import Config.Dyre import Config.Dyre.Compile import Config.Dyre.Paths++import System.Directory -- }}} -- | How dynamic reconfiguration process should behave.@@ -43,10 +45,11 @@ getHbroExecutable :: (MonadIO m) => m FilePath getHbroExecutable = io $ do (a, _, _, _, _) <- getPaths baseParameters- return . fpFromText $ pack a+ return a -- Dynamic reconfiguration settings-parameters :: (Functor m, MonadIO m, MonadLogger m, StM m () ~ ()) => (RunInBase m IO) -> Mode -> (a -> m b) -> Params (Either Text a)+parameters :: (Functor m, MonadIO m, MonadLogger m, StM m () ~ ())+ => RunInBase m IO -> Mode -> (a -> m b) -> Params (Either Text a) parameters runInIO mode main = baseParameters { configCheck = mode /= Vanilla , realMain = runInIO . main'@@ -63,6 +66,7 @@ , ghcOpts = ["-threaded"] , statusOut = hPutStrLn stderr , includeCurrentDirectory = False+ , configDir = Just $ getAppUserDataDirectory "hbro" } wrap :: (ControlIO m, MonadLogger m, StM m () ~ ()) => Mode -> (a -> m b) -> a -> m ()
library/Hbro/Error.hs view
@@ -6,36 +6,13 @@ -- {{{ Imports import Hbro.Prelude -import Control.Error.Safe-import Control.Error.Util as X (hush, note)-import Control.Monad.Except as X (ExceptT, MonadError (..),- runExceptT)--- }}}---- {{{ Fail--- | 'MonadError' with trivial error.-type MonadFail m = MonadError () m---- | 'throwError' for 'MonadFail'.-die :: MonadFail m => m a-die = throwError ()---- | 'runErrorT' with trivial error.-runFailT :: (Monad m) => ExceptT () m a -> m (Maybe a)-runFailT = return . rightMay <=< runExceptT---- | Lift a 'Maybe' value into a 'MonadFail' computation-liftMaybe :: (MonadFail m) => Maybe a -> m a-liftMaybe = maybe (throwError ()) return+import Control.Error.Util as X (hush, note)+import Control.Monad.Catch () -- }}} --- | Lift an 'Either' value into a 'MonadError' computation-liftEither :: (MonadError e m) => Either e a -> m a-liftEither = either throwError return--failWith :: (MonadError e m) => Maybe a -> e -> m a-failWith x e = either throwError return $ note e x+failWith :: (MonadThrow m, Exception e) => Maybe a -> e -> m a+failWith x e = maybe (throwM e) return x -- | Monadic and infix version of 'failWith'-(<!>) :: (MonadError e m) => m (Maybe a) -> e -> m a+(<!>) :: (MonadThrow m, Exception e) => m (Maybe a) -> e -> m a (<!>) f e = f >>= (`failWith` e)
library/Hbro/Event.hs view
@@ -82,14 +82,14 @@ listenTo (Signal _ signal _) = io . async . waitFor =<< atomically (dupTMChan signal) -- | Execute a function each time an event occurs.-addHandler :: (Event a, ControlIO m, MonadResource m) => Signal a -> (Handler m a) -> m ReleaseKey+addHandler :: (Event a, ControlIO m, MonadResource m) => Signal a -> Handler m a -> m ReleaseKey addHandler (Signal _ s handlers) f = do signal <- atomically $ dupTMChan s result <- liftBaseWith $ \runInIO -> do runInIO . flip allocate cancel . async . fix $ \recurse ->- waitFor signal >>= mapM_ (\x -> (runInIO $ f x) >> recurse)- (releaseKey, (_ :: Async ())) <- restoreM result+ waitFor signal >>= mapM_ (\x -> runInIO (f x) >> recurse)+ (releaseKey, _ :: Async ()) <- restoreM result atomically $ modifyTVar handlers (releaseKey:) return releaseKey@@ -102,11 +102,11 @@ result <- liftBaseWith $ \runInIO -> runInIO . flip allocate cancel . async . void . runInIO . flip fix init $ \recurse acc -> waitFor signal >>= mapM_ (f acc >=> recurse)- (releaseKey, (_ :: Async ())) <- restoreM result+ (releaseKey, _ :: Async ()) <- restoreM result atomically $ modifyTVar handlers (releaseKey:) return releaseKey -- | Stop all handlers associated to the given signal. deleteHandlers :: (Event e, MonadIO m, MonadResource m) => Signal e -> m ()-deleteHandlers (Signal _ _ handlers) = void . sequence . map release =<< atomically (readTVar handlers)+deleteHandlers (Signal _ _ handlers) = void . mapM release =<< atomically (readTVar handlers)
library/Hbro/Gui.hs view
@@ -13,9 +13,8 @@ ) where -- {{{ Imports-import Graphics.UI.Gtk.WebKit.Lifted.WebView ()+import Graphics.UI.Gtk.WebKit.Extended () -import Hbro.Error as Hbro import Hbro.Event import Hbro.Gui.Builder import Hbro.Gui.MainView hiding (initialize)@@ -40,9 +39,9 @@ import System.Glib.Signals hiding (Signal) -- }}} -initialize :: (ControlIO m, Alternative m, MonadError Text m, MonadThreadedLogger m, MonadResource m)+initialize :: (ControlIO m, Alternative m, MonadCatch m, MonadThreadedLogger m, MonadResource m) => FilePath -> m (Gtk.Builder, MainView, PromptBar, StatusBar, NotificationBar)-initialize (fpToText -> file) = do+initialize (pack -> file) = do debug $ "Building GUI from " ++ file builder <- gSync Gtk.builderNew gSync . Gtk.builderAddFromFile builder $ unpack file
library/Hbro/Gui/MainView.hs view
@@ -60,8 +60,9 @@ import qualified Graphics.UI.Gtk.Misc.Adjustment as Gtk import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.DOM.Document-import Graphics.UI.Gtk.WebKit.Lifted.WebView hiding- (LoadStatus (..))+import Graphics.UI.Gtk.WebKit.Extended hiding+ (LoadStatus (..),+ networkRequestGetUri) import Graphics.UI.Gtk.WebKit.NetworkRequest import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebSettings@@ -148,7 +149,7 @@ <*> newSignal ZoomLevelChanged -initialize :: (ControlIO m, MonadLogger m) => MainView -> m MainView+initialize :: (ControlIO m, MonadCatch m, MonadLogger m) => MainView -> m MainView initialize mainView = do set webView widgetCanDefault True -- set webView webViewSetMaintainsBackForwardList False@@ -236,7 +237,7 @@ set s webSettingsEnablePageCache True set s webSettingsEnablePlugins False set s webSettingsEnablePrivateBrowsing False- set s webSettingsEnableScripts False+ set s webSettingsEnableScripts True set s webSettingsEnableSpellChecking False set s webSettingsEnableSpatialNavigation False set s webSettingsEnableUniversalAccessFromFileUris True
library/Hbro/Gui/NotificationBar.hs view
@@ -10,11 +10,12 @@ ) where -- {{{ Imports-import Hbro.Error import Hbro.Gui.Builder import Hbro.Logger import Hbro.Prelude +import Control.Monad.Trans.Maybe+ import Graphics.Rendering.Pango.Extended import Graphics.UI.Gtk.Abstract.Misc import Graphics.UI.Gtk.Abstract.Widget@@ -51,7 +52,7 @@ initialize :: (ControlIO m, MonadThreadedLogger m) => NotificationBar -> m NotificationBar initialize notifBar = do- addLogHandler $ \(_loc, _source, level, message) -> void . runFailT $ do+ addLogHandler $ \(_loc, _source, level, message) -> void . runMaybeT $ do guard $ level >= LevelInfo write' message (logColor level) notifBar return notifBar
library/Hbro/Gui/PromptBar.hs view
@@ -17,6 +17,7 @@ , labelName , entryName , boxName+ , PromptException(..) -- * Functions , initialize , close@@ -44,6 +45,7 @@ import Control.Concurrent.Async.Lifted import Control.Lens.Getter import Control.Lens.TH+import Control.Monad.Trans.Maybe import Control.Monad.Trans.Resource import Graphics.Rendering.Pango.Extended@@ -88,6 +90,13 @@ , validatedL :: Signal Validated } |]++data PromptException = PromptInterrupted deriving(Eq)++instance Exception PromptException++instance Show PromptException where+ show PromptInterrupted = "Prompt interrupted." -- }}} -- | A 'PromptBar' can be built from an XML file.@@ -117,10 +126,6 @@ entryName = "promptEntry" boxName = "promptBox" --- | Error message-promptInterrupted :: Text-promptInterrupted = "Prompt interrupted."- initialize :: (MonadIO m) => PromptBar -> m PromptBar initialize = withM_ descriptionL (gAsync . (`labelSetAttributes` [allItalic, allBold]))@@ -139,7 +144,7 @@ close :: (ControlIO m, MonadLogger m) => PromptBar -> m PromptBar close promptBar = do- runFailT $ do+ runMaybeT $ do guard =<< get (promptBar^.boxL) widgetVisible emit (promptBar^.closedL) () gAsync . widgetHide $ promptBar^.boxL@@ -155,7 +160,7 @@ -- {{{ Prompts -- | Open prompt bar with given description and default value, -- register a callback to trigger when value is changed, and another one when value is validated.-prompt :: (ControlIO m, MonadLogger m, MonadError Text m)+prompt :: (ControlIO m, MonadLogger m, MonadThrow m) => Text -- ^ Prompt description -> Text -- ^ Pre-fill value -> PromptBar@@ -169,13 +174,14 @@ result <- io $ waitEitherCancel cancelation validation close promptBar- maybe (throwError promptInterrupted) return . join $ hush result+ maybe (throwM PromptInterrupted) return . join $ hush result -promptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadError Text m) => Text -> Text -> m Text+promptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadThrow m)+ => Text -> Text -> m Text promptM a b = prompt a b =<< ask -iprompt :: (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m)+iprompt :: (ControlIO m, MonadLogger m, MonadThrow m, MonadResource m) => Text -> Text -> (Text -> m ())@@ -191,12 +197,13 @@ close promptBar release update -ipromptM :: (ControlIO m, MonadResource m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadError Text m) => Text -> Text -> (Text -> m ()) -> m ()+ipromptM :: (ControlIO m, MonadResource m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadThrow m)+ => Text -> Text -> (Text -> m ()) -> m () ipromptM a b c = iprompt a b c =<< ask -- | Same as 'prompt' for URI values-uriPrompt :: (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m)+uriPrompt :: (ControlIO m, MonadLogger m, MonadThrow m, MonadResource m) => Text -> Text -> PromptBar@@ -213,10 +220,10 @@ result <- io $ waitEitherCancel cancelation validation release update close promptBar- parseURIReferenceM =<< maybe (throwError promptInterrupted) return (join $ hush result)+ parseURIReference =<< maybe (throwM PromptInterrupted) return (join $ hush result) -uriPromptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadError Text m, MonadResource m)+uriPromptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadThrow m, MonadResource m) => Text -> Text -> m URI uriPromptM a b = uriPrompt a b =<< ask
library/Hbro/Keys.hs view
@@ -28,7 +28,6 @@ ) where -- {{{ Imports-import Hbro.Error import Hbro.Event import Hbro.Gdk.KeyVal import Hbro.Keys.Model ((.|))@@ -121,7 +120,8 @@ describeInput _ (strokes, _bound) = Just . unwords $ "Key pressed: " : (describe <$> strokes) -bindKeys :: (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m) => Signal KeyPressed -> Signal KeyMapPressed -> KeyMap m -> m ReleaseKey+bindKeys :: (ControlIO m, MonadLogger m, MonadCatch m, MonadResource m)+ => Signal KeyPressed -> Signal KeyMapPressed -> KeyMap m -> m ReleaseKey bindKeys input output keyMap = addRecursiveHandler input empty $ \previousStrokes newStroke -> do let k = Map.keys keyMap strokes = previousStrokes |: newStroke
library/Hbro/Logger.hs view
@@ -20,13 +20,14 @@ ) where -- {{{ Imports-import Hbro.Error import Hbro.Event import Hbro.Prelude hiding (runReaderT) import Control.Monad.Base+import Control.Monad.Catch import Control.Monad.Logger.Extended as X import Control.Monad.Reader+import Control.Monad.Trans.Maybe import Control.Monad.Trans.Resource import Data.Text (justifyLeft)@@ -45,19 +46,18 @@ class (MonadLogger m) => MonadThreadedLogger m where addLogHandler :: (Input LogMessage -> IO ()) -> m () -instance (Monad m, MonadThreadedLogger m) => MonadThreadedLogger (ExceptT e m) where- addLogHandler = lift . addLogHandler- instance (Monad m, MonadThreadedLogger m) => MonadThreadedLogger (ResourceT m) where addLogHandler = lift . addLogHandler newtype ThreadedLoggingT m a = ThreadedLoggingT { unThreadedLoggingT :: ReaderT (Signal LogMessage, LogLevel) m a }+deriving instance (Alternative m) => Alternative (ThreadedLoggingT m) deriving instance (Applicative m) => Applicative (ThreadedLoggingT m) deriving instance (Functor m) => Functor (ThreadedLoggingT m) deriving instance (Monad m) => Monad (ThreadedLoggingT m) deriving instance (MonadIO m) => MonadIO (ThreadedLoggingT m) deriving instance (MonadResource m) => MonadResource (ThreadedLoggingT m) deriving instance (MonadThrow m) => MonadThrow (ThreadedLoggingT m)+deriving instance (MonadCatch m) => MonadCatch (ThreadedLoggingT m) deriving instance MonadTrans ThreadedLoggingT instance MonadBase b m => MonadBase b (ThreadedLoggingT m) where@@ -74,7 +74,7 @@ restoreM = defaultRestoreM instance (MonadIO m, Functor m) => MonadLogger (ThreadedLoggingT m) where- monadLoggerLog loc source level message = ThreadedLoggingT . void . runFailT $ do+ monadLoggerLog loc source level message = ThreadedLoggingT . void . runMaybeT $ do (loggerSignal, levelRef) <- Control.Monad.Reader.ask guard $ level >= levelRef emit' loggerSignal (loc, source, level, decodeUtf8With lenientDecode . fromLogStr $ toLogStr message)@@ -101,9 +101,9 @@ formatLevel (LevelOther a) = justifyLeft 5 ' ' . take 5 $ tshow a -- | Like 'catchError', except that the error is automatically logged, then discarded.-logErrors :: (MonadLogger m, Functor m, MonadError Text m) => m a -> m (Maybe a)-logErrors f = catchError (Just <$> f) $ \e -> error e >> return Nothing+logErrors :: (ControlIO m, MonadLogger m, MonadCatch m) => m a -> m (Maybe a)+logErrors f = catchAll (Just <$> f) $ \e -> error (tshow e) >> return Nothing -- | Like 'logErrors', but discards the result.-logErrors_ :: (MonadLogger m, Functor m, MonadError Text m) => m a -> m ()+logErrors_ :: (MonadLogger m, ControlIO m, MonadCatch m) => m a -> m () logErrors_ = void . logErrors
library/Hbro/Options.hs view
@@ -51,8 +51,8 @@ instance Describable CliOptions where describe opts = unwords $ catMaybes [ ("URI=" ++) . tshow <$> (opts^.startURIL)- , ("SOCKET=" ++) . fpToText <$> (opts^.socketPathL)- , ("UI=" ++) . fpToText <$> (opts^.uiFileL)+ , ("SOCKET=" ++) . pack <$> (opts^.socketPathL)+ , ("UI=" ++) . pack <$> (opts^.uiFileL) , Just . ("DYRE_MODE=" ++) . tshow $ opts^.dyreModeL , Just "DYRE_DEBUG" <| opts^.dyreDebugL |> Nothing , Just . ("LOG-LEVEL=" ++) . tshow $ opts^.logLevelL
library/Hbro/Prelude.hs view
@@ -19,11 +19,6 @@ , (>/>) , abort , doNothing--- * File manipulation- , readFileE- , readFileE'- , writeFileE- , writeFileE' -- * Lens util , withM , withM_@@ -44,12 +39,9 @@ (|>), (|>>)) import Control.Lens import Control.Monad.Base as X (MonadBase (..))-import Control.Monad.Except import Control.Monad.Reader.Extended as X hiding (get) import Control.Monad.Trans.Control as X -import qualified Data.ByteString as Strict-import qualified Data.ByteString.Lazy as Lazy import Data.Default.Class as X import Data.Foldable as X (asum) import Data.List as X (tail)@@ -99,24 +91,6 @@ -- | Alias for @return ()@ doNothing :: Monad m => m () doNothing = return ()--- }}}---- {{{ File manipulation--- | Lifted version of 'readFile'-readFileE :: (ControlIO m, MonadError Text m) => FilePath -> m Lazy.ByteString-readFileE = handleIO (throwError . tshow) . readFile---- | Strict version of 'readFileE'-readFileE' :: (ControlIO m, MonadError Text m) => FilePath -> m Strict.ByteString-readFileE' = handleIO (throwError . tshow) . readFile---- | Lifted version of 'writeFile'-writeFileE :: (ControlIO m, MonadError Text m) => FilePath -> Lazy.ByteString -> m ()-writeFileE f x = handleIO (throwError . tshow) $ writeFile f x---- | Strict version of 'writeFileE'-writeFileE' :: (ControlIO m, MonadError Text m) => FilePath -> Strict.ByteString -> m ()-writeFileE' f x = handleIO (throwError . tshow) $ writeFile f x -- }}} -- {{{ Lens util
library/Hbro/WebView/Signals.hs view
@@ -6,7 +6,6 @@ module Hbro.WebView.Signals where -- {{{ Imports-import Hbro.Error import Hbro.Event import Hbro.Gdk.KeyVal import Hbro.Keys as Keys@@ -14,8 +13,8 @@ import Hbro.Logger import Hbro.Prelude hiding (on) -import Graphics.UI.Gtk.WebKit.Lifted as Lifted-import Graphics.UI.Gtk.WebKit.Lifted.WebView as W+import Control.Monad.Catch+import Control.Monad.Trans.Maybe import Data.Set as S hiding (map) @@ -25,6 +24,7 @@ import Graphics.UI.Gtk.General.General.Extended import Graphics.UI.Gtk.WebKit.Download as W hiding (Download, downloadGetSuggestedFilename, downloadGetUri)+import Graphics.UI.Gtk.WebKit.Extended as W import Graphics.UI.Gtk.WebKit.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebPolicyDecision @@ -110,9 +110,10 @@ instance Describable ResourceAction where describe = tshow -attachDownload :: (ControlIO m, MonadLogger m) => WebView -> Signal Download -> m (ConnectId WebView)+attachDownload :: (ControlIO m, MonadCatch m, MonadLogger m)+ => WebView -> Signal Download -> m (ConnectId WebView) attachDownload webView signal = liftBaseWith $ \runInIO -> gSync . on webView downloadRequested $ \d -> do- runInIO . runExceptT . logErrors $ do+ runInIO . logErrors $ do amount <- io $ downloadGetTotalSize d uri <- downloadGetUri d name <- downloadGetSuggestedFilename d@@ -121,10 +122,11 @@ return False -attachLinkHovered :: (ControlIO m, MonadLogger m) => WebView -> Signal LinkHovered -> Signal LinkUnhovered -> m (ConnectId WebView)+attachLinkHovered :: (ControlIO m, MonadCatch m, MonadLogger m)+ => WebView -> Signal LinkHovered -> Signal LinkUnhovered -> m (ConnectId WebView) attachLinkHovered webView hoveredSignal unhoveredSignal = liftBaseWith $ \runInIO -> gSync $ on webView hoveringOverLink (\a b -> void . runInIO $ callback a b)- where callback title (Just uri) = void . runExceptT . logErrors $ do- u <- parseURIM $ pack uri+ where callback title (Just uri) = void . logErrors $ do+ u <- parseURI $ pack uri emit hoveredSignal (u, pack <$> title) callback _ _ = emit unhoveredSignal () @@ -133,10 +135,11 @@ attachLoadCommitted webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadCommitted $ \_frame -> void . runInIO $ emit signal () -attachLoadFailed :: (ControlIO m, MonadLogger m) => WebView -> Signal LoadFailed -> m (ConnectId WebView)+attachLoadFailed :: (ControlIO m, MonadCatch m, MonadLogger m)+ => WebView -> Signal LoadFailed -> m (ConnectId WebView) attachLoadFailed webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadError $ \_frame uri e -> do- runInIO . runExceptT . logErrors $ do- uri' <- parseURIReferenceM uri+ runInIO . logErrors $ do+ uri' <- parseURIReference uri emit signal (uri', e) return False @@ -148,7 +151,7 @@ attachLoadStarted :: (ControlIO m, MonadLogger m) => WebView -> Signal LoadStarted -> m (ConnectId WebView) attachLoadStarted webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadStarted $ \_frame -> void . runInIO $ emit signal () -attachNavigationRequest :: (ControlIO m, MonadLogger m) => WebView -> Signal LinkClicked -> Signal LoadRequested -> m (ConnectId WebView)+attachNavigationRequest :: (ControlIO m, MonadCatch m, MonadLogger m) => WebView -> Signal LinkClicked -> Signal LoadRequested -> m (ConnectId WebView) attachNavigationRequest webView signal1 signal2 = liftBaseWith $ \runInIO -> gSync . on webView navigationPolicyDecisionRequested $ \_frame request action decision -> do reason <- webNavigationActionGetReason action button <- toMouseButton <$> webNavigationActionGetButton action@@ -157,7 +160,7 @@ -- io . putStrLn . ("Request type: " ++) . describe =<< networkRequestGetContentType request -- io . putStrLn . ("Request type: " ++) . describe =<< networkRequestGetURI request - runInIO . runExceptT $ do+ runInIO $ do uri <- networkRequestGetUri request case (reason, button) of@@ -167,10 +170,8 @@ (WebNavigationReasonOther, _) -> do debug $ "Navigation request to <" ++ tshow uri ++ ">" io $ webPolicyDecisionUse decision- (WebNavigationReasonBackForward, _) -> do- io $ webPolicyDecisionUse decision- (WebNavigationReasonReload, _) -> do- io $ webPolicyDecisionUse decision+ (WebNavigationReasonBackForward, _) -> io $ webPolicyDecisionUse decision+ (WebNavigationReasonReload, _) -> io $ webPolicyDecisionUse decision (WebNavigationReasonFormSubmitted, _) -> do debug $ "Form submitted to <" ++ tshow uri ++ ">" io $ webPolicyDecisionUse decision@@ -178,8 +179,8 @@ debug $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">" emit signal2 uri io $ webPolicyDecisionIgnore decision- `catchError` \e -> do- error e+ `catchAll` \e -> do+ error (tshow e) io $ webPolicyDecisionUse decision return True@@ -193,22 +194,22 @@ -- Triggered in 2 cases: -- 1/ Javascript window.open() -- 2/ Context menu "Open in new window"-attachNewWebView :: (ControlIO m, MonadLogger m) => WebView -> Signal NewWindow -> m (ConnectId WebView)+attachNewWebView :: (ControlIO m, MonadCatch m, MonadLogger m) => WebView -> Signal NewWindow -> m (ConnectId WebView) attachNewWebView webView signal = liftBaseWith $ \runInIO -> gSync . on webView createWebView $ \_frame -> do webView' <- webViewNew on webView' webViewReady $ return True on webView' navigationPolicyDecisionRequested $ \_ request _ decision -> do- runInIO . runExceptT . logErrors $ networkRequestGetUri request >>= emit signal+ runInIO . logErrors $ networkRequestGetUri request >>= emit signal webPolicyDecisionIgnore decision return True return webView' -attachNewWindow :: (ControlIO m, MonadLogger m) => WebView -> Signal NewWindow -> m (ConnectId WebView)+attachNewWindow :: (ControlIO m, MonadCatch m, MonadLogger m) => WebView -> Signal NewWindow -> m (ConnectId WebView) attachNewWindow webView signal = liftBaseWith $ \runInIO -> gSync . on webView newWindowPolicyDecisionRequested $ \_frame request _action decision -> do- runInIO . runExceptT . logErrors $ networkRequestGetUri request >>= emit signal+ runInIO . logErrors $ networkRequestGetUri request >>= emit signal webPolicyDecisionIgnore decision return True @@ -239,10 +240,10 @@ attachTitleChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal TitleChanged -> m (ConnectId WebView) attachTitleChanged webView signal = liftBaseWith $ \runInIO -> gSync . on webView W.titleChanged $ \_frame title -> void . runInIO $ emit signal title -attachUriChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal URIChanged -> m (ConnectId WebView)+attachUriChanged :: (ControlIO m, MonadCatch m, MonadLogger m) => WebView -> Signal URIChanged -> m (ConnectId WebView) attachUriChanged webView signal = liftBaseWith $ \runInIO ->- gSync . on webView (notifyProperty W.webViewUri) . void . runInIO . runExceptT . logErrors $- io (Glib.get webView webViewUri) >>= maybe (throwError "Invalid URI") return >>= parseURIM >>= emit signal+ gSync . on webView (notifyProperty W.webViewUri) . void . runInIO . logErrors $+ io (Glib.get webView webViewUri) >>= maybe (throwM UnavailableUri) return >>= parseURI >>= emit signal attachZoomLevelChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal ZoomLevelChanged -> m (ConnectId WebView) attachZoomLevelChanged webView signal = liftBaseWith $ \runInIO -> gSync . on webView (notifyProperty webViewZoomLevel) . void . runInIO $ emit signal =<< io (Glib.get webView webViewZoomLevel)@@ -253,7 +254,7 @@ modifiers <- Modifier . S.delete Gdk.Shift . S.fromList <$> Gdk.eventModifier key <- KeyVal <$> Gdk.eventKeyVal - io . runInIO . runFailT $ do+ io . runInIO . runMaybeT $ do guard . not $ isModifier key || isModalKey key emit signal $ modifiers .| key
library/Network/URI/Extended.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}--- | Monadic version of 'Network.URI'.+-- | Generalized version of 'Network.URI'. module Network.URI.Extended ( module X- , parseURIReferenceM- , parseURIM+ , parseURIReference+ , parseURI+ , UriException(..) ) where -- {{{ Imports@@ -14,24 +15,28 @@ import Data.Aeson -import Network.URI as X+import Network.URI as X hiding (parseURI, parseURIReference)+import qualified Network.URI as N -- }}} instance FromJSON URI where- parseJSON (String t) = maybe mzero return . parseURIReference $ unpack t+ parseJSON (String t) = maybe mzero return $ parseURIReference t parseJSON _ = mzero instance ToJSON URI where toJSON = String . tshow --- | Error message-invalidURI :: Text -> Text-invalidURI uri = "Invalid URI: " ++ uri+-- | Generalized version of 'N.parseURIReference'.+parseURIReference :: (MonadThrow m) => Text -> m URI+parseURIReference uri = N.parseURIReference (unpack uri) `failWith` InvalidUri uri --- | Monadic version of 'parseURIReference'-parseURIReferenceM :: (MonadError Text m) => Text -> m URI-parseURIReferenceM uri = parseURIReference (unpack uri) `failWith` invalidURI uri+-- | Generalized version of 'N.parseURI'.+parseURI :: (MonadThrow m) => Text -> m URI+parseURI uri = N.parseURI (unpack uri) `failWith` InvalidUri uri --- | Monadic version of 'parseURI'-parseURIM :: (MonadError Text m) => Text -> m URI-parseURIM uri = parseURI (unpack uri) `failWith` invalidURI uri++data UriException = InvalidUri Text deriving(Eq)+instance Exception UriException++instance Show UriException where+ show (InvalidUri t) = "Invalid URI: " ++ unpack t