himerge-0.17.9: src/Emerge.hs
{-
Portage's emerge command entry functions.
Copyright (C) 2007, 2008 Luis Francisco Araujo <araujo@gentoo.org>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
-}
module Emerge
where
import Util
import Graphics.UI.Gtk
import Data.Char (isAlpha)
import System.IO
import System.Process
import Control.Concurrent
import System.Exit
import qualified Control.Exception as E
data EmergeParse = EmergeSuccessDep | EmergeBlockError String
deriving Show
blockerrormsg :: String
blockerrormsg = "\nFor more information about Blocked Packages, please refer to the following\n\
\section of the Gentoo Linux x86 Handbook (architecture is irrelevant):\n\
\\n\
\http://www.gentoo.org/doc/en/handbook/handbook-x86.xml?full=1#blocked"
emergepath :: FilePath
emergepath = envbin ++ " emerge --color=n "
equerypath :: FilePath
equerypath = envbin ++ " equery "
qlistpath :: FilePath
qlistpath = envbin ++ " qlist "
emergeDeps :: Handle -> IO [(String, String)]
emergeDeps out =
do
output <- hGetContents out
E.evaluate output
let pkgs = lines output
case checkDepOutput pkgs of
EmergeSuccessDep -> return $ map f $ takeWhile (not . null) $ lines $ dropWhile (/= '[') output
EmergeBlockError xs -> popErrorWindow xs >> return []
where
f pkg = let (s:rs) = words $ dropWhile (/= ' ') pkg
in
let p = dropWhile (not . isAlpha) $ unwords rs in (filter isAlpha s, p)
checkDepOutput :: [String] -> EmergeParse
checkDepOutput [] = EmergeSuccessDep
checkDepOutput (('[':'b':'l':'o':'c':'k':'s':xs):_) =
EmergeBlockError ((drop 2 $ dropWhile (/= ']') xs) ++ blockerrormsg)
checkDepOutput (_:xs) = checkDepOutput xs
equeryOutput :: Handle -> IO [(String, String)]
equeryOutput out =
do
output <- hGetContents out
E.evaluate output
let xs = filter (not . null) $ map (takeWhile (/= ' ')) $ lines output
return $ map ((,) "Y") xs
emergeError :: String -> Handle -> IO ()
emergeError = flip ((>>=) . hGetContents) . (popErrorWindow .) . (++)
sync :: Notebook -> TextView -> Statusbar -> ProgressBar -> IO ()
sync = commandView (emergepath ++ "--sync", "Updating portage tree",
"Portage tree successfully updated.", "Error updating portage tree.") EmergeSync
emergeInfo, emergeMetadata :: Notebook -> TextView -> Statusbar -> ProgressBar -> IO ()
emergeInfo = commandView (emergepath ++ "--info", "Showing portage information",
"Portage information.", "Error showing portage information.") Emerge
emergeMetadata = commandView (emergepath ++ "--metadata", "Regenerating metadata",
"Portage metadata regenerated.", "Error regenerating metadata.") EmergeSync
emerge :: [String] -> Notebook -> TextView -> Statusbar -> ProgressBar
-> String -> (TreeView, ListStore, [(String, TreeIter)]) -> IO ()
emerge _ _ _ statbar _ [] (_, _, []) =
updateStatBar statbar "No package on queue." >> return ()
emerge _ _ _ statbar _ pkgmsg (_, _, []) =
updateStatBar statbar pkgmsg
emerge msgs panel logview statbar progbar _ (tv, st, ((package, pkgiter):ps)) =
do
-- Create the notebook page.
(pkgscroll, pkgview) <- makeView False
-- Build the page panel with the proper tab buttons.
(tooltips, (Just stopbutton), (Just closebutton))
<- buildPanelTab pkgscroll panel package StopCloseButton
widgetShowAll pkgscroll
-- Jump to the page processing the operation.
notebookSetCurrentPage panel (-1)
-- Start emerge operation.
-- Set package status on queue.
progressBarSetFraction progbar 0.0
-- Log information.
let loginfo = ((msgs !! 1) ++ " " ++ package)
-- Write the log.
writeLog logview loginfo
-- Keep updating the status bar with the log information.
statid <- forkIO $ refreshStatBar statbar (loginfo ++ " ...")
listStoreSetValue st pkgiter 0 (GVstring $ Just (setQueueColor "green" (msgs !! 1)))
listStoreSetValue st pkgiter 4 (GVstring $ Just "purple")
scrollViewToCell st pkgiter tv
(_,out,err,ph) <- runInteractiveCommand ((msgs !! 0) ++ " =" ++ package)
barthread <- forkIO $ updateBar progbar
-- show stdout buffer.
ebuf <- textViewGetBuffer pkgview
forkIO $ showEmergeBuffer Emerge out pkgview ebuf
-- show stderr buffer.
forkIO $ showEmergeBuffer Emerge err pkgview ebuf
-- Connect signal to the stop-process and close-tab buttons.
stopbutton `onClicked`
(do
exitcode <- getProcessExitCode ph
case exitcode of
Nothing -> popSelectWindow ("Stop " ++ (msgs !! 1) ++ " " ++ package)
(terminateProcess ph)
Just _ -> popInfoWindow "This process is already stopped.")
closebutton `onClicked`
(do
exitcode <- getProcessExitCode ph
case exitcode of
Nothing -> popWarningWindow "The process is still running.\n\
\Stop this process first and then close the tab."
Just _ -> do
(Just text) <- notebookGetMenuLabelText panel pkgscroll
popSelectWindow ("Do you really want to close [" ++ text ++ "]?")
(tooltipsEnable tooltips >> closeTab panel pkgscroll))
-- Test for process termination.
forkIO $ onExit ph ((.) ((>>) (killThread statid)) (handleExitCode barthread))
-- Avoid individual tooltips to be GC'ed.
return ()
where
handleExitCode thread exitcode =
killThread thread >>
case exitcode of
ExitSuccess -> do
progressBarSetFraction progbar 1.0
listStoreSetValue st pkgiter 0 (GVstring $ Just (setQueueColor "purple" (msgs !! 2)))
listStoreSetValue st pkgiter 4 (GVstring $ Just "lightgreen")
scrollViewToCell st pkgiter tv
let rlog = (package ++ " => " ++ (msgs !! 2) ++ " successfully.")
writeLog logview rlog
emerge msgs panel logview statbar progbar rlog (tv, st, ps)
ExitFailure 115 -> do
listStoreSetValue st pkgiter 0 (GVstring $ Just (setQueueColor "blue" "Stopped"))
listStoreSetValue st pkgiter 4 (GVstring $ Just "red")
scrollViewToCell st pkgiter tv
let rlog = ((msgs !! 1) ++ " " ++ package ++ " stopped.")
writeLog logview rlog
updateStatBar statbar rlog
progressBarSetFraction progbar 0.0
ExitFailure _ -> do
listStoreSetValue st pkgiter 0 (GVstring $ Just (setQueueColor "black" (msgs !! 3)))
listStoreSetValue st pkgiter 4 (GVstring $ Just "red")
scrollViewToCell st pkgiter tv
let rlog = ((msgs !! 3) ++ " " ++ package ++ ".")
popErrorWindow rlog
writeLog logview rlog
updateStatBar statbar rlog
progressBarSetFraction progbar 0.0
packagesToEmerge :: ListStore -> IO (ListStore, [(String, TreeIter)])
packagesToEmerge st = collectIters st 0 >>= mapM f >>= return . (,) st
where f i = do
(GVstring (Just pkgatom)) <- treeModelGetValue st i 3
return $ (takeWhile (/= ' ') pkgatom, i)
{- | Emerge functions. -}
emergePackages, unmergePackages, fetchPackages
:: Notebook -> TextView -> Statusbar -> ProgressBar -> IO ()
binaryPackages, useBinaryPackages
:: Notebook -> TextView -> Statusbar -> ProgressBar -> IO ()
emergeOperation :: Notebook -> TextView -> Statusbar
-> ProgressBar -> [String] -> IO ()
emergeOperation panel logview statbar progbar info =
isCurrentPagePackagePanel panel
(\ pkgtv -> getStoreFromView pkgtv >>= packagesToEmerge >>=
\ (st, xs) -> emerge info panel logview statbar progbar [] (pkgtv, st, xs))
emergePackages panel logview statbar progbar =
emergeOperation panel logview statbar progbar
[emergepath, "Installing", "Installed", "Error installing"]
unmergePackages panel logview statbar progbar =
emergeOperation panel logview statbar progbar
[emergepath ++ " --unmerge" , "Uninstalling", "Uninstalled", "Error uninstalling"]
fetchPackages panel logview statbar progbar =
emergeOperation panel logview statbar progbar
[emergepath ++ " --nodeps --fetchonly", "Fetching", "Fetched", "Error fetching"]
binaryPackages panel logview statbar progbar =
emergeOperation panel logview statbar progbar
[emergepath ++ " --buildpkg", "Installing (building binary package too)"
, "Installed", "Error installing"]
useBinaryPackages panel logview statbar progbar =
emergeOperation panel logview statbar progbar
[emergepath ++ " --usepkg", "Installing (using binary package if available)"
, "Installed", "Error installing"]