diff options
Diffstat (limited to 'cabal-plan/src/Cabal')
| -rwxr-xr-x | cabal-plan/src/Cabal/Plan.hs | 576 |
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{..} |