diff --git a/Hbro/Boot.hs b/Hbro/Boot.hs --- a/Hbro/Boot.hs +++ b/Hbro/Boot.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes #-} module Hbro.Boot (hbro) where -- {{{ Imports @@ -8,7 +7,7 @@ import Hbro.Error import Hbro.Gui (GUI, GUIReader(..)) import qualified Hbro.Gui as Gui -import Hbro.IPC (IPC, IPCReader, readIPC) +import Hbro.IPC (IPC(..), IPCReader(..)) import qualified Hbro.IPC as IPC import qualified Hbro.Keys as Key import Hbro.Notification @@ -32,6 +31,7 @@ import Data.List import qualified Data.Map as M hiding(null) -- import Data.Maybe +import Data.Version import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Gdk.EventM @@ -42,35 +42,42 @@ import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebView as W +import Paths_hbro + import Prelude hiding(init) import System.Directory import System.Environment.XDG.BaseDir import System.Exit +import System.FilePath import System.Glib.Signals +import System.Posix.Files +import System.Posix.Process import System.Posix.Signals +import System.ZMQ3 (Rep(..)) import qualified System.ZMQ3 as ZMQ -- }}} -- | Main function to call in the configuration file (cf file @Hbro/Main.hs@). -- First, commandline options are parsed, then configuration is dynamically applied. -hbro :: K () -> (Config K -> Config K) -> IO () -hbro setup f = do +hbro :: K () -> IO () +hbro setup = do opts <- Options.get when (opts^.Options.help) $ putStrLn Options.usage >> exitSuccess + when (opts^.Options.version) $ putStrLn (showVersion version) >> exitSuccess when (opts^.Options.verbose) . putStrLn $ "Commandline options: " ++ show opts when (opts^.Options.recompile) $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) - Dyre.wrap hbro' opts (f, setup, opts) + Dyre.wrap hbro' opts (setup, opts) -hbro' :: (Config K -> Config K, K (), CliOptions) -> IO () -hbro' (f, customSetup, options) = do - config <- initConfig f options - gui <- initGUI config - ipc <- initIPC config +hbro' :: (K (), CliOptions) -> IO () +hbro' (customSetup, options) = do + config <- initConfig options + gui <- initGUI + ipc <- initIPC void $ installHandler sigINT (Catch onInterrupt) Nothing (result, logs) <- runK options config gui ipc $ main customSetup @@ -80,29 +87,47 @@ unless (options^.Options.quiet) $ putStrLn "Exiting..." -- {{{ Initialization -initConfig :: (MonadBase IO m) => (Config K -> Config K) -> CliOptions -> m (Config K) -initConfig f options = do - socketDir' <- io $ getTemporaryDirectory - theUIFile <- io $ getUserConfigDir "hbro" >/> "ui.xml" - let config = f - . set socketDir socketDir' - . set uIFile theUIFile +initConfig :: (MonadBase IO m) => CliOptions -> m (Config K) +initConfig options = do + let config = id . (options^.Options.quiet ? set verbosity Quiet ?? id) . (options^.Options.verbose ? set verbosity Verbose ?? id) $ def - - when (config^.verbosity == Verbose) . io . putStrLn $ "Start-up configuration: \n" ++ show config return config -initGUI :: (MonadBase IO m) => Config K -> m (GUI K) -initGUI config = do - io $ void GTK.initGUI - Gui.buildFrom $ config^.uIFile +initGUI :: (MonadBase IO m) => m (GUI K) +initGUI = do + file <- io (getUserConfigDir "hbro" >/> "ui.xml") + fallback <- io $ getDataFileName "examples/ui.xml" + file' <- io $ firstReadableOf [file, fallback] -initIPC :: (MonadBase IO m) => Config K -> m IPC -initIPC config = IPC.init =<< (IPC.getSocketPath $ config^.socketDir) + case file' of + Just f -> do + io $ void GTK.initGUI + Gui.buildFrom f + _ -> io $ putStrLn "No UI file found." >> exitFailure + where + firstReadableOf [] = return Nothing + firstReadableOf (x:y) = do + isReadable <- fileAccess x True False False + isReadable ? return (Just x) ?? firstReadableOf y + + +initIPC :: (MonadBase IO m) => m IPC +initIPC = io $ do + theContext <- ZMQ.init 1 + socket <- ZMQ.socket theContext Rep + ZMQ.bind socket =<< getSocketURI + return $ IPC theContext socket + + +getSocketURI :: (MonadBase IO m) => m String +getSocketURI = do + dir <- io getTemporaryDirectory + pid <- io getProcessID + return $ "ipc://" ++ dir "hbro." ++ show pid -- }}} @@ -140,6 +165,9 @@ -- Apply custom setup customSetup + config <- readConfig id + logV $ "Start-up configuration: \n" ++ show config + -- Load startpage startURI <- Options.getStartURI maybe goHome load startURI @@ -148,7 +176,7 @@ io GTK.mainGUI -- Clean & close - void . (`IPC.sendCommand` "QUIT") =<< IPC.getSocketPath =<< readConfig socketDir + void . (`IPC.sendCommand` "QUIT") =<< getSocketURI io $ takeMVar threadSync io . ZMQ.close =<< readIPC IPC.receiver diff --git a/Hbro/Clipboard.hs b/Hbro/Clipboard.hs --- a/Hbro/Clipboard.hs +++ b/Hbro/Clipboard.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -- | Designed to be imported as @qualified@. module Hbro.Clipboard where diff --git a/Hbro/Config.hs b/Hbro/Config.hs --- a/Hbro/Config.hs +++ b/Hbro/Config.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell, UndecidableInstances #-} module Hbro.Config where -- {{{ Imports @@ -32,9 +32,6 @@ -- | Custom settings provided by the user data Config m = Config { --- Paths - _socketDir :: FilePath, -- ^ Directory where IPC sockets will be created (e.g. @/tmp@) - _UIFile :: FilePath, -- ^ Path to XML file describing UI (used by @GtkBuilder@) _homePage :: URI, -- ^ Startup page -- Parameters _verbosity :: Verbosity, -- ^ Logs verbosity @@ -54,9 +51,7 @@ makeLenses ''Config instance Show (Config m) where - show c = "Socket directory = " ++ c^.socketDir - ++ "\nUI file = " ++ c^.uIFile - ++ "\nHome page = " ++ (show $ c^.homePage) + show c = "Home page = " ++ (show $ c^.homePage) ++ "\nVerbosity = " ++ (show $ c^.verbosity) @@ -64,6 +59,10 @@ class (Monad m) => ConfigReader n m | m -> n where readConfig :: Simple Lens (Config n) a -> m a +instance ConfigReader n ((->) (Config n)) where + readConfig l = view l + + -- | 'MonadWriter' for 'Config' class (Monad m) => ConfigWriter n m | m -> n where writeConfig :: Simple Lens (Config n) a -> a -> m () @@ -85,11 +84,6 @@ show WebNavigationReasonFormResubmitted = "Form resubmitted" show WebNavigationReasonOther = "Other" -- }}} - - --- | Return socket URI used for the current process. -getSocketURI :: (MonadBase IO m, ConfigReader n m) => m String -getSocketURI = getSocketPath =<< readConfig socketDir -- | Run an action unless verbosity is 'Quiet' unlessQuiet :: (MonadBase IO m, ConfigReader n m) => m () -> m () diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} module Hbro.Core where -- {{{ Imports @@ -110,8 +110,6 @@ -- {{{ Default configuration instance Default (Config K) where def = Config { - _socketDir = "/tmp", - _UIFile = "~/.config/hbro/ui.xml", _homePage = maybe undefined id . N.parseURI $ "https://duckduckgo.com/", _verbosity = Normal, _keyBindings = defaultKeyBindings, diff --git a/Hbro/Dyre.hs b/Hbro/Dyre.hs --- a/Hbro/Dyre.hs +++ b/Hbro/Dyre.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -- | Dynamic reconfiguration. Designed to be imported as @qualified@. module Hbro.Dyre where diff --git a/Hbro/Gtk/ScrolledWindow.hs b/Hbro/Gtk/ScrolledWindow.hs --- a/Hbro/Gtk/ScrolledWindow.hs +++ b/Hbro/Gtk/ScrolledWindow.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} module Hbro.Gtk.ScrolledWindow where -- {{{ Imports diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} module Hbro.Gui ( Buildable(..), StatusBar(..), diff --git a/Hbro/IPC.hs b/Hbro/IPC.hs --- a/Hbro/IPC.hs +++ b/Hbro/IPC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} -- | Designed to be imported as @qualified@. module Hbro.IPC where @@ -7,7 +7,6 @@ import Hbro.Util import Control.Lens hiding(Context, Rep) -import Control.Monad hiding(mapM_) import Control.Monad.Base -- import Control.Monad.Error hiding(mapM_) -- import Control.Monad.Writer @@ -21,12 +20,10 @@ import Prelude hiding(log, mapM_, read) -import System.FilePath -import System.Posix.Process -- import System.Posix.Types -- import System.Process -import System.ZMQ3 as ZMQ hiding(close, init, message, receive, send, socket) -import qualified System.ZMQ3 as ZMQ (init, receive, send, socket) +import System.ZMQ3 hiding(close, init, message, receive, send, socket) +import qualified System.ZMQ3 as ZMQ (receive, send) -- }}} -- {{{ Types @@ -42,18 +39,6 @@ newtype CommandsMap m = CommandsMap { unwrap :: Map String ([String] -> m String) } -- }}} - --- | Open a listening socket at given location -init :: (MonadBase IO m) => String -> m IPC -init uri = io $ do - theContext <- ZMQ.init 1 - socket <- ZMQ.socket theContext Rep - bind socket uri - return $ IPC theContext socket - --- | Return the socket path to use for the given browser's process ID. -getSocketPath :: (Functor m, MonadBase IO m) => FilePath -> m String -getSocketPath socketDir = ((("ipc://" ++ socketDir "hbro.") ++) . show) <$> io getProcessID -- | Send message through given socket send :: (MonadBase IO m, Sender a) => Socket a -> String -> m () diff --git a/Hbro/Keys.hs b/Hbro/Keys.hs --- a/Hbro/Keys.hs +++ b/Hbro/Keys.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell, TupleSections #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell, TupleSections #-} -- | Key bindings model. -- Designed to be imported as @qualified@. module Hbro.Keys ( diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -2,14 +2,8 @@ -- {{{ Imports import Hbro - -import Control.Lens - -import Paths_hbro -- }}} --- | Default main function provided as example +-- Default main function provided as example main :: IO () -main = do - theUIFile <- getDataFileName "examples/ui.xml" - hbro (return ()) (set uIFile theUIFile) +main = hbro $ return () diff --git a/Hbro/Network.hs b/Hbro/Network.hs --- a/Hbro/Network.hs +++ b/Hbro/Network.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -- | Functions from 'Network.URI' rewritten with 'MonadError' instead of 'Maybe'. module Hbro.Network where diff --git a/Hbro/Notification.hs b/Hbro/Notification.hs --- a/Hbro/Notification.hs +++ b/Hbro/Notification.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Hbro.Notification where -- {{{ Imports diff --git a/Hbro/Options.hs b/Hbro/Options.hs --- a/Hbro/Options.hs +++ b/Hbro/Options.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} -- | Commandline options tools. Designed to be imported as @qualified@. module Hbro.Options ( CliOptions(), @@ -7,6 +7,7 @@ help, quiet, verbose, + version, vanilla, recompile, denyReconf, @@ -45,6 +46,7 @@ _help :: Bool, _quiet :: Bool, _verbose :: Bool, + _version :: Bool, _vanilla :: Bool, _recompile :: Bool, _denyReconf :: Bool, @@ -60,6 +62,7 @@ ++ (view help opts ? " HELP" ?? "") ++ (view quiet opts ? " QUIET" ?? "") ++ (view verbose opts ? " VERBOSE" ?? "") + ++ (view version opts ? " VERSION" ?? "") ++ (view vanilla opts ? " VANILLA" ?? "") ++ (view recompile opts ? " RECOMPILE" ?? "") ++ (view denyReconf opts ? " DENY_RECONFIGURATION" ?? "") @@ -72,6 +75,7 @@ _help = False, _quiet = False, _verbose = False, + _version = False, _vanilla = False, _recompile = False, _denyReconf = False, @@ -95,6 +99,7 @@ Option ['h'] ["help"] (NoArg (\o -> o { _help = True })) "Print this help.", Option ['q'] ["quiet"] (NoArg (\o -> o { _quiet = True })) "Do not print any log.", Option ['v'] ["verbose"] (NoArg (\o -> o { _verbose = True })) "Print detailed logs.", + Option ['V'] ["version"] (NoArg (\o -> o { _version = True })) "Print version.", Option ['1'] ["vanilla"] (NoArg (\o -> o { _vanilla = True })) "Do not read custom configuration file.", Option ['r'] ["recompile"] (NoArg (\o -> o { _recompile = True })) "Only recompile configuration.", Option [] ["deny-reconf"] (NoArg id) "Do not recompile configuration even if it has changed.", diff --git a/Hbro/Prompt.hs b/Hbro/Prompt.hs --- a/Hbro/Prompt.hs +++ b/Hbro/Prompt.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} -- | Designed to be imported as @qualified@. module Hbro.Prompt( PromptBar(..), diff --git a/Hbro/Util.hs b/Hbro/Util.hs --- a/Hbro/Util.hs +++ b/Hbro/Util.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes #-} module Hbro.Util where -- {{{ Imports diff --git a/Hbro/Webkit/WebSettings.hs b/Hbro/Webkit/WebSettings.hs --- a/Hbro/Webkit/WebSettings.hs +++ b/Hbro/Webkit/WebSettings.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -- | Designed to be imported as @qualified@. module Hbro.Webkit.WebSettings where diff --git a/Hbro/Webkit/WebView.hs b/Hbro/Webkit/WebView.hs --- a/Hbro/Webkit/WebView.hs +++ b/Hbro/Webkit/WebView.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, TemplateHaskell #-} -- | Rewrite many 'Graphics.UI.Gtk.WebKit.WebView' functions in a monadic way. -- Designed to be imported as @qualified@. module Hbro.Webkit.WebView where diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 1.1.0.0 +Version: 1.1.1.0 Synopsis: Minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/ @@ -8,8 +8,8 @@ License: OtherLicense License-file: LICENSE -- Copyright: -Author: koral -Maintainer: koral at mailoo dot org +Author: koral +Maintainer: koral Cabal-version: >=1.8 Build-type: Simple @@ -53,7 +53,6 @@ Hbro.Clipboard, Hbro.Config, Hbro.Core, - Hbro.Dyre, Hbro.Error, Hbro.Gui, Hbro.IPC, @@ -66,6 +65,15 @@ Hbro.Gtk.ScrolledWindow, Hbro.Webkit.WebSettings, Hbro.Webkit.WebView + Extensions: + ConstraintKinds, + FlexibleContexts, + FunctionalDependencies, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + RankNTypes + + Other-modules: Hbro.Dyre, Paths_hbro Ghc-options: -Wall Flag threaded @@ -74,14 +82,10 @@ Executable hbro Build-depends: - hbro, + hbro >= 1.1.1.0, base == 4.*, - data-default, - directory, glib, - gtk, - lens, - mtl + gtk Main-is: Main.hs Hs-Source-Dirs: Hbro Ghc-options: -Wall