module Hbro.Util (
spawn,
getAllProcessIDs,
webFrameGetUri,
webViewGetUri,
webViewLoadUri,
labelSetMarkupTemporary,
dmenu,
errorHandler
) where
import Control.Monad
import Data.List
import Data.IORef
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.General.General
import qualified Graphics.UI.Gtk.WebKit.WebFrame as WebKit
import qualified Graphics.UI.Gtk.WebKit.WebView as WebKit
import Network.URI
import System.Console.CmdArgs
import qualified System.Info as Sys
import System.IO
import System.IO.Error
import System.Posix.Process
import System.Process
spawn :: String -> [String] -> IO ()
spawn command options = spawn' (proc command options)
spawn' :: CreateProcess -> IO ()
spawn' command = createProcess command { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True } >> return ()
getAllProcessIDs :: IO [FilePath]
getAllProcessIDs = do
(_, pids, _) <- readProcessWithExitCode "pidof" ["hbro"] []
(_, pids', _) <- readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []
myPid <- getProcessID
return $ delete (show myPid) . nub . words $ pids ++ " " ++ pids'
webFrameGetUri :: WebKit.WebFrame -> IO (Maybe URI)
webFrameGetUri frame = (>>= parseURI) `fmap` WebKit.webFrameGetUri frame
webViewGetUri :: WebKit.WebView -> IO (Maybe URI)
webViewGetUri webView = (>>= parseURI) `fmap` WebKit.webViewGetUri webView
webViewLoadUri :: WebKit.WebView -> URI -> IO ()
webViewLoadUri webView uri = do
whenLoud $ putStrLn ("Loading URI: " ++ show uri)
case uriScheme uri of
[] -> WebKit.webViewLoadUri webView ("http://" ++ show uri)
_ -> WebKit.webViewLoadUri webView (show uri)
labelSetMarkupTemporary :: Label -> String -> Int -> IO ()
labelSetMarkupTemporary label text delay = do
labelSetMarkup label text
timeoutAdd (clear >> return False) delay >> return ()
where
clear = labelSetMarkup label ""
dmenu :: [String]
-> String
-> IO (Maybe String)
dmenu options input = do
(in_, out, err, pid) <- runInteractiveProcess "dmenu" options Nothing Nothing
hPutStr in_ input
hClose in_
output <- try $ hGetLine out
let output' = case output of
Left _ -> Nothing
Right x -> Just x
hClose out >> hClose err >> (void $ waitForProcess pid)
return output'
errorHandler :: FilePath -> IOError -> IO ()
errorHandler file e = do
when (isAlreadyInUseError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> is already opened and cannot be reopened.")
when (isDoesNotExistError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> doesn't exist.")
when (isPermissionError e) $ (whenNormal . putStrLn) ("ERROR: user doesn't have permission to open file <" ++ file ++ ">.")