diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -28,57 +28,6 @@ import Stackage.CorePackages import Stackage.Prelude -data TestState = ExpectSuccess - | ExpectFailure - | Don'tBuild -- ^ when the test suite will pull in things we don't want - deriving (Show, Eq, Ord, Bounded, Enum) - -testStateToText :: TestState -> Text -testStateToText ExpectSuccess = "expect-success" -testStateToText ExpectFailure = "expect-failure" -testStateToText Don'tBuild = "do-not-build" - -instance ToJSON TestState where - toJSON = toJSON . testStateToText -instance FromJSON TestState where - parseJSON = withText "TestState" $ \t -> - case lookup t states of - Nothing -> fail $ "Invalid state: " ++ unpack t - Just v -> return v - where - states = asHashMap $ mapFromList - $ map (\x -> (testStateToText x, x)) [minBound..maxBound] - -data SystemInfo = SystemInfo - { siGhcVersion :: Version - , siOS :: OS - , siArch :: Arch - , siCorePackages :: Map PackageName Version - , siCoreExecutables :: Set ExeName - } - deriving (Show, Eq, Ord) -instance ToJSON SystemInfo where - toJSON SystemInfo {..} = object - [ "ghc-version" .= display siGhcVersion - , "os" .= display siOS - , "arch" .= display siArch - , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages) - , "core-executables" .= siCoreExecutables - ] -instance FromJSON SystemInfo where - parseJSON = withObject "SystemInfo" $ \o -> do - let helper name = (o .: name) >>= either (fail . show) return . simpleParse - siGhcVersion <- helper "ghc-version" - siOS <- helper "os" - siArch <- helper "arch" - siCorePackages <- (o .: "core-packages") >>= goPackages - siCoreExecutables <- o .: "core-executables" - return SystemInfo {..} - where - goPackages = either (fail . show) return - . mapM simpleParse - . Map.mapKeysWith const mkPackageName - data BuildConstraints = BuildConstraints { bcPackages :: Set PackageName -- ^ This does not include core packages. @@ -89,39 +38,6 @@ , bcGithubUsers :: Map Text (Set Text) -- ^ map an account to set of pingees } - -data PackageConstraints = PackageConstraints - { pcVersionRange :: VersionRange - , pcMaintainer :: Maybe Maintainer - , pcTests :: TestState - , pcHaddocks :: TestState - , pcBuildBenchmarks :: Bool - , pcFlagOverrides :: Map FlagName Bool - , pcEnableLibProfile :: Bool - } - deriving (Show, Eq) -instance ToJSON PackageConstraints where - toJSON PackageConstraints {..} = object $ addMaintainer - [ "version-range" .= display pcVersionRange - , "tests" .= pcTests - , "haddocks" .= pcHaddocks - , "build-benchmarks" .= pcBuildBenchmarks - , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides - , "library-profiling" .= pcEnableLibProfile - ] - where - addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer -instance FromJSON PackageConstraints where - parseJSON = withObject "PackageConstraints" $ \o -> do - pcVersionRange <- (o .: "version-range") - >>= either (fail . show) return . simpleParse - pcTests <- o .: "tests" - pcHaddocks <- o .: "haddocks" - pcBuildBenchmarks <- o .: "build-benchmarks" - pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags" - pcMaintainer <- o .:? "maintainer" - pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") - return PackageConstraints {..} -- | The proposed plan from the requirements provided by contributors. -- diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -29,68 +29,6 @@ import Stackage.PackageIndex import Stackage.Prelude -data BuildPlan = BuildPlan - { bpSystemInfo :: SystemInfo - , bpTools :: Vector (PackageName, Version) - , bpPackages :: Map PackageName PackagePlan - , bpGithubUsers :: Map Text (Set Text) - } - deriving (Show, Eq) - -instance ToJSON BuildPlan where - toJSON BuildPlan {..} = object - [ "system-info" .= bpSystemInfo - , "tools" .= map goTool bpTools - , "packages" .= Map.mapKeysWith const unPackageName bpPackages - , "github-users" .= bpGithubUsers - ] - where - goTool (k, v) = object - [ "name" .= display k - , "version" .= display v - ] -instance FromJSON BuildPlan where - parseJSON = withObject "BuildPlan" $ \o -> do - bpSystemInfo <- o .: "system-info" - bpTools <- (o .: "tools") >>= mapM goTool - bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") - bpGithubUsers <- o .:? "github-users" .!= mempty - return BuildPlan {..} - where - goTool = withObject "Tool" $ \o -> (,) - <$> ((o .: "name") >>= - either (fail . show) return . simpleParse . asText) - <*> ((o .: "version") >>= - either (fail . show) return . simpleParse . asText) - -data PackagePlan = PackagePlan - { ppVersion :: Version - , ppGithubPings :: Set Text - , ppUsers :: Set PackageName - , ppConstraints :: PackageConstraints - , ppDesc :: SimpleDesc - } - deriving (Show, Eq) - -instance ToJSON PackagePlan where - toJSON PackagePlan {..} = object - [ "version" .= asText (display ppVersion) - , "github-pings" .= ppGithubPings - , "users" .= map unPackageName (unpack ppUsers) - , "constraints" .= ppConstraints - , "description" .= ppDesc - ] -instance FromJSON PackagePlan where - parseJSON = withObject "PackageBuild" $ \o -> do - ppVersion <- o .: "version" - >>= either (fail . show) return - . simpleParse . asText - ppGithubPings <- o .:? "github-pings" .!= mempty - ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) - ppConstraints <- o .: "constraints" - ppDesc <- o .: "description" - return PackagePlan {..} - -- | Make a build plan given these package set and build constraints. newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs --- a/Stackage/PackageDescription.hs +++ b/Stackage/PackageDescription.hs @@ -27,88 +27,6 @@ import Distribution.System (Arch, OS) import Stackage.Prelude -data Component = CompLibrary - | CompExecutable - | CompTestSuite - | CompBenchmark - deriving (Show, Read, Eq, Ord, Enum, Bounded) - -compToText :: Component -> Text -compToText CompLibrary = "library" -compToText CompExecutable = "executable" -compToText CompTestSuite = "test-suite" -compToText CompBenchmark = "benchmark" - -instance ToJSON Component where - toJSON = toJSON . compToText -instance FromJSON Component where - parseJSON = withText "Component" $ \t -> maybe - (fail $ "Invalid component: " ++ unpack t) - return - (lookup t comps) - where - comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound] - -data DepInfo = DepInfo - { diComponents :: Set Component - , diRange :: VersionRange - } - deriving (Show, Eq) - -instance Semigroup DepInfo where - DepInfo a x <> DepInfo b y = DepInfo - (a <> b) - (intersectVersionRanges x y) -instance ToJSON DepInfo where - toJSON DepInfo {..} = object - [ "components" .= diComponents - , "range" .= display diRange - ] -instance FromJSON DepInfo where - parseJSON = withObject "DepInfo" $ \o -> do - diComponents <- o .: "components" - diRange <- o .: "range" >>= either (fail . show) return . simpleParse - return DepInfo {..} - --- | A simplified package description that tracks: --- --- * Package dependencies --- --- * Build tool dependencies --- --- * Provided executables --- --- It has fully resolved all conditionals -data SimpleDesc = SimpleDesc - { sdPackages :: Map PackageName DepInfo - , sdTools :: Map ExeName DepInfo - , sdProvidedExes :: Set ExeName - , sdModules :: Set Text - -- ^ modules exported by the library - } - deriving (Show, Eq) -instance Monoid SimpleDesc where - mempty = SimpleDesc mempty mempty mempty mempty - mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc - (unionWith (<>) a w) - (unionWith (<>) b x) - (c ++ y) - (d ++ z) -instance ToJSON SimpleDesc where - toJSON SimpleDesc {..} = object - [ "packages" .= Map.mapKeysWith const unPackageName sdPackages - , "tools" .= Map.mapKeysWith const unExeName sdTools - , "provided-exes" .= sdProvidedExes - , "modules" .= sdModules - ] -instance FromJSON SimpleDesc where - parseJSON = withObject "SimpleDesc" $ \o -> do - sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") - sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools") - sdProvidedExes <- o .: "provided-exes" - sdModules <- o .: "modules" - return SimpleDesc {..} - -- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the -- constraints in the provided 'CheckCond'. toSimpleDesc :: MonadThrow m diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs --- a/Stackage/Prelude.hs +++ b/Stackage/Prelude.hs @@ -23,52 +23,7 @@ import Filesystem (createTree) import Filesystem.Path (parent) import qualified Filesystem.Path as F - -unPackageName :: PackageName -> Text -unPackageName (PackageName str) = pack str - -unFlagName :: FlagName -> Text -unFlagName (FlagName str) = pack str - -mkPackageName :: Text -> PackageName -mkPackageName = PackageName . unpack - -mkFlagName :: Text -> FlagName -mkFlagName = FlagName . unpack - -display :: DT.Text a => a -> Text -display = fromString . DT.display - -simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a -simpleParse orig = withTypeRep $ \rep -> - case DT.simpleParse str of - Nothing -> throwM (ParseFailedException rep (pack str)) - Just v -> return v - where - str = unpack orig - - withTypeRep :: Typeable a => (TypeRep -> m a) -> m a - withTypeRep f = - res - where - res = f (typeOf (unwrap res)) - - unwrap :: m a -> a - unwrap _ = error "unwrap" - -data ParseFailedException = ParseFailedException TypeRep Text - deriving (Show, Typeable) -instance Exception ParseFailedException - -newtype Maintainer = Maintainer { unMaintainer :: Text } - deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) - --- | Name of an executable. -newtype ExeName = ExeName { unExeName :: Text } - deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) - -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y +import Stackage.Types as X -- | There seems to be a bug in Cabal where serializing and deserializing -- version ranges winds up with different representations. So we have a diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs --- a/Stackage/ServerBundle.hs +++ b/Stackage/ServerBundle.hs @@ -32,6 +32,7 @@ import qualified Text.XML as X import Text.XML.Cursor import System.PosixCompat.Files (createSymbolicLink) +import Stackage.Types -- | Get current time epochTime :: IO Tar.EpochTime @@ -83,23 +84,6 @@ map (\(PackageName name) -> name) (M.keys $ siCorePackages bpSystemInfo) --- | Package name is key -type DocMap = Map Text PackageDocs -data PackageDocs = PackageDocs - { pdVersion :: Text - , pdModules :: Map Text [Text] - -- ^ module name, path - } -instance ToJSON PackageDocs where - toJSON PackageDocs {..} = object - [ "version" .= pdVersion - , "modules" .= pdModules - ] -instance FromJSON PackageDocs where - parseJSON = withObject "PackageDocs" $ \o -> PackageDocs - <$> o .: "version" - <*> o .: "modules" - docsListing :: BuildPlan -> FilePath -- ^ docs directory -> IO DocMap @@ -139,29 +123,6 @@ , pdModules = m } else return mempty - -data SnapshotType = STNightly - | STLTS !Int !Int -- ^ major, minor - deriving (Show, Read, Eq, Ord) - -instance ToJSON SnapshotType where - toJSON STNightly = object - [ "type" .= asText "nightly" - ] - toJSON (STLTS major minor) = object - [ "type" .= asText "lts" - , "major" .= major - , "minor" .= minor - ] -instance FromJSON SnapshotType where - parseJSON = withObject "SnapshotType" $ \o -> do - t <- o .: "type" - case asText t of - "nightly" -> return STNightly - "lts" -> STLTS - <$> o .: "major" - <*> o .: "minor" - _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t data CreateBundleV2 = CreateBundleV2 { cb2Plan :: BuildPlan diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -8,7 +8,7 @@ import Data.Version import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) -import Paths_stackage (version) +import Paths_stackage_curator (version) import Stackage.CompleteBuild import Stackage.Upload import Stackage.InstallBuild diff --git a/stackage-curator.cabal b/stackage-curator.cabal --- a/stackage-curator.cabal +++ b/stackage-curator.cabal @@ -1,5 +1,5 @@ name: stackage-curator -version: 0.7.0 +version: 0.7.0.1 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -66,13 +66,14 @@ , semigroups , xml-conduit , conduit + , stackage-types executable stackage-curator default-language: Haskell2010 hs-source-dirs: app main-is: stackage.hs build-depends: base - , stackage + , stackage-curator , optparse-applicative >= 0.11 , system-filepath , http-client @@ -89,7 +90,7 @@ Stackage.PackageIndexSpec Stackage.BuildPlanSpec build-depends: base - , stackage + , stackage-curator , hspec , QuickCheck , text