diff --git a/Data/Aeson/Extended.hs b/Data/Aeson/Extended.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Extended.hs @@ -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 diff --git a/Hbro/Bookmarks.hs b/Hbro/Bookmarks.hs --- a/Hbro/Bookmarks.hs +++ b/Hbro/Bookmarks.hs @@ -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 diff --git a/Hbro/Download.hs b/Hbro/Download.hs --- a/Hbro/Download.hs +++ b/Hbro/Download.hs @@ -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] diff --git a/Hbro/History.hs b/Hbro/History.hs --- a/Hbro/History.hs +++ b/Hbro/History.hs @@ -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)) diff --git a/Hbro/Misc.hs b/Hbro/Misc.hs --- a/Hbro/Misc.hs +++ b/Hbro/Misc.hs @@ -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 diff --git a/Hbro/Settings.hs b/Hbro/Settings.hs --- a/Hbro/Settings.hs +++ b/Hbro/Settings.hs @@ -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 diff --git a/Hbro/StatusBar.hs b/Hbro/StatusBar.hs --- a/Hbro/StatusBar.hs +++ b/Hbro/StatusBar.hs @@ -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 diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -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 + } diff --git a/hbro-contrib.cabal b/hbro-contrib.cabal --- a/hbro-contrib.cabal +++ b/hbro-contrib.cabal @@ -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