module Distribution.HaskellSuite.Packages
(
Packages
, getInstalledPackages
, readPackagesInfo
, IsPackageDB(..)
, MaybeInitDB(..)
, maybeInitDB
, StandardDB(..)
, IsDBName(..)
, makePkgInfoRelative
, makePkgInfoAbsolute
, mapPaths
, writeDB
, readDB
, initDB
, PkgDBError(..)
, PkgInfoError(..)
)
where
import Data.Aeson
import Data.Aeson.Types
import Control.Applicative
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Control.Exception as E
import Control.Monad
import Data.Typeable
import Data.Tagged
import Data.Proxy
import qualified Data.Map as Map
import Text.Printf
import qualified Distribution.InstalledPackageInfo as Info
import Distribution.Package
import Distribution.Text
import System.FilePath
import System.Directory
import Data.Version (Version(..))
import Distribution.Simple.Compiler (PackageDB(..))
import Distribution.License (License(..))
import Distribution.ModuleName(ModuleName)
import Distribution.Simple.Utils
import Distribution.Verbosity
type Packages = [Info.InstalledPackageInfo]
getInstalledPackages
:: forall db. IsPackageDB db
=> Proxy db
-> PackageDB
-> IO Packages
getInstalledPackages _proxy dbspec = do
mbDb <- locateDB dbspec
maybe
(return [])
(readPackageDB $ maybeInitDB dbspec)
(mbDb :: Maybe db)
readPackagesInfo
:: IsPackageDB db
=> Proxy db -> [PackageDB] -> [InstalledPackageId] -> IO Packages
readPackagesInfo proxyDb dbs pkgIds = do
allPkgInfos <- concat <$> mapM (getInstalledPackages proxyDb) dbs
let
pkgMap =
Map.fromList
[ (Info.installedPackageId pkgInfo, pkgInfo)
| pkgInfo <- allPkgInfos
]
forM pkgIds $ \pkgId ->
maybe
(throwIO $ PkgInfoNotFound pkgId)
return
(Map.lookup pkgId pkgMap)
class IsPackageDB db where
dbName :: Tagged db String
readPackageDB :: MaybeInitDB -> db -> IO Packages
writePackageDB :: db -> Packages -> IO ()
globalDB :: IO (Maybe db)
dbFromPath :: FilePath -> IO db
locateDB :: PackageDB -> IO (Maybe db)
locateDB GlobalPackageDB = globalDB
locateDB UserPackageDB = Just <$> userDB
locateDB (SpecificPackageDB p) = Just <$> dbFromPath p
userDB :: IO db
userDB = do
let name = untag (dbName :: Tagged db String)
path <- (</>) <$> haskellPackagesDir <*> pure (name <.> "db")
dbFromPath path
data MaybeInitDB = InitDB | Don'tInitDB
maybeInitDB :: PackageDB -> MaybeInitDB
maybeInitDB GlobalPackageDB = InitDB
maybeInitDB UserPackageDB = InitDB
maybeInitDB SpecificPackageDB {} = Don'tInitDB
class IsDBName name where
getDBName :: Tagged name String
data StandardDB name = StandardDB FilePath
instance IsDBName name => IsPackageDB (StandardDB name) where
dbName = retag (getDBName :: Tagged name String)
readPackageDB init (StandardDB db) =
map (makePkgInfoAbsolute (dropFileName db)) <$> readDB init db
writePackageDB (StandardDB db) = writeDB db
globalDB = return Nothing
dbFromPath path = return $ StandardDB path
makePkgInfoRelative :: FilePath -> Info.InstalledPackageInfo -> Info.InstalledPackageInfo
makePkgInfoRelative base info =
mapPaths (makeRelative base) info
makePkgInfoAbsolute :: FilePath -> Info.InstalledPackageInfo -> Info.InstalledPackageInfo
makePkgInfoAbsolute base info =
flip mapPaths info $ \f ->
if isRelative f
then base </> f
else f
mapPaths
:: (FilePath -> FilePath)
-> (Info.InstalledPackageInfo -> Info.InstalledPackageInfo)
mapPaths f info = info
{ Info.importDirs = map f (Info.importDirs info)
, Info.libraryDirs = map f (Info.libraryDirs info)
, Info.includeDirs = map f (Info.includeDirs info)
, Info.frameworkDirs = map f (Info.frameworkDirs info)
, Info.haddockInterfaces = map f (Info.haddockInterfaces info)
, Info.haddockHTMLs = map f (Info.haddockHTMLs info)
}
writeDB :: FilePath -> Packages -> IO ()
writeDB path db = LBS.writeFile path $ encode db
readDB :: MaybeInitDB -> FilePath -> IO Packages
readDB maybeInit path = do
maybeDoInitDB
cts <- LBS.fromChunks . return <$> BS.readFile path
`E.catch` \e ->
throwIO $ PkgDBReadError path e
maybe (throwIO $ BadPkgDB path) return $ decode' cts
where
maybeDoInitDB
| InitDB <- maybeInit = initDB path
| otherwise = return ()
initDB :: FilePath -> IO ()
initDB path = do
dbExists <- doesFileExist path
unless dbExists $ do
createDirectoryIfMissingVerbose silent True (dropFileName path)
writeDB path []
haskellPackagesDir :: IO FilePath
haskellPackagesDir = getAppUserDataDirectory "haskell-packages"
errPrefix :: String
errPrefix = "haskell-suite package manager"
data PkgDBError
= BadPkgDB FilePath
| PkgDBReadError FilePath IOException
| PkgExists InstalledPackageId
| RegisterNullDB
deriving (Typeable)
instance Show PkgDBError where
show (BadPkgDB path) =
printf "%s: bad package database at %s" errPrefix path
show (PkgDBReadError path e) =
printf "%s: package db at %s could not be read: %s"
errPrefix path (show e)
show (PkgExists pkgid) =
printf "%s: package %s is already in the database" errPrefix (display pkgid)
show (RegisterNullDB) =
printf "%s: attempt to register in a null global db" errPrefix
instance Exception PkgDBError
data PkgInfoError
= PkgInfoNotFound InstalledPackageId
deriving Typeable
instance Exception PkgInfoError
instance Show PkgInfoError where
show (PkgInfoNotFound pkgid) =
printf "%s: package not found: %s" errPrefix (display pkgid)
stdToJSON :: Text a => a -> Value
stdToJSON = toJSON . display
stdFromJSON :: Text a => Value -> Parser a
stdFromJSON = maybe mzero return . simpleParse <=< parseJSON
instance ToJSON License where
toJSON = stdToJSON
instance FromJSON License where
parseJSON = stdFromJSON
instance ToJSON Version where
toJSON = stdToJSON
instance FromJSON Version where
parseJSON = stdFromJSON
instance ToJSON ModuleName where
toJSON = stdToJSON
instance FromJSON ModuleName where
parseJSON = stdFromJSON
instance ToJSON PackageName where
toJSON = stdToJSON
instance FromJSON PackageName where
parseJSON = stdFromJSON
instance ToJSON PackageIdentifier where
toJSON = stdToJSON
instance FromJSON PackageIdentifier where
parseJSON = stdFromJSON
instance ToJSON InstalledPackageId where
toJSON = stdToJSON
instance FromJSON InstalledPackageId where
parseJSON = stdFromJSON
instance ToJSON a => ToJSON (Info.InstalledPackageInfo_ a) where
toJSON i = object
[ "id" .= Info.installedPackageId i
, "name" .= Info.sourcePackageId i
, "license" .= Info.license i
, "copyright" .= Info.copyright i
, "maintainer" .= Info.maintainer i
, "author" .= Info.author i
, "stability" .= Info.stability i
, "homepage" .= Info.homepage i
, "package-url" .= Info.pkgUrl i
, "synopsis" .= Info.synopsis i
, "description" .= Info.description i
, "category" .= Info.category i
, "exposed" .= Info.exposed i
, "exposed-modules" .= Info.exposedModules i
, "hidden-modules" .= Info.hiddenModules i
, "trusted" .= Info.trusted i
, "import-dirs" .= Info.importDirs i
, "library-dirs" .= Info.libraryDirs i
, "hs-libraries" .= Info.hsLibraries i
, "extra-libraries" .= Info.extraLibraries i
, "extra-ghci-libraries" .= Info.extraGHCiLibraries i
, "include-dirs" .= Info.includeDirs i
, "includes" .= Info.includes i
, "depends" .= Info.depends i
, "hugs-options" .= Info.hugsOptions i
, "cc-options" .= Info.ccOptions i
, "ld-options" .= Info.ldOptions i
, "framework-dirs" .= Info.frameworkDirs i
, "frameworks" .= Info.frameworks i
, "haddock-interfaces" .= Info.haddockInterfaces i
, "haddock-html" .= Info.haddockHTMLs i
]
instance FromJSON a => FromJSON (Info.InstalledPackageInfo_ a) where
parseJSON (Object v) = Info.InstalledPackageInfo <$>
v .: "id" <*>
v .: "name" <*>
v .: "license" <*>
v .: "copyright" <*>
v .: "maintainer" <*>
v .: "author" <*>
v .: "stability" <*>
v .: "homepage" <*>
v .: "package-url" <*>
v .: "synopsis" <*>
v .: "description" <*>
v .: "category" <*>
v .: "exposed" <*>
v .: "exposed-modules" <*>
v .: "hidden-modules" <*>
v .: "trusted" <*>
v .: "import-dirs" <*>
v .: "library-dirs" <*>
v .: "hs-libraries" <*>
v .: "extra-libraries" <*>
v .: "extra-ghci-libraries" <*>
v .: "include-dirs" <*>
v .: "includes" <*>
v .: "depends" <*>
v .: "hugs-options" <*>
v .: "cc-options" <*>
v .: "ld-options" <*>
v .: "framework-dirs" <*>
v .: "frameworks" <*>
v .: "haddock-interfaces" <*>
v .: "haddock-html"
parseJSON _ = mzero