hbro-contrib-1.2.0.0: examples/hbro.hs

{-# LANGUAGE ConstraintKinds, FlexibleContexts, NoImplicitPrelude, OverloadedStrings, PackageImports #-}
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 qualified Data.Set as Set

import Filesystem

import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.WebKit.WebSettings

import qualified Network.URI as N
import Network.URI.Monadic
-- }}}


myHomePage = fromJust . N.parseURI $ "http://www.google.com"

-- Download to $HOME
myDownloadHook :: (BaseIO m) => Download -> m ()
myDownloadHook (Download 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

-- 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
-- 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])
-- History
    Key.bind (_Alt .| _h)          $     load . History._uri =<< History.select ["-l", "10"]
-- Settings
    Key.bind (_Alt .| _j)          $     WebSettings.toggle_ webSettingsEnableScripts
    Key.bind (_Alt .| _p)          $     WebSettings.toggle_ webSettingsEnablePlugins

-- Web settings (cf Graphic.Gtk.WebKit.WebSettings)
    WebSettings.set webSettingsEnablePlugins       False
    WebSettings.set webSettingsEnableScripts       True
    WebSettings.set webSettingsJSCanOpenWindowAuto True
    WebSettings.set 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"

    return ()


-- Main function, expected to call 'hbro'
main :: IO ()
main = hbro mySetup