diff options
Diffstat (limited to 'cabal-plan/src')
| -rwxr-xr-x | cabal-plan/src/Cabal/Plan.hs | 586 |
1 files changed, 0 insertions, 586 deletions
diff --git a/cabal-plan/src/Cabal/Plan.hs b/cabal-plan/src/Cabal/Plan.hs deleted file mode 100755 index d65c581..0000000 --- a/cabal-plan/src/Cabal/Plan.hs +++ /dev/null @@ -1,586 +0,0 @@ -{-# 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 - , dispCompNameTarget - , 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' in cabal's target-selector syntax. -dispCompNameTarget :: PkgName -> CompName -> Text -dispCompNameTarget (PkgName pkg) cn = case cn of - CompNameLib -> "lib:" <> pkg - _ -> dispCompName cn - --- | Pretty print 'CompName' in the same syntax that is used in --- @plan.json@. Note that this string can not be used as a target-selector on --- the cabal command-line. See 'dispCompNameTarget' for a target-selector --- compatible pretty printer. -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{..} |