PkgManager.hs

{- |
   Module      : Distribution.Gentoo.PkgManager
   Description : Using package managers in Gentoo.
   Copyright   : (c) Ivan Lazar Miljenovic, Emil Karlson 2010
   License     : GPL-2 or later

   This module defines ways to use different Gentoo package managers.
 -}
module Distribution.Gentoo.PkgManager
       ( definedPMs
       , choosePM
       , stringToCustomPM
       , isValidPM
       , defaultPM
       , defaultPMName
       , nameOfPM
       , buildCmd
       , buildAltCmd
       ) where

import Distribution.Gentoo.Packages
import Distribution.Gentoo.PkgManager.Types

import Data.Char(toLower)
import Data.Maybe(mapMaybe, fromMaybe)
import qualified Data.Map as M
import Data.Map(Map)
import System.Environment(getEnvironment)

-- -----------------------------------------------------------------------------

-- | The default package manager.  If the environment variable
--   @PACKAGE_MANAGER@ exists, use that; otherwise default to
--   "portage".  Note that even if that environment variable is
--   defined, if it is unknown then it won't be used.
defaultPM :: IO PkgManager
defaultPM = do eDPM <- lookup "PACKAGE_MANAGER" `fmap` getEnvironment
               let dPM = fromMaybe defaultPMName eDPM
                   mPM = dPM `M.lookup` pmNameMap
               return $ fromMaybe knownDef mPM
  where
    knownDef = pmNameMap M.! defaultPMName

defaultPMName :: String
defaultPMName = "portage"

-- | The names of known package managers.
definedPMs :: [String]
definedPMs = M.keys pmNameMap

isValidPM                    :: PkgManager -> Either String PkgManager
isValidPM (InvalidPM pmname) = Left pmname
isValidPM pm                 = Right pm

pmNameMap :: Map String PkgManager
pmNameMap = M.fromList [ ("portage", Portage)
                       , ("pkgcore", PkgCore)
                       , ("paludis", Paludis)
                       ]

pmNameMap' :: Map PkgManager String
pmNameMap' = M.fromList . map (\(nm,pm) -> (pm,nm)) $ M.toList pmNameMap

nameOfPM                    :: PkgManager -> String
nameOfPM (CustomPM pmname)  = "custom package manager command: " ++ pmname
nameOfPM (InvalidPM pmname) = "invalid package manager: " ++ pmname
nameOfPM pm                 = pmNameMap' M.! pm

-- | Choose the appropriate PM from the textual representation; throws
--   an error if that PM isn't known.
choosePM    :: String -> PkgManager
choosePM pm = fromMaybe (InvalidPM pm) $ pm' `M.lookup` pmNameMap
    where
      pm' = map toLower pm

stringToCustomPM :: String -> PkgManager
stringToCustomPM = CustomPM

pmCommand                :: PkgManager -> String
pmCommand Portage        = "emerge"
pmCommand PkgCore        = "pmerge"
pmCommand Paludis        = "cave"
pmCommand (CustomPM cmd) = cmd
pmCommand (InvalidPM _)  = undefined

defaultPMFlags               :: PkgManager -> [String]
defaultPMFlags Portage       = [ "--oneshot"
                               , "--keep-going"
                               , "--complete-graph"
                               , "--usepkg=n"
                               ]
defaultPMFlags PkgCore       = [ "--deep"
                               , "--oneshot"
                               , "--ignore-failures"
                               ]
defaultPMFlags Paludis       = [ "resolve"
                               , "--execute"
                               , "--preserve-world"
                               , "--continue-on-failure", "if-independent"
                               ]
defaultPMFlags CustomPM{}    = []
defaultPMFlags (InvalidPM _) = undefined

buildCmd :: PkgManager -> [PMFlag] -> [String] -> [Package] -> (String, [String])
buildCmd pm fs raw_pm_flags ps = (pmCommand pm, fs' ++ ps')
    where
      fs' = defaultPMFlags pm ++ mapMaybe (flagRep pm) fs ++ raw_pm_flags
      ps' = map printPkg ps

-- | Alternative version of 'buildCmd' which uses experimental @emerge@
--   invocation (using @--reinstall-atoms@). This is only to be used with the
--   'Portage' 'PkgManager'.
--
--   The rationale is that by marking broken packages by using
--   @--reinstall-atoms@, portage will pretend that they are not yet
--   installed, thus forcing their reinstallation. @--update@ is
--   used and all installed Haskell packages are targeted so that the entire
--   Haskell environment is examined. This has a side-effect of skipping
--   packages that are masked or otherwise unavailable while still rebuilding
--   needed dependencies that have been broken.
buildAltCmd
    :: [PMFlag] -- ^ Basic flags
    -> [String] -- ^ User-supplied flags
    -> [Package] -- ^ List of packages to rebuild
    -- | List of /all/ installed haskell packages ('Nothing' denotes a @world@ target)
    -> Maybe [Package]
    -> (String, [String])
buildAltCmd fs rawPmFlags ps allPs =
    (pmCommand Portage, fs' ++ reinst ++ rawPmFlags ++ allPs')
  where
    fs' = defaultPMFlags Portage ++ mapMaybe (flagRep Portage) fs ++ ["--update"]
    reinst = ["--reinstall-atoms", unwords (map printPkg ps)]
    allPs' = maybe ["@world"] (map printPkg) allPs

-- -----------------------------------------------------------------------------

flagRep               :: PkgManager -> PMFlag -> Maybe String
flagRep Portage       = portagePMFlag
flagRep PkgCore       = pkgcorePMFlag
flagRep Paludis       = cavePMFlag
flagRep CustomPM{}    = const Nothing -- Can't tell how flags would work.
flagRep (InvalidPM _) = undefined

portagePMFlag                :: PMFlag -> Maybe String
portagePMFlag PretendBuild   = Just "--pretend"
portagePMFlag UpdateDeep     = Just "--deep"
portagePMFlag UpdateAsNeeded = Nothing

pkgcorePMFlag :: PMFlag -> Maybe String
pkgcorePMFlag = portagePMFlag -- The options are the same for the 3
                              -- current flags.

cavePMFlag                :: PMFlag -> Maybe String
cavePMFlag PretendBuild   = Just "--no-execute"
cavePMFlag UpdateDeep     = Just "--complete"
cavePMFlag UpdateAsNeeded = Just "--lazy"