{- Portage's emerge command entry functions. Copyright (C) 2007, 2008 Luis Francisco Araujo 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 [String] | 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" portagereloadinfo :: String portagereloadinfo = "INFO=Portage will stop merging at this point and reload itself" 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 $ dropWhile (/= '[') output case checkDepOutput pkgs [] of EmergeSuccessDep parsedpkgs -> return $ map f $ takeWhile (not . null) $ parsedpkgs 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] -> [String] -> EmergeParse checkDepOutput [] pkgs = EmergeSuccessDep pkgs checkDepOutput (('[':'b':'l':'o':'c':'k':'s':xs):_) _ = EmergeBlockError ((drop 2 $ dropWhile (/= ']') xs) ++ blockerrormsg) checkDepOutput (x:xs) pkgs = case x of ('*':'*':'*':' ':'P':_) -> if (findSubstring "stop" x) then checkDepOutput xs (pkgs ++ ["[ R ] sys-apps/portage " ++ portagereloadinfo]) else checkDepOutput xs (pkgs ++ [x]) _ -> checkDepOutput xs (pkgs ++ [x]) 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"]