module Debian.Debianize.Utility
( DebMap
, buildDebVersionMap
, (!)
, trim
, strictReadF
, replaceFile
, modifyFile
, diffFile
, removeIfExists
, dpkgFileMap
, cond
, debOfFile
, readFile'
, readFileMaybe
, showDeps
, showDeps'
, withCurrentDirectory
, getDirectoryContents'
, setMapMaybe
, zipMaps
, foldEmpty
, maybeL
, indent
, maybeRead
, read'
) where
import Control.Applicative ((<$>))
import Control.Exception as E (catch, try, bracket, IOException)
import Control.Monad (when)
import Control.Monad.Reader (ReaderT, ask)
import Data.Char (isSpace)
import Data.List as List (isSuffixOf, intercalate, map, lines)
import Data.Lens.Lazy (Lens, modL)
import Data.Map as Map (Map, foldWithKey, empty, fromList, findWithDefault, insert, map, lookup)
import Data.Maybe (catMaybes, mapMaybe, listToMaybe, fromMaybe)
import Data.Set (Set, toList)
import qualified Data.Set as Set
import Data.Text as Text (Text, unpack, lines)
import Data.Text.IO (hGetContents)
import Debian.Control (parseControl, lookupP, Field'(Field), unControl, stripWS)
import Debian.Version (DebianVersion, prettyDebianVersion)
import Debian.Version.String (parseDebianVersion)
import qualified Debian.Relation as D
import Prelude hiding (map, lookup)
import System.Directory (doesFileExist, doesDirectoryExist, removeFile, renameFile, removeDirectory, getDirectoryContents, getCurrentDirectory, setCurrentDirectory)
import System.Exit(ExitCode(ExitSuccess, ExitFailure))
import System.FilePath ((</>), dropExtension)
import System.IO (IOMode (ReadMode), withFile, openFile, hSetBinaryMode)
import System.IO.Error (isDoesNotExistError, catchIOError)
import System.Process (readProcessWithExitCode, showCommandForUser)
import Text.PrettyPrint.ANSI.Leijen (pretty)
type DebMap = Map.Map D.BinPkgName (Maybe DebianVersion)
buildDebVersionMap :: IO DebMap
buildDebVersionMap =
readFile "/var/lib/dpkg/status" >>=
return . either (const []) unControl . parseControl "/var/lib/dpkg/status" >>=
mapM (\ p -> case (lookupP "Package" p, lookupP "Version" p) of
(Just (Field (_, name)), Just (Field (_, version))) ->
return (Just (D.BinPkgName (stripWS name), Just (parseDebianVersion (stripWS version))))
_ -> return Nothing) >>=
return . Map.fromList . catMaybes
(!) :: DebMap -> D.BinPkgName -> DebianVersion
m ! k = maybe (error ("No version number for " ++ (show . pretty $ k) ++ " in " ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)
trim :: String -> String
trim = dropWhile isSpace
strictReadF :: (Text -> r) -> FilePath -> IO r
strictReadF f path = withFile path ReadMode (\h -> hGetContents h >>= (\x -> return $! f x))
replaceFile :: FilePath -> String -> IO ()
replaceFile path text =
do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e))
renameFile path back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e))
writeFile path text
where
back = path ++ "~"
modifyFile :: FilePath -> (String -> IO (Maybe String)) -> IO ()
modifyFile path f =
do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e))
try (renameFile path back) >>=
either (\ (e :: IOException) -> if not (isDoesNotExistError e)
then ioError e
else f "" >>= maybe (return ()) (writeFile path))
(\ () -> readFile back >>= f >>= maybe (return ()) (writeFile path))
where
back = path ++ "~"
diffFile :: FilePath -> Text -> IO (Maybe String)
diffFile path text =
readProcessWithExitCode cmd args (unpack text) >>= \ (code, out, _err) ->
case code of
ExitSuccess -> return Nothing
ExitFailure 1 -> return (Just out)
_ -> error (showCommandForUser cmd args ++ " -> " ++ show code)
where
cmd = "diff"
args = ["-ruw", path, "-"]
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists x = doesFileExist x >>= (`when` (removeFile x))
removeDirectoryIfExists :: FilePath -> IO ()
removeDirectoryIfExists x = doesDirectoryExist x >>= (`when` (removeDirectory x))
removeIfExists :: FilePath -> IO ()
removeIfExists x = removeFileIfExists x >> removeDirectoryIfExists x
dpkgFileMap :: IO (Map.Map FilePath (Set.Set D.BinPkgName))
dpkgFileMap =
do
let fp = "/var/lib/dpkg/info"
names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list")
let paths = List.map (fp </>) names
files <- mapM (strictReadF Text.lines) paths
return $ Map.fromList $ zip (List.map dropExtension names) (List.map (Set.fromList . List.map (D.BinPkgName . unpack)) $ files)
debOfFile :: FilePath -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO (Maybe D.BinPkgName)
debOfFile path =
do mp <- ask
return $ testPath (lookup path mp)
where
testPath Nothing = Nothing
testPath (Just s) =
case Set.size s of
1 -> Just (Set.findMin s)
_ -> Nothing
cond :: t -> t -> Bool -> t
cond ifF _ifT False = ifF
cond _ifF ifT True = ifT
readFile' :: FilePath -> IO Text
readFile' path =
do file <- openFile path ReadMode
hSetBinaryMode file True
hGetContents file
readFileMaybe :: FilePath -> IO (Maybe Text)
readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\ _ -> return Nothing)
showDeps :: [[D.Relation]] -> String
showDeps = show . D.prettyRelations
showDeps' :: [a] -> [[D.Relation]] -> String
showDeps' prefix xss =
intercalate ("\n" ++ prefix' ++ " ") . Prelude.lines . show . D.prettyRelations $ xss
where prefix' = List.map (\ _ -> ' ') prefix
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory name m =
E.bracket
(do cwd <- getCurrentDirectory
setCurrentDirectory name
return cwd)
(\oldwd -> setCurrentDirectory oldwd )
(const m)
getDirectoryContents' :: FilePath -> IO [FilePath]
getDirectoryContents' dir =
getDirectoryContents dir >>= return . filter (not . dotFile)
where
dotFile "." = True
dotFile ".." = True
dotFile _ = False
setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
setMapMaybe p = Set.fromList . mapMaybe p . toList
zipMaps :: Ord k => (k -> Maybe a -> Maybe b -> Maybe c) -> Map k a -> Map k b -> Map k c
zipMaps f m n =
foldWithKey h (foldWithKey g empty m) n
where
g k a r = case f k (Just a) (lookup k n) of
Just c -> Map.insert k c r
Nothing -> r
h k b r = case lookup k m of
Nothing -> case f k Nothing (Just b) of
Just c -> Map.insert k c r
Nothing -> r
Just _ -> r
foldEmpty :: r -> ([a] -> r) -> [a] -> r
foldEmpty r _ [] = r
foldEmpty _ f l = f l
maybeL :: Lens a (Maybe b) -> Maybe b -> a -> a
maybeL lens mb x = modL lens (maybe mb Just) x
indent :: [Char] -> String -> String
indent prefix text = unlines (List.map (prefix ++) (List.lines text))
maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads
read' :: Read a => (String -> a) -> String -> a
read' f s = fromMaybe (f s) (maybeRead s)