diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,12 @@ +Copyright (c) 2014, Thiago Arrais, JP Moresmau +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of Thiago Arrais, JP Moresmau nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-pkg-lib.cabal b/ghc-pkg-lib.cabal new file mode 100644 --- /dev/null +++ b/ghc-pkg-lib.cabal @@ -0,0 +1,29 @@ +name: ghc-pkg-lib +version: 0.1 +cabal-version: >=1.6 +build-type: Simple +author: Thiago Arrais, JP Moresmau +maintainer: jp@moresmau.fr +license: BSD3 +license-file: LICENSE +copyright: (c) Thiago Arrais 2009 +stability: stable +synopsis: Provide library support for ghc-pkg information +description: A library that lists the installed packages in a given sandbox and/or in the global and user package databases +category: Development +homepage: https://github.com/JPMoresmau/ghc-pkg-lib + +library + hs-source-dirs: src + build-depends: + base < 5, + ghc-paths >=0.1.0 && <0.2, + filepath >=1.3.0 && <1.4, + directory >=1.2.1 && <1.3, + Cabal >=1.18.1 && <1.19 + ghc-options: -Wall + exposed-modules: Language.Haskell.Packages + +source-repository head + type: git + location: git@github.com:JPMoresmau/ghc-pkg-lib.git diff --git a/src/Language/Haskell/Packages.hs b/src/Language/Haskell/Packages.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Packages.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +-- | +-- Module : Language.Haskell.Packages +-- Copyright : (c) Thiago Arrais 2009 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Packages from packages databases (global, user). +-- see +module Language.Haskell.Packages ( getPkgInfos ) where + + +import Prelude hiding (Maybe) +import qualified System.Info +import Control.Applicative +import Data.List +import Data.Maybe +import Control.Monad +import Distribution.InstalledPackageInfo +import Distribution.Text +import System.Directory +import System.Environment (getEnv) +import System.FilePath +import System.IO +import qualified Control.Exception as Exc + +import GHC.Paths + +import qualified Control.Exception as Exception + +-- This was borrowed from the ghc-pkg source: +type InstalledPackageInfoString = InstalledPackageInfo_ String + +-- | Types of cabal package databases +data CabalPkgDBType = + PkgDirectory FilePath + | PkgFile FilePath + +type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])] + + + +-- | Fetch the installed package info from the global and user package.conf +-- databases, mimicking the functionality of ghc-pkg. +getPkgInfos :: Maybe FilePath -- ^ the path to the cabal sandbox if any + -> IO InstalledPackagesList +getPkgInfos msandbox= + let + -- | Test for package database's presence in a given directory + -- NB: The directory is returned for later scanning by listConf, + -- which parses the actual package database file(s). + lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList) + lookForPackageDBIn dir = + let + path_dir = dir "package.conf.d" + path_file = dir "package.conf" + path_sd_dir= dir ("packages-" ++ ghcVersion ++ ".conf") + -- cabal sandboxes + path_ghc_dir= dir currentArch ++ '-' : currentOS ++ "-ghc-" ++ ghcVersion ++ "-packages.conf.d" + + in join . listToMaybe . filter isJust <$> + mapM readIfExists [PkgDirectory path_dir,PkgFile path_file,PkgDirectory path_sd_dir,PkgDirectory path_ghc_dir] + + currentArch :: String + currentArch = System.Info.arch + + currentOS :: String + currentOS = System.Info.os + + ghcVersion :: String + ghcVersion = TOOL_VERSION_ghc + in do + -- Get the global package configuration database: + global_conf <- do + r <- lookForPackageDBIn getLibDir + case r of + Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) + Just pkgs -> return pkgs + + -- Get the user package configuration database + user_conf <- case msandbox of + Nothing -> do + e_appdir <- Exc.try $ getAppUserDataDirectory "ghc" + case e_appdir of + Left (_::Exc.IOException) -> return [] + Right appdir -> do + let subdir + = currentArch ++ '-' : currentOS ++ '-' : ghcVersion + dir = appdir subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return [] + Just pkgs -> return pkgs + Just sd->do + r <- lookForPackageDBIn sd + case r of + Nothing -> return [] + Just pkgs -> return pkgs + -- Process GHC_PACKAGE_PATH, if present: + e_pkg_path <- Exc.try (getEnv "GHC_PACKAGE_PATH") + env_stack <- case e_pkg_path of + Left (_::Exc.IOException) -> return [] + Right path -> do + pkgs <- mapM readContents [PkgDirectory pkg | pkg <- splitSearchPath path] + return $ concat pkgs + + -- Send back the combined installed packages list: + return (env_stack ++ user_conf ++ global_conf) + +readIfExists :: CabalPkgDBType -> IO (Maybe InstalledPackagesList) +readIfExists p@(PkgDirectory path_dir) = do + exists_dir <- doesDirectoryExist path_dir + if exists_dir + then Just <$> readContents p + else return Nothing +readIfExists p@(PkgFile path_dir) = do + exists_dir <- doesFileExist path_dir + if exists_dir + then Just <$> readContents p + else return Nothing + +-- | Read the contents of the given directory, searching for ".conf" files, and parse the +-- package contents. Returns a singleton list (directory, [installed packages]) + +readContents :: CabalPkgDBType -- ^ The package database + -> IO InstalledPackagesList -- ^ Installed packages + +readContents pkgdb = + let + -- | List package configuration files that might live in the given directory + listConf :: FilePath -> IO [FilePath] + listConf dbdir = do + conf_dir_exists <- doesDirectoryExist dbdir + if conf_dir_exists + then do + files <- getDirectoryContents dbdir + return [ dbdir file | file <- files, ".conf" `isSuffixOf` file] + else return [] + + -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 + readUTF8File :: FilePath -> IO String + readUTF8File file = do + h <- openFile file ReadMode +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + Exc.catch (hGetContents h) (\(err :: Exc.IOException)->do + print err + hClose h + h' <- openFile file ReadMode + hSetEncoding h' localeEncoding + hGetContents h' + ) +#else + hGetContents h +#endif + + + -- | This function was lifted directly from ghc-pkg. Its sole purpose is + -- parsing an input package description string and producing an + -- InstalledPackageInfo structure. + convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo + convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = convert e, + hiddenModules = convert h } + where convert = mapMaybe simpleParse + + -- | Utility function that just flips the arguments to Control.Exception.catch + catchError :: IO a -> (String -> IO a) -> IO a + catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err + + -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d + -- directories, where individual package configuration files are association + -- pairs. + pkgInfoReader :: FilePath + -> IO [InstalledPackageInfo] + pkgInfoReader f = + Exc.catch ( + do + pkgStr <- readUTF8File f + let pkgInfo = parseInstalledPackageInfo pkgStr + case pkgInfo of + ParseOk _ info -> return [info] + ParseFailed err -> do + print err + return [emptyInstalledPackageInfo] + ) (\(_::Exc.IOException)->return [emptyInstalledPackageInfo]) + + in case pkgdb of + (PkgDirectory pkgdbDir) -> do + confs <- listConf pkgdbDir + pkgInfoList <- mapM pkgInfoReader confs + return [(pkgdbDir, join pkgInfoList)] + + (PkgFile dbFile) -> do + pkgStr <- readUTF8File dbFile + let pkgs = map convertPackageInfoIn $ readObj "InstalledPackageInfo" pkgStr + pkgInfoList <- + Exception.evaluate pkgs + `catchError` + (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ show e) + return [(takeDirectory dbFile, pkgInfoList)] + +-- GHC.Path sets libdir for us... +getLibDir :: String +getLibDir = libdir + +-- | read an object from a String, with a given error message if it fails +readObj :: Read a=> String -> String -> a +readObj msg s=let parses=reads s -- :: [(a,String)] + in if null parses + then error (msg ++ ": " ++ s ++ ".") + else fst $ head parses