aboutsummaryrefslogtreecommitdiff
path: root/cabal-plan/src/Cabal
diff options
context:
space:
mode:
Diffstat (limited to 'cabal-plan/src/Cabal')
-rwxr-xr-xcabal-plan/src/Cabal/Plan.hs576
1 files changed, 576 insertions, 0 deletions
diff --git a/cabal-plan/src/Cabal/Plan.hs b/cabal-plan/src/Cabal/Plan.hs
new file mode 100755
index 0000000..63be81b
--- /dev/null
+++ b/cabal-plan/src/Cabal/Plan.hs
@@ -0,0 +1,576 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | SPDX-License-Identifier: GPL-2.0-or-later
+--
+-- Utilities for reading @cabal@'s @plan.json@ file
+--
+-- @plan.json@ are generated when using @cabal@
+-- <http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html Nix-style Local Builds>.
+module Cabal.Plan
+ (
+ PlanJson(..)
+ , Unit(..)
+ , CompName(..)
+ , dispCompName
+ , CompInfo(..)
+ , UnitType(..)
+
+ -- * Basic types
+ , Ver(..)
+ , dispVer
+ , PkgName(..)
+ , PkgId(..)
+ , dispPkgId
+ , UnitId(..)
+ , FlagName(..)
+
+ -- ** SHA-256
+ , Sha256
+ , dispSha256
+ , parseSha256
+ , sha256ToByteString
+ , sha256FromByteString
+
+ -- ** PkgLoc
+ , PkgLoc(..)
+ , Repo(..)
+ , SourceRepo(..)
+ , URI(..)
+ , RepoType(..)
+
+ -- * Utilities
+ , planJsonIdGraph
+ , planJsonIdRoots
+
+ -- * Convenience functions
+ , SearchPlanJson(..)
+ , findAndDecodePlanJson
+ , findProjectRoot
+ , decodePlanJson
+ ) where
+
+import Control.Applicative as App
+import Control.Monad
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as B16
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Version as DV
+import qualified System.Directory as Dir
+import System.FilePath
+import Text.ParserCombinators.ReadP
+
+----------------------------------------------------------------------------
+
+-- | Equivalent to @Cabal@'s @Distribution.Package.Version@
+newtype Ver = Ver [Int]
+ deriving (Show,Eq,Ord)
+
+-- | Equivalent to @Cabal@'s @Distribution.Package.UnitId@
+newtype UnitId = UnitId Text
+ deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey)
+
+-- | Equivalent to @Cabal@'s @Distribution.Package.PackageName@
+newtype PkgName = PkgName Text
+ deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey)
+
+-- | Equivalent to @Cabal@'s @Distribution.Package.PackageIdentifier@
+data PkgId = PkgId !PkgName !Ver
+ deriving (Show,Eq,Ord)
+
+-- | Equivalent to @Cabal@'s @Distribution.PackageDescription.FlagName@
+--
+-- @since 0.3.0.0
+newtype FlagName = FlagName Text
+ deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey)
+
+-- | <https://en.wikipedia.org/wiki/SHA-2 SHA-256> hash
+newtype Sha256 = Sha256 B.ByteString -- internal invariant: exactly 32 bytes long
+ deriving (Eq,Ord)
+-- | Equivalent to @Cabal@\'s @Distribution.Client.Types.PackageLocation@
+data PkgLoc
+ = LocalUnpackedPackage !FilePath
+ | LocalTarballPackage !FilePath
+ | RemoteTarballPackage !URI
+ | RepoTarballPackage !Repo
+ | RemoteSourceRepoPackage !SourceRepo
+ deriving (Show,Eq,Ord)
+
+-- | Equivalent to @Cabal@\'s @Distribution.Types.SourceRepo@
+data Repo
+ = RepoLocal !FilePath
+ | RepoRemote !URI
+ | RepoSecure !URI
+ deriving (Show,Eq,Ord)
+
+-- | Equivalent to @Cabal@\'s @Distribution.Client.Types.Repo@
+data SourceRepo = SourceRepo
+ { srType :: !(Maybe RepoType)
+ , srLocation :: !(Maybe Text)
+ , srModule :: !(Maybe Text)
+ , srBranch :: !(Maybe Text)
+ , srTag :: !(Maybe Text)
+ , srSubdir :: !(Maybe FilePath)
+ } deriving (Show,Eq,Ord)
+
+newtype URI = URI Text
+ deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey)
+
+-- | Equivalent to @Cabal@\'s @Distribution.Client.SourceRepo.RepoType@
+data RepoType
+ = Darcs
+ | Git
+ | SVN
+ | CVS
+ | Mercurial
+ | GnuArch
+ | Bazaar
+ | Monotone
+ | OtherRepoType Text
+ deriving (Show,Eq,Ord)
+
+-- | Represents the information contained in cabal's @plan.json@ file.
+--
+-- This comprises basic information describing the environment as well
+-- as the install/build plan computed by @cabal@.
+data PlanJson = PlanJson
+ { pjCabalVersion :: !Ver -- ^ Version of @cabal@ frontend
+ , pjCabalLibVersion :: !Ver -- ^ Version of Cabal library
+ , pjCompilerId :: !PkgId -- ^ Name and version of Haskell compiler
+ , pjArch :: !Text -- ^ Architecture name
+ , pjOs :: !Text -- ^ Operating system name
+ , pjUnits :: !(M.Map UnitId Unit) -- ^ install/build plan
+ } deriving Show
+
+-- | Describes kind of build unit and its provenance
+data UnitType = UnitTypeBuiltin -- ^ Lives in global (non-nix-style) package db
+ | UnitTypeGlobal -- ^ Lives in Nix-store cache
+ | UnitTypeLocal -- ^ Local package
+ | UnitTypeInplace -- ^ Local in-place package
+ deriving (Show,Eq)
+
+-- | Represents a build-plan unit uniquely identified by its 'UnitId'
+data Unit = Unit
+ { uId :: !UnitId -- ^ Unit ID uniquely identifying a 'Unit' in install plan
+ , uPId :: !PkgId -- ^ Package name and version (not necessarily unique within plan)
+ , uType :: !UnitType -- ^ Describes type of build item, see 'UnitType'
+ , uSha256 :: !(Maybe Sha256) -- ^ SHA256 source tarball checksum (as used by e.g. @hackage-security@)
+ , uComps :: !(Map CompName CompInfo) -- ^ Components identified by 'UnitId'
+ --
+ -- When @cabal@ needs to fall back to legacy-mode (currently for
+ -- @custom@ build-types or obsolete @cabal-version@ values), 'uComps'
+ -- may contain more than one element.
+ , uFlags :: !(Map FlagName Bool) -- ^ cabal flag settings (not available for 'UnitTypeBuiltin')
+ , uDistDir :: !(Maybe FilePath) -- ^ In-place dist-dir (if available)
+ --
+ -- @since 0.3.0.0
+ , uPkgSrc :: !(Maybe PkgLoc)
+ -- ^ Source of the package
+ --
+ -- @since 0.5.0.0 (TODO)
+ } deriving Show
+
+-- | Component name inside a build-plan unit
+--
+-- A similiar type exists in @Cabal@ codebase, see
+-- @Distribution.Simple.LocalBuildInfo.ComponentName@
+data CompName =
+ CompNameLib
+ | CompNameSubLib !Text
+ | CompNameFLib !Text -- ^ @since 0.3.0.0
+ | CompNameExe !Text
+ | CompNameTest !Text
+ | CompNameBench !Text
+ | CompNameSetup
+ deriving (Show, Eq, Ord)
+
+-- | Describes component-specific information inside a 'Unit'
+data CompInfo = CompInfo
+ { ciLibDeps :: Set UnitId -- ^ library dependencies
+ , ciExeDeps :: Set UnitId -- ^ executable dependencies
+ , ciBinFile :: Maybe FilePath -- ^ path-name of artifact if available
+ } deriving Show
+
+----------------------------------------------------------------------------
+----------------------------------------------------------------------------
+----------------------------------------------------------------------------
+
+-- JSON instances
+
+instance FromJSON CompName where
+ parseJSON = withText "CompName" (maybe (fail "invalid CompName") pure . parseCompName)
+
+instance ToJSON CompName where
+ toJSON = toJSON . dispCompName
+
+instance FromJSONKey CompName where
+ fromJSONKey = FromJSONKeyTextParser (maybe (fail "CompName") pure . parseCompName)
+
+instance ToJSONKey CompName where
+ toJSONKey = toJSONKeyText dispCompName
+
+----
+
+instance FromJSON CompInfo where
+ parseJSON = withObject "CompInfo" $ \o ->
+ CompInfo <$> o .:?! "depends"
+ <*> o .:?! "exe-depends"
+ <*> o .:? "bin-file"
+
+----
+
+instance FromJSON PkgId where
+ parseJSON = withText "PkgId" (maybe (fail "invalid PkgId") pure . parsePkgId)
+
+instance ToJSON PkgId where
+ toJSON = toJSON . dispPkgId
+
+instance FromJSONKey PkgId where
+ fromJSONKey = FromJSONKeyTextParser (maybe (fail "PkgId") pure . parsePkgId)
+
+instance ToJSONKey PkgId where
+ toJSONKey = toJSONKeyText dispPkgId
+
+----
+
+instance FromJSON PkgLoc where
+ parseJSON = withObject "PkgSrc" $ \o -> do
+ ty <- o .: "type"
+ case ty :: Text of
+ "local" -> LocalUnpackedPackage <$> o .: "path"
+ "local-tar" -> LocalTarballPackage <$> o .: "path"
+ "remote-tar" -> RemoteTarballPackage <$> o .: "uri"
+ "repo-tar" -> RepoTarballPackage <$> o .: "repo"
+ "source-repo" -> RemoteSourceRepoPackage <$> o .: "source-repo"
+ _ -> fail "invalid PkgSrc \"type\""
+
+instance FromJSON Repo where
+ parseJSON = withObject "Repo" $ \o -> do
+ ty <- o .: "type"
+ case ty :: Text of
+ "local-repo" -> RepoLocal <$> o .: "path"
+ "remote-repo" -> RepoRemote <$> o .: "uri"
+ "secure-repo" -> RepoSecure <$> o .: "uri"
+ _ -> fail "invalid Repo \"type\""
+
+instance FromJSON SourceRepo where
+ parseJSON = withObject "SourceRepo" $ \o -> do
+ SourceRepo <$> o .:? "type"
+ <*> o .:? "location"
+ <*> o .:? "module"
+ <*> o .:? "branch"
+ <*> o .:? "tag"
+ <*> o .:? "subdir"
+
+instance FromJSON RepoType where
+ parseJSON = withText "RepoType" $ \ty -> return $
+ case ty of
+ "darcs" -> Darcs
+ "git" -> Git
+ "svn" -> SVN
+ "cvs" -> CVS
+ "mercurial" -> Mercurial
+ "gnuarch" -> GnuArch
+ "bazaar" -> Bazaar
+ "monotone" -> Monotone
+ _ -> OtherRepoType ty
+
+----------------------------------------------------------------------------
+-- parser helpers
+
+parseCompName :: Text -> Maybe CompName
+parseCompName t0 = case T.splitOn ":" t0 of
+ ["lib"] -> Just CompNameLib
+ ["lib",n] -> Just $! CompNameSubLib n
+ ["flib",n] -> Just $! CompNameFLib n
+ ["exe",n] -> Just $! CompNameExe n
+ ["bench",n] -> Just $! CompNameBench n
+ ["test",n] -> Just $! CompNameTest n
+ ["setup"] -> Just CompNameSetup
+ _ -> Nothing
+
+-- | Pretty print 'CompName'
+dispCompName :: CompName -> Text
+dispCompName cn = case cn of
+ CompNameLib -> "lib"
+ CompNameSubLib n -> "lib:" <> n
+ CompNameFLib n -> "flib:" <> n
+ CompNameExe n -> "exe:" <> n
+ CompNameBench n -> "bench:" <> n
+ CompNameTest n -> "test:" <> n
+ CompNameSetup -> "setup"
+
+instance FromJSON PlanJson where
+ parseJSON = withObject "PlanJson" $ \o -> do
+ pjCabalVersion <- o .: "cabal-version"
+
+ unless (pjCabalVersion >= Ver [2]) $
+ fail ("plan.json version " ++ T.unpack (dispVer pjCabalVersion) ++ " not supported")
+
+ pjCabalLibVersion <- o .: "cabal-lib-version"
+ pjCompilerId <- o .: "compiler-id"
+ pjArch <- o .: "arch"
+ pjOs <- o .: "os"
+ pjUnits <- toMap =<< o .: "install-plan"
+
+ App.pure PlanJson{..}
+ where
+ toMap pil = do
+ let pim = M.fromList [ (uId pi',pi') | pi' <- pil ]
+ unless (M.size pim == length pil) $
+ fail "install-plan[] has duplicate ids"
+ pure pim
+
+(.:?!) :: (FromJSON a, Monoid a) => Object -> Text -> Parser a
+o .:?! fld = o .:? fld .!= mempty
+
+planItemAllDeps :: Unit -> Set UnitId
+planItemAllDeps Unit{..} = mconcat [ ciLibDeps <> ciExeDeps | CompInfo{..} <- M.elems uComps ]
+
+instance FromJSON Unit where
+ parseJSON = withObject "Unit" $ \o -> do
+ mcomponents <- o .:? "components"
+ mcomponentname <- o .:? "component-name"
+ ty <- o .: "type"
+ mstyle <- o .:? "style"
+
+ uId <- o .: "id"
+ uPId <- PkgId <$> o .: "pkg-name" <*> o .: "pkg-version"
+ uType <- case (ty :: Text, mstyle :: Maybe Text) of
+ ("pre-existing",Nothing) -> pure UnitTypeBuiltin
+ ("configured",Just "global") -> pure UnitTypeGlobal
+ ("configured",Just "local") -> pure UnitTypeLocal
+ ("configured",Just "inplace") -> pure UnitTypeInplace
+ _ -> fail (show (ty,mstyle))
+ uFlags <- o .:?! "flags"
+ uSha256 <- o .:? "pkg-src-sha256"
+ uComps <- case (mcomponents, mcomponentname) of
+ (Just comps0, Nothing) ->
+ pure comps0
+ (Nothing, Just cname) ->
+ M.singleton cname <$> parseJSON (Object o)
+ (Nothing, Nothing) | uType == UnitTypeBuiltin ->
+ M.singleton CompNameLib <$> parseJSON (Object o)
+ _ -> fail (show o)
+
+ uDistDir <- o .:? "dist-dir"
+
+ uPkgSrc <- o .:? "pkg-src"
+
+ pure Unit{..}
+
+----------------------------------------------------------------------------
+-- Convenience helper
+
+-- | Where/how to search for the plan.json file.
+data SearchPlanJson
+ = ProjectRelativeToDir FilePath -- ^ Find the project root relative to
+ -- specified directory and look for
+ -- plan.json there.
+ | InBuildDir FilePath -- ^ Look for plan.json in specified build
+ -- directory.
+ deriving (Eq, Show, Read)
+
+-- | Locates the project root for cabal project relative to specified
+-- directory.
+--
+-- @plan.json@ is located from either the optional build dir argument, or in
+-- the default directory (@dist-newstyle@) relative to the project root.
+--
+-- The folder assumed to be the project-root is returned as well.
+--
+-- This function determines the project root in a slightly more liberal manner
+-- than cabal-install. If no cabal.project is found, cabal-install assumes an
+-- implicit cabal.project if the current directory contains any *.cabal files.
+--
+-- This function looks for any *.cabal files in directories above the current
+-- one and behaves as if there is an implicit cabal.project in that directory
+-- when looking for a plan.json.
+--
+-- Throws 'IO' exceptions on errors.
+--
+findAndDecodePlanJson
+ :: SearchPlanJson
+ -> IO PlanJson
+findAndDecodePlanJson searchLoc = do
+ distFolder <- case searchLoc of
+ InBuildDir builddir -> pure builddir
+ ProjectRelativeToDir fp -> do
+ mRoot <- findProjectRoot fp
+ case mRoot of
+ Nothing -> fail ("missing project root relative to: " ++ fp)
+ Just dir -> pure $ dir </> "dist-newstyle"
+
+ haveDistFolder <- Dir.doesDirectoryExist distFolder
+
+ unless haveDistFolder $
+ fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?")
+
+ let planJsonFn = distFolder </> "cache" </> "plan.json"
+
+ havePlanJson <- Dir.doesFileExist planJsonFn
+
+ unless havePlanJson $
+ fail "missing 'plan.json' file; do you need to run 'cabal new-build'?"
+
+ decodePlanJson planJsonFn
+
+-- | Decodes @plan.json@ file location provided as 'FilePath'
+--
+-- This is a trivial convenience function so that the caller doesn't
+-- have to depend on @aeson@ directly
+--
+-- Throws 'IO' exceptions on errors.
+--
+decodePlanJson :: FilePath -> IO PlanJson
+decodePlanJson planJsonFn = do
+ jsraw <- B.readFile planJsonFn
+ either fail pure $ eitherDecodeStrict' jsraw
+
+-- | Find project root relative to a directory, this emulates cabal's current
+-- heuristic, but is slightly more liberal. If no cabal.project is found,
+-- cabal-install looks for *.cabal files in the specified directory only. This
+-- function also considers *.cabal files in directories higher up in the
+-- hierarchy.
+findProjectRoot :: FilePath -> IO (Maybe FilePath)
+findProjectRoot dir = do
+ normalisedPath <- Dir.canonicalizePath dir
+ let checkCabalProject d = do
+ ex <- Dir.doesFileExist fn
+ return $ if ex then Just d else Nothing
+ where
+ fn = d </> "cabal.project"
+
+ checkCabal d = do
+ files <- listDirectory d
+ return $ if any (isExtensionOf ".cabal") files
+ then Just d
+ else Nothing
+
+ result <- walkUpFolders checkCabalProject normalisedPath
+ case result of
+ Just rootDir -> pure $ Just rootDir
+ Nothing -> walkUpFolders checkCabal normalisedPath
+ where
+ isExtensionOf :: String -> FilePath -> Bool
+ isExtensionOf ext fp = ext == takeExtension fp
+
+ listDirectory :: FilePath -> IO [FilePath]
+ listDirectory fp = filter isSpecialDir <$> Dir.getDirectoryContents fp
+ where
+ isSpecialDir f = f /= "." && f /= ".."
+
+walkUpFolders
+ :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe a)
+walkUpFolders dtest d0 = do
+ home <- Dir.getHomeDirectory
+
+ let go d | d == home = pure Nothing
+ | isDrive d = pure Nothing
+ | otherwise = do
+ t <- dtest d
+ case t of
+ Nothing -> go $ takeDirectory d
+ x@Just{} -> pure x
+
+ go d0
+
+parseVer :: Text -> Maybe Ver
+parseVer str = case reverse $ readP_to_S DV.parseVersion (T.unpack str) of
+ (ver, "") : _ | not (null (DV.versionBranch ver)), all (>= 0) (DV.versionBranch ver)
+ -> Just (Ver $ DV.versionBranch ver)
+ _ -> Nothing
+
+-- | Pretty print 'Ver'
+dispVer :: Ver -> Text
+dispVer (Ver ns) = T.pack $ intercalate "." (map show ns)
+
+instance FromJSON Ver where
+ parseJSON = withText "Ver" (maybe (fail "Ver") pure . parseVer)
+
+instance ToJSON Ver where
+ toJSON = toJSON . dispVer
+
+parsePkgId :: Text -> Maybe PkgId
+parsePkgId t = do
+ let (pns_, pvs) = T.breakOnEnd "-" t
+ pv <- parseVer pvs
+
+ pn <- T.stripSuffix "-" pns_
+
+ -- TODO: validate pn
+ pure (PkgId (PkgName pn) pv)
+
+-- | Pretty print 'PkgId'
+dispPkgId :: PkgId -> Text
+dispPkgId (PkgId (PkgName pn) pv) = pn <> "-" <> dispVer pv
+
+
+-- | Pretty print 'Sha256' as base-16.
+dispSha256 :: Sha256 -> Text
+dispSha256 (Sha256 s) = T.decodeLatin1 (B16.encode s)
+
+-- | Parse base-16 encoded 'Sha256'.
+--
+-- Returns 'Nothing' in case of parsing failure.
+--
+-- @since 0.3.0.0
+parseSha256 :: Text -> Maybe Sha256
+parseSha256 t
+ | B.length s == 32, B.null rest = Just (Sha256 s)
+ | otherwise = Nothing
+ where
+ (s, rest) = B16.decode $ T.encodeUtf8 t
+
+-- | Export the 'Sha256' digest to a 32-byte 'B.ByteString'.
+--
+-- @since 0.3.0.0
+sha256ToByteString :: Sha256 -> B.ByteString
+sha256ToByteString (Sha256 bs) = bs
+
+-- | Import the 'Sha256' digest from a 32-byte 'B.ByteString'.
+--
+-- Returns 'Nothing' if input 'B.ByteString' has incorrect length.
+--
+-- @since 0.3.0.0
+sha256FromByteString :: B.ByteString -> Maybe Sha256
+sha256FromByteString bs
+ | B.length bs == 32 = Just (Sha256 bs)
+ | otherwise = Nothing
+
+instance FromJSON Sha256 where
+ parseJSON = withText "Sha256" (maybe (fail "Sha256") pure . parseSha256)
+
+instance ToJSON Sha256 where
+ toJSON = toJSON . dispSha256
+
+instance Show Sha256 where
+ show = show . dispSha256
+
+----------------------------------------------------------------------------
+
+-- | Extract directed 'UnitId' dependency graph edges from 'pjUnits'
+--
+-- This graph contains both, library and executable dependencies edges
+planJsonIdGraph :: PlanJson -> Map UnitId (Set UnitId)
+planJsonIdGraph PlanJson{..} = M.fromList [ (uId unit, planItemAllDeps unit)
+ | unit <- M.elems pjUnits
+ ]
+
+-- | Extract 'UnitId' root nodes from dependency graph computed by 'planJsonIdGraph'
+planJsonIdRoots :: PlanJson -> Set UnitId
+planJsonIdRoots PlanJson{..} = M.keysSet pjUnits `S.difference` nonRoots
+ where
+ nonRoots :: Set UnitId
+ nonRoots = mconcat $ M.elems $ planJsonIdGraph PlanJson{..}