diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +Version 2, December 2004 + +Copyright (C) 2011 koral + +Everyone is permitted to copy and distribute verbatim or modified +copies of this license document, and changing it is allowed as long +as the name is changed. + +DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + +0. You just DO WHAT THE FUCK YOU WANT TO. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hbro.cabal b/hbro.cabal new file mode 100644 --- /dev/null +++ b/hbro.cabal @@ -0,0 +1,51 @@ +Name: hbro + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 +Synopsis: A suckless minimalist KISSy browser +stability: alpha + +-- A longer description of the package. +-- Description: + +License: OtherLicense +License-file: LICENSE +Author: koral +Maintainer: koral at mailoo dot org + +-- A copyright notice. +-- Copyright: + +Category: Web +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +Cabal-version: >=1.6 + + +Source-repository head + type: git + location: git@twyk.tk/haskell-browser.git + +Executable hbro + -- .hs or .lhs file containing the Main module. + Main-is: Main.hs + + -- Packages needed in order to build this package. + Build-depends: base == 4.*, webkit, gtk, glade, mtl, containers, dyre, process, url + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + + Hs-Source-Dirs: src + + Ghc-options: -Wall -threaded + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,189 @@ +module Main where + +-- {{{ Imports +import Browser +import Gui + +import Control.Concurrent +import Graphics.UI.Gtk +import Graphics.UI.Gtk.WebKit.Download +import Graphics.UI.Gtk.WebKit.NetworkRequest +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.WebSettings +import System.Cmd +-- }}} + +main :: IO () +main = browser Configuration { + mError = Nothing, + mHomePage = "https://www.google.com", + + mKeyBindings = [ +-- ((Mod, Key), Callback) + -- Browsing + (([], "<"), back), + (([Shift], ">"), forward), + (([], "s"), stop), + (([], ""), reload True), + (([Shift], ""), reload False), + + -- Zooming + (([Shift], "+"), zoomIn), + (([], "-"), zoomOut), + + -- Prompt + (([], "o"), promptURL False), + (([Shift], "O"), promptURL True), + + -- Others + (([Control], "i"), showWebInspector), + (([Control], "u"), toggleSourceMode), + (([], "t"), toggleStatusBar) + ], + + mWebSettings = (do + settings <- webSettingsNew + set settings [ + --SETTING DEFAULT VALUE + --webSettingsCursiveFontFamily := "serif", + --webSettingsDefaultFontFamily := "sans-serif", + --webSettingsFantasyFontFamily := , + --webSettingsMonospaceFontFamily := "monospace", + --webSettingsSansFontFamily := "sans-serif", + --webSettingsSerifFontFamily := "serif", + --webSettingsDefaultFontSize := , + --webSettingsDefaultMonospaceFontSize := 10, + --webSettingsMinimumFontSize := 5, + --webSettingsMinimumLogicalFontSize := 5, + --webSettingsAutoLoadImages := True, + --webSettingsAutoShrinkImages := True, + --webSettingsDefaultEncoding := "iso-8859-1", + --webSettingsEditingBehavior := EditingBehaviorWindows, + --webSettingsEnableCaretBrowsing := , + webSettingsEnableDeveloperExtras := True, + webSettingsEnableHtml5Database := False, + webSettingsEnableHtml5LocalStorage := False, + webSettingsEnableOfflineWebApplicationCache := True, + webSettingsEnablePlugins := True, + webSettingsEnablePrivateBrowsing := False, + webSettingsEnableScripts := True, + webSettingsEnableSpellChecking := True, + webSettingsEnableUniversalAccessFromFileUris := True, + webSettingsEnableXssAuditor := True, + --webSettingsEnableSiteSpecificQuirks := False, + --webSettingsEnableDomPaste := False, + --webSettingsEnableDefaultContextMenu := True, + webSettingsEnablePageCache := True, + --webSettingsEnableSpatialNavigation := False, + --webSettingsEnforce96Dpi := , + webSettingsJSCanOpenWindowAuto := True, + --webSettingsPrintBackgrounds := True, + --webSettingsResizableTextAreas := True, + webSettingsSpellCheckingLang := Just "en_US", + --webSettingsTabKeyCyclesThroughElements := True, + webSettingsUserAgent := "Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.3) Gecko/20100401 Firefox/4.0 (.NET CLR 3.5.30729)" + --webSettingsUserStylesheetUri := Nothing, + --webSettingsZoomStep := 0.1 + ] + return settings), + + -- Custom callbacks + mCustomizations = \gui -> (let + webView = mWebView gui + progressLabel = mProgressLabel gui + urlLabel = mUrlLabel gui + window = mWindow gui + in do + _ <- on webView loadStarted $ \_ -> do + labelSetMarkup progressLabel "0%" + + _ <- on webView loadCommitted $ \_ -> do + getUrl <- (webViewGetUri webView) + case getUrl of + Just url -> labelSetMarkup urlLabel url + _ -> labelSetMarkup urlLabel "" + + _ <- on webView progressChanged $ \progress -> + labelSetMarkup progressLabel $ "" ++ show progress ++ "%" + + _ <- on webView loadFinished $ \_ -> + labelSetMarkup progressLabel "100%" + + _ <- on webView loadError $ \_ _ _ -> do + labelSetMarkup progressLabel "ERROR" + return False + + _ <- on webView titleChanged $ \_ title -> do + set window [ windowTitle := title] + + _ <- on webView downloadRequested $ \download -> do + getUrl <- downloadGetUri download + _ <- case getUrl of + Just url -> forkOS $ do rawSystem "wget" [url]; return () + _ -> forkOS $ do rawSystem "pwd" []; return () + return True + + _ <- on webView mimeTypePolicyDecisionRequested $ \_ request mimetype policyDecision -> do + putStrLn mimetype + getUrl <- networkRequestGetUri request + case getUrl of + Just url -> putStrLn url + _ -> putStrLn "ERROR" + + return False + + _ <- on webView newWindowPolicyDecisionRequested $ \_ request action policyDecision -> do + getUrl <- networkRequestGetUri request + case getUrl of + Just url -> putStrLn ("New Window: " ++ url) + _ -> putStrLn "ERROR" + + return True + + return () + )} + + +-- Definitions + where + back :: GUI -> IO () + back gui = webViewGoBack (mWebView gui) + + forward :: GUI -> IO () + forward gui = webViewGoForward (mWebView gui) + + stop :: GUI -> IO () + stop gui = webViewStopLoading (mWebView gui) + + reload :: Bool -> GUI -> IO () + reload True gui = webViewReload (mWebView gui) + reload _ gui = webViewReloadBypassCache (mWebView gui) + + zoomIn :: GUI -> IO () + zoomIn gui = webViewZoomIn (mWebView gui) + + zoomOut :: GUI -> IO () + zoomOut gui = webViewZoomOut (mWebView gui) + + toggleSourceMode :: GUI -> IO () + toggleSourceMode gui = do + currentMode <- webViewGetViewSourceMode (mWebView gui) + webViewSetViewSourceMode (mWebView gui) (not currentMode) + + -- TODO + toggleStatusBar :: GUI -> IO () + toggleStatusBar gui = return() + + + promptURL :: Bool -> GUI -> IO () + promptURL False gui = + prompt "Open URL" "" gui (\g -> do + uri <- entryGetText (mPrompt g) + loadURL uri g) + promptURL _ gui = do + uri <- webViewGetUri (mWebView gui) + case uri of + Just url -> prompt "Open URL" url gui (\g -> do + u <- entryGetText (mPrompt g) + loadURL u g) + _ -> return ()