Yum dependency walker script

transdeps.hs

{-# LANGUAGE ViewPatterns, LambdaCase, FlexibleContexts #-}

module Main where

import Control.Applicative
import System.Environment
import System.Exit
import System.IO
import System.Process
import Data.List (nub, sort)
import Data.Monoid
import Data.ByteString.UTF8 (fromString)
import Text.Trifecta
import Text.Trifecta.Delta
import Text.PrettyPrint.ANSI.Leijen (hPutDoc)
import Control.Monad.Memo


type PkgId = String

newtype Provider = Provider { unProvider :: PkgId }

yum :: [String] -> IO String
yum args = readProcess "yum" args stdin
    where stdin = ""


pWord :: Parser String
pWord = many $ letter <|> digit <|> oneOf "_-.:()+"

pPackage :: Parser PkgId
pPackage = pWord <* char ' ' <* pVersion
    where pVersion = pWord

pDepsList :: Parser [PkgId]
pDepsList = concat <$> arch `manyTill` (try $ many newline *> eof)
    where
    arch  = string "package: " *> pPackage
             *> newline *> whiteSpace
             *> (concat <$> many depLines)
    depLines  = string "dependency: " *> pWord *> many (noneOf "\n") {-pssst-}
             *> newline *> whiteSpace *> (fmap unProvider <$> many provLine)
            <|> string "No dependencies for this package" *> pure []
    provLine = string "provider: " *> (Provider <$> pPackage) <* newline <* whiteSpace


getDependees :: PkgId -> IO [PkgId]
getDependees pkg = let
        lbl = Directed (fromString $ "yum deplist " <> pkg) 0 0 0 0
    in
    --putStrLn ("---> getDependees " ++ show pkg) >>
    yum ["--noplugins", "deplist", pkg] >>= \txt ->
    case parseString pDepsList lbl txt of
        Success pkgs -> mapM_ putStrLn pkgs >> return pkgs
        Failure errs -> hPutDoc stderr (_errDoc errs) >> hPutStrLn stderr "" >> return []

getDependeesMemo :: PkgId -> MemoT PkgId [PkgId] IO [PkgId]
getDependeesMemo = memo (lift . getDependees)

transitivelyM :: (Monad m, Functor m, Ord a, Show a) => (a -> m [a]) -> [a] -> m [a]
transitivelyM f = go
    where go (nub.sort -> xs) = nub . concat <$> mapM f xs >>= \xs' ->
            if (xs `union` xs' == xs) then return xs else go (xs `union` xs')

union aa bb = nub . sort $ aa ++ bb

walk p = startEvalMemoT $ transitivelyM getDependeesMemo [p]

main :: IO ()
main = getArgs >>= \case
    [arg1] -> walk arg1 >>= \_ -> return ()
    _ -> putStrLn "Usage: $0 <pkgname>" >> exitFailure