hbro-contrib 1.2.0.0 → 1.3.0.0
raw patch · 9 files changed
+368/−323 lines, 9 filesdep +aesondep +aeson-prettydep +bytestringdep ~classy-preludedep ~hbrodep ~mtl
Dependencies added: aeson, aeson-pretty, bytestring, lens, resourcet
Dependency ranges changed: classy-prelude, hbro, mtl
Files
- Data/Aeson/Extended.hs +15/−0
- Hbro/Bookmarks.hs +59/−75
- Hbro/Download.hs +26/−6
- Hbro/History.hs +43/−48
- Hbro/Misc.hs +24/−20
- Hbro/Settings.hs +22/−15
- Hbro/StatusBar.hs +87/−75
- examples/hbro.hs +80/−64
- hbro-contrib.cabal +12/−20
+ Data/Aeson/Extended.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Data.Aeson.Extended (module X, module Data.Aeson.Extended) where++import ClassyPrelude++import Control.Monad.Except++import Data.Aeson as X+import Data.Aeson.Encode.Pretty as X+import qualified Data.ByteString.Lazy as Lazy+++decodeM :: (FromJSON a, MonadError Text m) => Lazy.ByteString -> m a+decodeM = either (throwError . pack) return . eitherDecode
Hbro/Bookmarks.hs view
@@ -1,38 +1,38 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-} -- | Simple bookmarks system: bookmarks are a list of tagged URIs. -- -- This module is designed to be imported as @qualified@. module Hbro.Bookmarks ( Entry(..)+ , addCurrent+ , addCurrent' , add- , add'- , addCustom , Hbro.Bookmarks.select , Hbro.Bookmarks.select' , selectByTag , deleteByTag-) where+ ) where -- {{{ Imports-import Hbro--- import Hbro.Error-import Hbro.Gui-import Hbro.Misc--import Control.Monad.Reader hiding(mapM)+import Hbro+import Hbro.Logger+import Hbro.Misc -import qualified Data.Set as Set+import Data.Aeson.Extended+import qualified Data.Set as Set -- import Data.Random.Extras -- import Data.Random.RVar -- import Data.Random.Source.DevRandom -import Filesystem hiding(readFile, writeFile)--import Network.URI+import Filesystem hiding (readFile, writeFile) -import Safe+import Network.URI.Extended -import Text.Parsec hiding(many)-import Text.Parsec.Text+import Safe -- }}} -- {{{ Type definitions@@ -41,89 +41,76 @@ , _tags :: Set Text } +deriving instance Eq Entry+deriving instance Ord Entry+ instance Describable Entry where- describe (Entry uri tags) = unwords $ (tshow uri):(Set.toList tags)--- }}}+ describe (Entry uri tags) = unwords $ map (\x -> "[" ++ x ++ "]") (Set.toList tags) ++ [tshow uri] --- Error message--- invalidBookmarkEntry :: Text -> Text--- invalidBookmarkEntry = ("Invalid bookmark entry: " ++)+instance FromJSON Entry where+ parseJSON (Object v) = Entry <$> v .: "uri" <*> v .: "tags"+ parseJSON _ = mzero +instance ToJSON Entry where+ toJSON (Entry u t) = object ["uri" .= u, "tags" .= t]+-- }}}+ -- | Return bookmarks file getBookmarksFile :: (BaseIO m) => m FilePath getBookmarksFile = getAppDataDirectory "hbro" >/> "bookmarks" --- | Try to parse a Text into a history Entry.-entry :: Parser Entry-entry = do- spaces- u <- (some $ satisfy isAllowedInURI) <?> "URI"- uri <- (maybe mzero return $ parseURI u) <?> "URI"- some space- tags <- many $ noneOf "\n"- return $ Entry uri (Set.fromList . words $ pack tags)-- -- | Check if the given bookmark 'Entry' is tagged with the given tag. hasTag :: Text -> Entry -> Bool hasTag tag = member tag . _tags -- | Add current webpage to bookmarks with given tags-add :: (BaseIO m, MonadReader r m, HasGUI r, MonadError Text m, ToSet Text tags) => tags -> m ()-add tags = (`add'` tags) =<< getBookmarksFile+addCurrent :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m, Alternative m) => [Text] -> m ()+addCurrent tags = (`addCurrent'` tags) =<< getBookmarksFile -- | Like 'add', but you can specify the bookmarks file path-add' :: (BaseIO m, MonadReader r m, Hbro.Gui.HasGUI r, MonadError Text m, ToSet Text tags) => FilePath -> tags -> m ()-add' file tags = do+addCurrent' :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m, Alternative m) => FilePath -> [Text] -> m ()+addCurrent' file tags = do uri <- getCurrentURI- void . addCustom file $ Entry uri (toSet tags)+ void . add file $ Entry uri (Set.fromList tags) -- | Add a custom entry to bookmarks-addCustom :: (BaseIO m, MonadError Text m)- => FilePath -- ^ Bookmarks file- -> Entry -- ^ Custom bookmark entry- -> m ()-addCustom file newEntry = io $ withFile file AppendMode (`hPutStrLn` describe newEntry)+add :: (ControlIO m, MonadLogger m, MonadError Text m, Alternative m)+ => FilePath -- ^ Bookmarks file+ -> Entry -- ^ Custom bookmark entry+ -> m ()+add file newEntry = do+ info $ "New bookmark: " ++ describe newEntry+ tryIO . io . copyFile file $ file <.> "bak"+ entries <- (decodeM =<< readFileE file) <|> return Set.empty+ writeFileE file . encodePretty $ Set.insert newEntry entries -- | Open a dmenu with all (sorted alphabetically) bookmarks entries, and return the user's selection, if any.-select :: (ControlIO m, MonadError Text m)- => [Text] -- ^ dmenu's commandline options- -> m URI-select dmenuOptions = (`select'` dmenuOptions) =<< getBookmarksFile+select :: (ControlIO m, MonadError Text m) => m URI+select = (`select'` defaultDmenuOptions) =<< getBookmarksFile -- | Like 'select', but you can specify the bookmarks file path select' :: (ControlIO m, MonadError Text m) => FilePath -> [Text] -> m URI-select' file dmenuOptions = do- maybe (throwError "ERROR") return . parseURIReference . unpack . lastDef "" . words =<< dmenu dmenuOptions . unlines . sort . ordNub . (map reformat) . lines =<< readFile file--reformat :: Text -> Text-reformat line = unwords $ tags' ++ [uri]- where- uri:tags = words line- tags' = sort $ map (("[" ++) . (++ "]")) tags+select' file dmenuOptions = parseURIReferenceM . lastDef "" . words =<< dmenu dmenuOptions . unlines . sort . map (describe :: Entry -> Text) . Set.toList =<< decodeM =<< readFileE file -- | Open a dmenu with all (sorted alphabetically) bookmarks tags, and return the user's selection, if any.-selectByTag :: (ControlIO m, MonadError Text m)- => [Text] -- ^ dmenu's commandline options- -> m [URI]-selectByTag dmenuOptions = (`selectByTag'` dmenuOptions) =<< getBookmarksFile+selectByTag :: (ControlIO m, MonadLogger m, MonadError Text m) => m [URI]+selectByTag = (`selectByTag'` defaultDmenuOptions) =<< getBookmarksFile -- | Like 'selectByTag', but you can specify the bookmarks file path-selectByTag' :: (ControlIO m, MonadError Text m)+selectByTag' :: (ControlIO m, MonadLogger m, MonadError Text m) => FilePath -- ^ Bookmarks' database file -> [Text] -- ^ dmenu's commandline options -> m [URI] selectByTag' file dmenuOptions = do -- Read bookmarks file- result <- readFile file-- entries <- mapM (either (throwError . tshow) return . runParser entry () "(unknown)") . lines $ result+ entries <- decodeM =<< readFileE file let tags = unlines . Set.toList . foldl' Set.union Set.empty $ map _tags entries -- Let user select a tag- (map _uri) . (\t -> filter (hasTag t) entries) <$> dmenu dmenuOptions tags+ tag <- dmenu dmenuOptions tags+ debug $ "User selected tag " ++ tag+ return . map _uri $ filter (hasTag tag) entries --- --popOldest :: PortableFilePath -> Text -> IO (Maybe URI) --popOldest file tags = do @@ -148,22 +135,19 @@ -- | Remove all bookmarks entries matching the given tag.-deleteByTag :: (ControlIO m, MonadError Text m)- => [Text] -- ^ dmenu's commandline options- -> m ()-deleteByTag dmenuOptions = (`deleteByTag'` dmenuOptions) =<< getBookmarksFile+deleteByTag :: (ControlIO m, MonadLogger m, MonadError Text m) => m ()+deleteByTag = (`deleteByTag'` defaultDmenuOptions) =<< getBookmarksFile -- | Like 'selectByTag', but you can specify the bookmarks file path-deleteByTag' :: (ControlIO m, MonadError Text m)+deleteByTag' :: (ControlIO m, MonadLogger m, MonadError Text m) => FilePath -- ^ Bookmarks' database file -> [Text] -- ^ dmenu's commandline options -> m () deleteByTag' file dmenuOptions = do- result <- readFile file-- entries <- mapM (either (throwError . tshow) return . runParser entry () "(unknown)") . lines $ result- let tags = unlines . Set.toList . (foldl' Set.union Set.empty) $ map _tags entries+ entries <- decodeM =<< readFileE file+ let tags = unlines . Set.toList . foldl' Set.union Set.empty . map _tags $ Set.toList entries tag <- dmenu dmenuOptions tags- writeFile (file <.> "old") $ unlines (describe <$> entries)- writeFile file $ (unlines . map describe . (filter (not . (hasTag tag)))) entries+ info $ "Deleting bookmarks with tag " ++ tag+ tryIO . io . copyFile file $ file <.> "bak"+ writeFileE file . encodePretty $ Set.filter (not . hasTag tag) entries
Hbro/Download.hs view
@@ -1,17 +1,37 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} module Hbro.Download where -- {{{ Imports-import Hbro.Prelude+import Hbro.Prelude -import Network.URI+import Network.URI++import System.Process -- }}} -aria, wget, axel :: (BaseIO m)+aria, wget, axel :: (ControlIO m) => FilePath -- ^ Destination directory -> URI -- ^ URI to download -> Text -- ^ Destination file name -> m ()-aria destination uri filename = spawn "aria2c" [show uri, "-d", unpack $ fpToText destination, "-o", unpack filename]-wget destination uri filename = spawn "wget" [show uri, "-O", unpack $ fpToText (destination </> fpFromText filename)]-axel destination uri filename = spawn "axel" [show uri, "-o", unpack $ fpToText (destination </> fpFromText filename)]+aria (fpToText -> destination) (tshow -> uri) outputFile+ = downloadWith "aria2c" [uri, "-d", destination, "-o", outputFile, "-q"] outputFile++wget destination (tshow -> uri) outputFile+ = downloadWith "wget" [uri, "-O", dest] outputFile+ where dest = fpToText (destination </> fpFromText outputFile)++axel destination (tshow -> uri) outputFile+ = downloadWith "axel" [uri, "-o", dest] outputFile+ where dest = fpToText (destination </> fpFromText outputFile)++downloadWith :: (ControlIO m) => Text -> [Text] -> Text -> m ()+downloadWith (unpack -> program) (map unpack -> args) (unpack -> outputFile) = handleIO (io . print) . io $ do+ callProcess "notify-send" ["Download started", outputFile]+ callProcess program args+ callProcess "notify-send" ["Download finished", outputFile]
Hbro/History.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} -- | Designed to be imported as @qualified@. module Hbro.History ( Entry(..)@@ -5,99 +11,88 @@ , log' , add , add'- , entry , Hbro.History.select , Hbro.History.select' ) where -- {{{ Imports--- import Hbro-import Hbro.Core-import Hbro.Error-import Hbro.Gui-import Hbro.Logger-import Hbro.Misc-import Hbro.Prelude--import Control.Monad.Reader--import Data.Time+import Hbro+import Hbro.Logger+import Hbro.Misc -import Filesystem (getAppDataDirectory, withTextFile, IOMode(..))+import Data.Aeson.Extended+import qualified Data.Set as Set+import Data.Time -import Network.URI+import Filesystem (copyFile, getAppDataDirectory) -import Text.Parsec hiding(many)-import Text.Parsec.Text+import Network.URI -- }}} -- {{{ Type definitions data Entry = Entry- { _time :: LocalTime+ { _time :: UTCTime , _uri :: URI , _title :: Text } +deriving instance Eq Entry+instance Ord Entry where+ compare (Entry t u _) (Entry t' u' _)+ | u == u' = EQ+ | otherwise = compare t t'+ instance Describable Entry where describe (Entry time uri title) = unwords [pack (formatTime defaultTimeLocale dateFormat time), tshow uri, title]++instance FromJSON Entry where+ parseJSON (Object v) = Entry <$> v .: "time" <*> v .: "uri" <*> v .: "title"+ parseJSON _ = mzero++instance ToJSON Entry where+ toJSON (Entry time uri title) = object ["time" .= time, "uri" .= uri, "title" .= title]+ -- }}} dateFormat :: String dateFormat = "%F %T" --- Error message--- invalidHistoryEntry :: Text -> Text--- invalidHistoryEntry = ("Invalid history entry: " ++)- getHistoryFile :: (BaseIO m) => m FilePath getHistoryFile = getAppDataDirectory "hbro" >/> "history" -- | Log current visited page to history database-log :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => m ()+log :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m, Alternative m) => m () log = log' =<< getHistoryFile -- | Like 'log', but you can specify the history file path-log' :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => FilePath -> m ()+log' :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m, Alternative m) => FilePath -> m () log' file = do uri <- getCurrentURI title <- getPageTitle- timeZone <- io $ utcToLocalTime <$> getCurrentTimeZone- now <- io $ timeZone <$> getCurrentTime+ now <- io $ zonedTimeToUTC <$> getZonedTime add' file (Entry now uri title) -- | Add a new entry to history database-add :: (ControlIO m, MonadError Text m) => Entry -> m ()+add :: (ControlIO m, MonadLogger m, MonadError Text m, Alternative m) => Entry -> m () add newEntry = (`add'` newEntry) =<< getHistoryFile -- | Like 'add', but you can specify the history file path-add' :: (ControlIO m, MonadError Text m) => FilePath -> Entry -> m ()+add' :: (ControlIO m, MonadLogger m, MonadError Text m, Alternative m) => FilePath -> Entry -> m () add' file newEntry = do- debugM "hbro.history" $ "Adding new entry <" ++ tshow (_uri newEntry) ++ "> to history file <" ++ fpToText file ++ ">"- handleIO (throwError . tshow) . io $ withTextFile file AppendMode (`hPutStrLn` describe newEntry)+ debug $ "Adding new entry <" ++ tshow (_uri newEntry) ++ "> to history file <" ++ fpToText file ++ ">"+ tryIO . io . copyFile file $ file <.> "bak"+ entries <- (decodeM =<< readFileE file) <|> return Set.empty --- | Try to parse a Text into a history Entry.-entry :: Parser Entry-entry = do- spaces- time1 <- some $ noneOf " "- some space- time2 <- some $ noneOf " "- time <- maybe mzero return $ parseTime defaultTimeLocale dateFormat (unwords [time1, time2])- some space- u <- some $ satisfy isAllowedInURI- uri <- maybe mzero return $ parseURI u- some space- tags <- many (noneOf "\n")- return $ Entry time uri (pack tags)+ writeFileE file . encodePretty $ Set.insert newEntry entries -- | Open a dmenu with all (sorted alphabetically) history entries, and return the user's selection, if any-select :: (ControlIO m, MonadError Text m)- => [Text] -- ^ dmenu's commandline options- -> m Entry -- ^ Selected history entry, if any-select dmenuOptions = (`select'` dmenuOptions) =<< getHistoryFile+select :: (ControlIO m, MonadError Text m) => m Entry+select = (`select'` defaultDmenuOptions) =<< getHistoryFile -- | Like 'select', but you can specify the history file path select' :: (ControlIO m, MonadError Text m) => FilePath -> [Text] -> m Entry select' file dmenuOptions = do- either (throwError . tshow) return . runParser entry () "(unknown)" =<< dmenu dmenuOptions . unlines . reverse . sort . ordNub . lines =<< readFile file+ entries <- zip [1..] . sortBy (flip (comparing _time)) <$> (decodeM =<< readFileE file)+ result <- dmenu dmenuOptions . unlines $ map (\(i :: Int, e :: Entry) -> tshow i ++ " " ++ describe e) entries+ maybe (throwError "Invalid history item selected") return ((`lookup` entries) =<< readMay =<< headMay (words result))
Hbro/Misc.hs view
@@ -1,20 +1,21 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module Hbro.Misc where -- {{{ Imports-import Hbro-import Hbro.Gui as Gui--import Control.Monad.Reader hiding(mapM)+import Hbro -import Graphics.UI.Gtk.WebKit.WebBackForwardList-import Graphics.UI.Gtk.WebKit.WebHistoryItem-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebBackForwardList+import Graphics.UI.Gtk.WebKit.WebHistoryItem+import Graphics.UI.Gtk.WebKit.WebView -import Network.URI.Monadic+import Network.URI.Extended -import Safe+import Safe -import System.Process+import System.Process -- }}} @@ -31,30 +32,33 @@ output <- hGetLine out - io $ hClose out >> hClose err >> (void $ waitForProcess pid)+ io $ hClose out >> hClose err >> void (waitForProcess pid) return output +defaultDmenuOptions :: [Text]+defaultDmenuOptions = ["-l", "10"] + -- | List preceding URIs in dmenu and let the user select which one to load.-goBackList :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => [Text] -> m URI-goBackList dmenuOptions = do- list <- io . webViewGetBackForwardList =<< Gui.get webViewL+goBackList :: (ControlIO m, MonadReader r m, Has MainView r, MonadError Text m) => m URI+goBackList = do+ list <- io . webViewGetBackForwardList =<< getWebView n <- io $ webBackForwardListGetBackLength list backList <- io $ webBackForwardListGetBackListWithLimit list n dmenuList <- io $ mapM itemToEntry backList - parseURIReference . headDef "" . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList+ parseURIReferenceM . headDef "" . words =<< (dmenu defaultDmenuOptions . unlines . catMaybes) dmenuList -- | List succeeding URIs in dmenu and let the user select which one to load.-goForwardList :: (ControlIO m, MonadReader r m, HasGUI r, MonadError Text m) => [Text] -> m URI-goForwardList dmenuOptions = do- list <- io . webViewGetBackForwardList =<< Gui.get webViewL+goForwardList :: (ControlIO m, MonadReader r m, Has MainView r, MonadError Text m) => m URI+goForwardList = do+ list <- io . webViewGetBackForwardList =<< getWebView n <- io $ webBackForwardListGetForwardLength list forwardList <- io $ webBackForwardListGetForwardListWithLimit list n dmenuList <- io $ mapM itemToEntry forwardList - parseURIReference . headDef "" . words =<< (dmenu dmenuOptions . unlines . catMaybes) dmenuList+ parseURIReferenceM . headDef "" . words =<< (dmenu defaultDmenuOptions . unlines . catMaybes) dmenuList itemToEntry :: WebHistoryItem -> IO (Maybe Text)@@ -62,5 +66,5 @@ title <- webHistoryItemGetTitle item uri <- webHistoryItemGetUri item case uri of- Just u -> return $ Just (u ++ " | " ++ (maybe "Untitled" id title))+ Just u -> return $ Just (u ++ " | " ++ fromMaybe "Untitled" title) _ -> return Nothing
Hbro/Settings.hs view
@@ -1,29 +1,36 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-} module Hbro.Settings where -- {{{ Import-import Hbro.Gui-import Hbro.Prelude-import qualified Hbro.Webkit.WebSettings as Settings+import Hbro.Gui.MainView+import Hbro.Logger+import Hbro.Prelude -import Control.Monad.Reader+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebView -import Graphics.UI.Gtk.WebKit.WebSettings+import System.Glib.Attributes.Extended -- }}} -- | Disable HTML5 database & local storage, plugins and scripts.-setParanoidWebSettings :: (BaseIO m, MonadReader t m, HasGUI t) => m ()+setParanoidWebSettings :: (BaseIO m, MonadLogger m, MonadReader r m, Has MainView r) => m () setParanoidWebSettings = do- --webSettingsEnablePrivateBrowsing := False, -- Experimental+ s <- gSync . webViewGetWebSettings =<< getWebView+ --set s webSettingsEnablePrivateBrowsing False, -- Experimental -- Privacy- Settings.set webSettingsEnableHtml5Database False- Settings.set webSettingsEnableHtml5LocalStorage False- Settings.set webSettingsEnableOfflineWebApplicationCache False- Settings.set webSettingsEnableSiteSpecificQuirks False- Settings.set webSettingsUserAgent firefoxUserAgent+ set s webSettingsEnableHtml5Database False+ set s webSettingsEnableHtml5LocalStorage False+ set s webSettingsEnableOfflineWebApplicationCache False+ set s webSettingsEnableSiteSpecificQuirks False+ set s webSettingsUserAgent firefoxUserAgent -- Security- Settings.set webSettingsEnablePlugins False- Settings.set webSettingsEnableScripts False- Settings.set webSettingsJSCanOpenWindowAuto False+ set s webSettingsEnablePlugins False+ set s webSettingsEnableScripts False+ set s webSettingsJSCanOpenWindowAuto False+ return () -- {{{ User agents chromeUserAgent, epiphanyUserAgent, firefoxUserAgent, internetExplorerUserAgent, operaUserAgent, safariUserAgent :: String
Hbro/StatusBar.hs view
@@ -1,105 +1,116 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Hbro.StatusBar where -- {{{ Imports-import Hbro.Keys as Key-import Hbro.Gui as Gui-import Hbro.Prelude hiding(on)+import Hbro+import Hbro.Keys as Key+import Hbro.Logger -import Control.Monad.Reader hiding(forM_, mapM_)+import Control.Lens.Getter+import Control.Monad.Trans.Resource -import Graphics.Rendering.Pango.Enums-import Graphics.Rendering.Pango.Layout+import Graphics.Rendering.Pango.Extended+import Graphics.Rendering.Pango.Layout -import Graphics.UI.Gtk.Display.Label---import Graphics.UI.Gtk.Gdk.EventM-import Graphics.UI.Gtk.Misc.Adjustment-import Graphics.UI.Gtk.Scrolling.ScrolledWindow-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.Misc.Adjustment+import Graphics.UI.Gtk.WebKit.WebView -import Network.URI as N+import Network.URI as N -import System.Glib.Signals+import System.Glib.Attributes.Extended -- }}} -- | Write current scroll position in the given Label.-installScrollWidget :: (BaseIO m, MonadReader r m, HasGUI r) => Label -> m ()+installScrollWidget :: (ControlIO m, MonadResource m, MonadReader r m, Has MainView r) => Label -> m () installScrollWidget widget = do- adjustment <- io . scrolledWindowGetVAdjustment =<< Gui.get scrollWindowL- io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}]+ gAsync $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}] - io . void . onValueChanged adjustment $ do- current <- adjustmentGetValue adjustment- lower <- adjustmentGetLower adjustment- upper <- adjustmentGetUpper adjustment- page <- adjustmentGetPageSize adjustment+ mainView <- ask+ addHandler (mainView^.scrolledHandlerL) . const $ do+ adjustment <- getAdjustment Vertical $ mainView^.scrollWindowL+ current <- get adjustment adjustmentValue+ lower <- get adjustment adjustmentLower+ upper <- get adjustment adjustmentUpper+ page <- get adjustment adjustmentPageSize case upper-lower-page of- 0 -> labelSetText widget (asText "ALL")- x -> labelSetText widget $ show (round $ current/x*100) ++ "%"+ 0 -> gAsync $ labelSetText widget (asText "ALL")+ x -> gAsync . labelSetText widget $ show ((round $ current/x*100) :: Int) ++ "%" - io $ labelSetText widget (asText "0%")+ gAsync $ labelSetText widget (asText "0%") -- | /!\\ Doesn't work for now. -- Write current zoom level in the given Label.-installZoomWidget :: (BaseIO m, MonadReader r m, HasGUI r) => Label -> m ()+installZoomWidget :: (ControlIO m, MonadResource m, MonadReader r m, Has MainView r) => Label -> m () installZoomWidget widget = do- io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}]- Gui.get webViewL >>= io . webViewGetZoomLevel >>= io . labelSetMarkup widget . escapeMarkup . show+ gAsync $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 65535 65535 65535}]+ mainView <- ask+ getWebView >>= \w -> get w webViewZoomLevel >>= updateZoomLabel+ void $ addHandler (mainView^.zoomLevelChangedHandlerL) updateZoomLabel+ where updateZoomLabel = gAsync . labelSetMarkup widget . escapeMarkup . show + -- | Write current keystrokes state in the given 'Label'-installKeyStrokesWidget :: (BaseIO m, MonadReader r m, HasGUI r, HasHooks n r, BaseIO n) => Label -> m ()+installKeyStrokesWidget :: (ControlIO m, MonadResource m, MonadReader r m, Has (Signal KeyMapPressed) r) => Label -> m () installKeyStrokesWidget widget = do io $ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = yellow}]+ (keySignal :: Signal KeyMapPressed) <- ask+ void . addHandler keySignal $ \(strokes, isBound) -> gAsync $ do+ labelSetText widget . unwords $ map describe strokes+ labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = green <| isBound |> red}] - Key.set onKeyPressedL $ io . labelSetText widget . unwords . map describe -- | Write current load progress in the given 'Label'.-installProgressWidget :: (BaseIO m, MonadReader r m, HasGUI r) => Label -> m ()+installProgressWidget :: (ControlIO m, MonadLogger m, MonadResource m, MonadReader r m, Has MainView r) => Label -> m () installProgressWidget widget = do- wv <- Gui.get webViewL+ mainView <- ask -- Load started- io . void . on wv loadStarted $ \_ -> do+ addHandler (mainView^.loadStartedHandlerL) $ \_ -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = red}] labelSetText widget (asText "0%") -- Progress changed- io . void . on wv progressChanged $ \progress -> do+ addHandler (mainView^.progressChangedHandlerL) $ \progress -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = yellow}] labelSetText widget $ tshow progress ++ "%" -- Load finished- io . void . on wv loadFinished $ \_ -> do+ addHandler (mainView^.loadFinishedHandlerL) $ \_ -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = green}] labelSetText widget (asText "100%") -- Error- io . void . on wv loadError $ \_ (asText -> _a) _ -> do+ addHandler (mainView^.loadFailedHandlerL) $ \(_uri, _e) -> gAsync $ do labelSetAttributes widget [AttrForeground {paStart = 0, paEnd = -1, paColor = red}]- labelSetText widget (asText "ERROR")- return False+ labelSetText widget $ asText "100%" return () -- | Write current URI, or the destination of a hovered link, in the given Label.-installURIWidget :: (BaseIO m, MonadReader r m, HasGUI r) => URIColors -> URIColors -> Label -> m ()+installURIWidget :: (ControlIO m, MonadResource m, MonadReader r m, Has MainView r, MonadLogger m)+ => URIColors -> URIColors -> Label -> m () installURIWidget normalColors secureColors widget = do- wv <- Gui.get webViewL+ mainView <- ask -- URI changed- _ <- io $ on wv loadCommitted $ \_ ->- (mapM_ (labelSetURI normalColors secureColors widget)) =<< ((>>= N.parseURIReference) `fmap` (webViewGetUri wv))--- Link (un)hovered- _ <- io $ on wv hoveringOverLink $ \_title hoveredURI -> do- uri <- webViewGetUri wv-- forM_ (hoveredURI >>= N.parseURIReference) $ labelSetURI normalColors secureColors widget- unless (isJust hoveredURI) $ forM_ (uri >>= N.parseURIReference) (labelSetURI normalColors secureColors widget)+ addHandler (mainView^.uriChangedHandlerL) $ labelSetURI normalColors secureColors widget+-- Link hovered+ addHandler (mainView^.linkHoveredHandlerL) $ \(uri, _title) ->+ labelSetURI normalColors secureColors widget uri+-- Link unhovered+ addHandler (mainView^.linkUnhoveredHandlerL) $ \_ -> void . runExceptT . logErrors $+ labelSetURI normalColors secureColors widget =<< getCurrentURI return () -- |-labelSetURI :: URIColors -> URIColors -> Label -> URI -> IO ()-labelSetURI normalColors secureColors widget uri = do+labelSetURI :: (MonadIO m) => URIColors -> URIColors -> Label -> URI -> m ()+labelSetURI normalColors secureColors widget uri = gAsync $ do let colors = case uriScheme uri of "https:" -> secureColors _ -> normalColors@@ -110,37 +121,38 @@ uriPath uri, uriQuery uri] - labelSetAttributes widget $ [- AttrWeight{ paStart = 0, paEnd = -1, paWeight = WeightBold },- AttrForeground{ paStart = 0, paEnd = i+2, paColor = mScheme colors },- AttrForeground{ paStart = i+2, paEnd = i+2+j, paColor = mHost colors },- AttrForeground{ paStart = i+2+j, paEnd = i+2+j+k, paColor = mPath colors },- AttrForeground{ paStart = i+2+j+k, paEnd = i+2+j+k+l, paColor = mQuery colors },- AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors }]+ labelSetAttributes widget+ [ AttrWeight{ paStart = 0, paEnd = -1, paWeight = WeightBold }+ , AttrForeground{ paStart = 0, paEnd = i+2, paColor = mScheme colors }+ , AttrForeground{ paStart = i+2, paEnd = i+2+j, paColor = mHost colors }+ , AttrForeground{ paStart = i+2+j, paEnd = i+2+j+k, paColor = mPath colors }+ , AttrForeground{ paStart = i+2+j+k, paEnd = i+2+j+k+l, paColor = mQuery colors }+ , AttrForeground{ paStart = i+2+j+k+l, paEnd = -1, paColor = mFragment colors }+ ] labelSetText widget (show uri) -data URIColors = URIColors {- mScheme :: Color,- mHost :: Color,- mPort :: Color,- mUser :: Color,- mPath :: Color,- mQuery :: Color,- mFragment :: Color-}+data URIColors = URIColors+ { mScheme :: Color+ , mHost :: Color+ , mPort :: Color+ , mUser :: Color+ , mPath :: Color+ , mQuery :: Color+ , mFragment :: Color+ } defaultURIColors :: URIColors-defaultURIColors = URIColors {- mScheme = Color 20000 20000 20000,- mHost = Color 50000 50000 50000,- mPort = Color 65535 0 0,- mUser = Color 0 65535 0,- mPath = Color 20000 20000 20000,- mQuery = Color 20000 20000 20000,- mFragment = Color 10000 10000 65535-}+defaultURIColors = URIColors+ { mScheme = Color 20000 20000 20000+ , mHost = Color 50000 50000 50000+ , mPort = Color 65535 0 0+ , mUser = Color 0 65535 0+ , mPath = Color 20000 20000 20000+ , mQuery = Color 20000 20000 20000+ , mFragment = Color 10000 10000 65535+ } defaultSecureURIColors :: URIColors
examples/hbro.hs view
@@ -1,93 +1,109 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, NoImplicitPrelude, OverloadedStrings, PackageImports #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-} module Main where -- {{{ Imports-import Hbro-import qualified Hbro.Bookmarks as Bookmarks-import qualified Hbro.Clipboard as Clipboard-import Hbro.Config (homePageL)-import qualified Hbro.Config as Config-import qualified Hbro.Download as Download-import qualified Hbro.Gui as GUI-import Hbro.Gui.PromptBar-import qualified Hbro.History as History-import Hbro.Keys as Key-import Hbro.Keys.Model ((.|))-import Hbro.Keys.Monadic as Key-import Hbro.Misc-import Hbro.Settings-import Hbro.Gui.PromptBar.Signals-import Hbro.StatusBar-import Hbro.WebView.Hooks as WebView-import Hbro.WebView.Signals-import qualified Hbro.Webkit.WebSettings as WebSettings+import Hbro+import qualified Hbro.Bookmarks as Bookmarks+import qualified Hbro.Clipboard as Clipboard+import Hbro.Config (homePageL)+import qualified Hbro.Config as Config+import Hbro.Defaults+import qualified Hbro.Download as Download+import Hbro.Gui.PromptBar+import qualified Hbro.History as History+import Hbro.Keys as Key+import Hbro.Keys.Model ((.|))+import Hbro.Logger+import Hbro.Misc+import Hbro.Settings+import Hbro.StatusBar -import qualified Data.Set as Set+import Control.Lens.Getter -import Filesystem+import qualified Data.Map as Map+import qualified Data.Set as Set -import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.WebKit.WebSettings+import Filesystem -import qualified Network.URI as N-import Network.URI.Monadic+import Graphics.UI.Gtk.WebKit.WebSettings++import qualified Network.URI as N+import Network.URI.Extended++import System.Glib.Attributes.Extended+import System.Process.Extended -- }}} -myHomePage = fromJust . N.parseURI $ "http://www.google.com"+myHomePage = fromJust . N.parseURI $ "https://www.google.com" -- Download to $HOME-myDownloadHook :: (BaseIO m) => Download -> m ()-myDownloadHook (Download uri filename _size) = do+myDownloadHandler :: (ControlIO m) => (URI, Text, Maybe Int) -> m ()+myDownloadHandler (uri, filename, _size) = do destination <- io getHomeDirectory Download.aria destination uri filename --- myLoadFinishedHook :: KE ()-myLoadFinishedHook _ = History.log---- Setup (run at start-up)--- Note that keybindings are suited for an azerty keyboard-mySetup :: K ()-mySetup = do- Config.set homePageL myHomePage- WebView.set onDownloadL myDownloadHook- WebView.set onLoadFinishedL myLoadFinishedHook+myLoadFinishedHandler :: (ControlIO m, MonadReader r m, Has MainView r, MonadLogger m, MonadError Text m, Alternative m) => m ()+myLoadFinishedHandler = History.log --- Browse- Key.bind (_Control .| _Left) $ goBackList ["-l", "10"] >>= load- Key.bind (_Control .| _Right) $ goForwardList ["-l", "10"] >>= load- Key.bind (_Control .| _g) $ prompt "DuckDuckGo search" "" >>= parseURIReference . ("http://duckduckgo.com/html?q=" ++) . (pack . escapeURIString isAllowedInURI . unpack) >>= load+-- Those key bindings are suited for an azerty keyboard+myKeyMap :: (God r m) => KeyMap m+myKeyMap = defaultKeyMap <> Map.fromList+ -- Browse+ [ [_Control .| _Left] >: goBackList >>= load+ , [_Control .| _Right] >: goForwardList >>= load+ , [_Control .| _g] >: promptM "DuckDuckGo search" "" >>= parseURIReferenceM . ("http://duckduckgo.com/html?q=" ++) . pack . escapeURIString isAllowedInURI . unpack >>= load -- Bookmarks- Key.bind (_Control .| _d) $ prompt "Bookmark with tags:" "" >>= Bookmarks.add . Set.fromList . words-{- Key.bind (_Control .| _D) $ Prompt.read "Bookmark all instances with tag:" "" $ \tags -> do- uris <- mapM parseURI =<< sendCommandToAll "GET_URI"- forM uris $ Bookmarks.addCustom . (`Bookmarks.Entry` words tags)- void . Bookmarks.addCustom . (`Bookmarks.Entry` words tags) =<< getURI-}- Key.bind (_Alt .| _d) $ Bookmarks.deleteByTag ["-l", "10"]- Key.bind (_Control .| _l) $ Bookmarks.select ["-l", "10"] >>= load- Key.bind (_Control .| _L) $ Bookmarks.selectByTag ["-l", "10"] >>= void . mapM (\uri -> io $ spawn "hbro" ["-u", show uri])+ , [_Control .| _d] >: promptM "Bookmark with tags:" "" >>= Bookmarks.addCurrent . words+ -- , [_Control .| _D] >: promptM "Bookmark all instances with tag:" "" >>= \tags -> do+ -- uris <- mapM parseURI =<< sendCommandToAll "GET_URI"+ -- forM uris $ Bookmarks.addCustom . (`Bookmarks.Entry` words tags)+ -- void . Bookmarks.addCustom . (`Bookmarks.Entry` words tags) =<< getURI+ , [_Alt .| _d] >: Bookmarks.deleteByTag+ , [_Control .| _l] >: Bookmarks.select >>= load+ , [_Control .| _L] >: Bookmarks.selectByTag >>= void . mapM (\uri -> spawn "hbro" ["-u", tshow uri]) -- History- Key.bind (_Alt .| _h) $ load . History._uri =<< History.select ["-l", "10"]+ , [_Alt .| _h] >: load . History._uri =<< History.select -- Settings- Key.bind (_Alt .| _j) $ WebSettings.toggle_ webSettingsEnableScripts- Key.bind (_Alt .| _p) $ WebSettings.toggle_ webSettingsEnablePlugins+ , [_Alt .| _j] >: getWebSettings >>= \s -> toggle_ s webSettingsEnableScripts+ , [_Alt .| _p] >: getWebSettings >>= \s -> toggle_ s webSettingsEnablePlugins+ ] ++-- Setup run at start-up+myStartUp :: (God r m) => m ()+myStartUp = do+ Config.set homePageL myHomePage++ mainView <- ask+ addHandler (mainView^.downloadHandlerL) myDownloadHandler+ addHandler (mainView^.loadFinishedHandlerL) $ const myLoadFinishedHandler+ -- Web settings (cf Graphic.Gtk.WebKit.WebSettings)- WebSettings.set webSettingsEnablePlugins False- WebSettings.set webSettingsEnableScripts True- WebSettings.set webSettingsJSCanOpenWindowAuto True- WebSettings.set webSettingsUserAgent firefoxUserAgent+ s <- getWebSettings+ set s webSettingsEnablePlugins False+ set s webSettingsEnableScripts True+ set s webSettingsJSCanOpenWindowAuto True+ set s webSettingsUserAgent firefoxUserAgent -- Status bar customization: scroll position + zoom level + load progress + current URI + key strokes- installScrollWidget =<< GUI.getObject castToLabel "scroll"- installZoomWidget =<< GUI.getObject castToLabel "zoom"- installProgressWidget =<< GUI.getObject castToLabel "progress"- installURIWidget defaultURIColors defaultSecureURIColors =<< GUI.getObject castToLabel "uri"- installKeyStrokesWidget =<< GUI.getObject castToLabel "keys"+ b <- ask+ installScrollWidget =<< getWidget b "scroll"+ installZoomWidget =<< getWidget b "zoom"+ installProgressWidget =<< getWidget b "progress"+ installURIWidget defaultURIColors defaultSecureURIColors =<< getWidget b "uri"+ installKeyStrokesWidget =<< getWidget b "keys" return () -- Main function, expected to call 'hbro' main :: IO ()-main = hbro mySetup+main = hbro $ def+ { keyMap = myKeyMap+ , startUp = myStartUp+ }
hbro-contrib.cabal view
@@ -1,5 +1,5 @@ Name: hbro-contrib-Version: 1.2.0.0+Version: 1.3.0.0 Synopsis: Third-party extensions to hbro. Description: Cf README Homepage: https://bitbucket.org/k0ral/hbro-contrib@@ -19,51 +19,43 @@ Source-repository head Type: git Location: https://github.com/k0ral/hbro-contrib.git-Source-repository head- Type: hg- Location: https://bitbucket.org/k0ral/hbro-contrib-Source-repository head- Type: hg- Location: http://hgweb.twyk.org/hbro-contrib Library Build-depends:+ aeson,+ aeson-pretty, base == 4.*,- classy-prelude,+ bytestring,+ classy-prelude >= 0.9.4, containers, glib, gtk3 >= 0.12.3,- hbro >= 1.2.0.0,+ hbro >= 1.3.0.0,+ lens, monad-control,- mtl >= 2.2.1,+ mtl, network-uri, pango, parsec, process, -- random-extras, -- random-fu,+ resourcet, safe, system-fileio,+ -- taggy-lens, text, time, transformers-base, unix, webkitgtk3 Exposed-modules:+ Data.Aeson.Extended, Hbro.Bookmarks, Hbro.Download,+ -- Hbro.Feed, Hbro.History, Hbro.Misc, Hbro.Settings, Hbro.StatusBar- Extensions:- ConstraintKinds,- DeriveDataTypeable,- FlexibleContexts,- FunctionalDependencies,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses,- NoImplicitPrelude,- OverloadedStrings,- RankNTypes Ghc-options: -Wall -fno-warn-unused-do-bind -threaded