Help me gather information about Mac Haskell installations

HaskellSysInfo.hs

-- Please help me gather information about Haskell installations on Macs
--
-- I'm the packager for Haskell Platform on Macintosh. I'd like to include
-- an optional installation step (and script) that cleans out older versions
-- of Haskell from a system before installing a new one, since each version
-- consumes a fair bit of disk.
--
-- In order to build a script that cleans things out, I need to know where
-- Haskell has been installed, and where cabal has installed things. Some of
-- this information can be derived from the system, but some of it you just
-- have to know where to look.
--
-- This program looks in a bunch of places and gathers the locations of various
-- bits of Haskell on the current system, as well as the current cabal config.
-- It writes a file with that information, and asks you to mail it to me. You
-- might want to review the file and remove anything you don't want to share.
-- Your user name is already scrubbed from the file.
--
-- To run this, put it in a file, say HaskellSysInfo.hs, and at the shell:
--    runhaskell HaskellSysInfo.hs
--
-- Thanks,
--    Mark Lentczner (mzero on irc)


module Main where

import Data.Char (isSpace, toLower)
import Data.List (isInfixOf, sort)
import System.Directory (getDirectoryContents, getHomeDirectory)
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import System.IO (openTempFile, hPutStr, hPutStrLn)
import System.IO.Error (ioeGetErrorString)
import System.Posix.Files
    (getFileStatus, getSymbolicLinkStatus, isDirectory, isSymbolicLink,
     readSymbolicLink)
import System.Process (readProcess, readProcessWithExitCode)
import System.Random (randomRIO)


concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f as = mapM f as >>= return . concat


scrub :: String -> String
scrub ('/':'U':'s':'e':'r':'s':'/':p)
    = "/Users/xxxxx" ++ scrub (dropWhile (/= '/') p)
scrub (c:s) = c : scrub s
scrub [] = []


entries :: (String -> Bool) -> FilePath -> IO [FilePath]
entries p f = getDirectoryContents f >>= return . map (f </>) . filter p
    
        
notDot :: String -> Bool
notDot n = not $ n `elem` [".", ".."]

ls :: FilePath -> IO [String]
ls d = do
    dst <- getFileStatus d
    if isDirectory dst
        then entries notDot d >>= mapM disp
        else disp d >>= return . (:[])
  where
    disp f = do
      st <- getSymbolicLinkStatus f
      sy <- if isSymbolicLink st
        then ("@ -> " ++) `fmap` readSymbolicLink f
        else return ""
      return $ f ++ sy


section :: String -> IO [String] -> IO [String]
section name act = do
    out <- act `catch` reportError
    return $ ["## " ++ name ++ " ##"] ++ out ++ [""]
  where
    reportError e = return [ ">>> " ++ ioeGetErrorString e ]

findFrameworks :: IO [String]
findFrameworks = section "Frameworks" $
    haskellFrameworks >>= concatMapM showVersions
  where 
    haskellFrameworks = entries haskellRelated "/Library/Frameworks"
    haskellRelated n = any (`isInfixOf` (map toLower n)) ["ghc", "haskell"]
    showVersions f = ls $ f </> "Versions"

programVersions :: IO [String]
programVersions = concatMapM go programs
  where
    go (prog, args) = section prog $ do
        (exit, out, err) <- readProcessWithExitCode "which" [prog] ""
        case exit of
          ExitSuccess   -> do
            loc <- ls $ takeWhile (not . isSpace) out
            readProcess prog args "" >>= return . (loc ++) . lines 
          ExitFailure _ -> return [prog ++ " not found"]
    programs = 
        [ ("ghc", ["--version"])
        , ("cabal", ["--version"])
        ]

packageDirs :: IO [String]
packageDirs = section "Packages" $ do
    out <- readProcess "ghc-pkg" ["dump"] ""
    return $ sort $ filter (": /" `isInfixOf`) $ lines out

dotDirs :: IO [String]
dotDirs = concatMapM go [".ghc", ".cabal"]
  where
    go d = section d $ getHomeDirectory >>= ls . (</> d) 

skipHackageLogin :: String -> String
skipHackageLogin line_
  | "username" `isInfixOf` line || "password" `isInfixOf` line
  = "-- stripped"
  | otherwise
  = line_
  where line = dropWhile isSpace line_

cabalConfig :: IO [String]
cabalConfig = section ".cabal/config" $ do
    f <- (</> ".cabal/config") `fmap` getHomeDirectory
    content <- readFile f
    let content' = unlines . map skipHackageLogin . lines $ scrub content
    hash <- readProcess "md5" [] content'
    return $ lines ("md5 of scrubbed .cabal/config: " ++ hash) ++ lines content'


main :: IO ()
main = do
    n <- randomRIO (10000,99999::Int)
    let f = "hs-info-" ++ show n ++ ".txt"
    sequence
        [ findFrameworks
        , programVersions
        , packageDirs
        , dotDirs
        , cabalConfig
        ] >>= writeFile f . unlines . map scrub . concat
    mapM_ putStrLn $
        [ "Haskell system info written to " ++ f
        , "Your user name has been scrubbed from this file."
        , "Please mail the file to: mark+hsinfo@glyphic.com"
        , "Thanks,"
        , "  - Mark"
        ]