stackage-curator 0.10.0 → 0.11.0
raw patch · 19 files changed
+401/−420 lines, 19 filesdep +luciddep ~amazonkadep ~classy-prelude-conduitdep ~xml-conduit
Dependencies added: lucid
Dependency ranges changed: amazonka, classy-prelude-conduit, xml-conduit
Files
- ChangeLog.md +4/−0
- Stackage/BuildConstraints.hs +6/−7
- Stackage/BuildPlan.hs +0/−2
- Stackage/CompleteBuild.hs +53/−152
- Stackage/CorePackages.hs +4/−3
- Stackage/Curator/UploadDocs.hs +39/−30
- Stackage/Curator/UploadIndex.hs +5/−35
- Stackage/DiffPlans.hs +129/−34
- Stackage/GhcPkg.hs +7/−11
- Stackage/InstallBuild.hs +3/−2
- Stackage/PackageDescription.hs +0/−2
- Stackage/PackageIndex.hs +17/−12
- Stackage/PerformBuild.hs +54/−51
- Stackage/Prelude.hs +5/−8
- Stackage/ServerBundle.hs +19/−21
- Stackage/Stats.hs +1/−1
- Stackage/Upload.hs +5/−11
- app/stackage.hs +45/−34
- stackage-curator.cabal +5/−4
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.11.0++* Use newest version of libraries [#6](https://github.com/fpco/stackage-curator/issues/6)+ ## 0.10.0 * Added `pcSkipBuild`
Stackage/BuildConstraints.hs view
@@ -23,13 +23,12 @@ import qualified Data.Map as Map import Data.Yaml (decodeEither', decodeFileEither) import Distribution.Package (Dependency (..))-import Distribution.System (Arch, OS) import qualified Distribution.System import Distribution.Version (anyVersion)-import Filesystem (isFile) import Network.HTTP.Client (Manager, httpLbs, responseBody, Request) import Stackage.CorePackages import Stackage.Prelude+import System.Directory (doesFileExist) data BuildConstraints = BuildConstraints { bcPackages :: Set PackageName@@ -75,7 +74,7 @@ loadBuildConstraints bcs man = do case bcs of BCSDefault -> do- e <- isFile fp0+ e <- doesFileExist fp0 if e then loadFile fp0 else loadReq req0@@ -85,7 +84,7 @@ fp0 = "build-constraints.yaml" req0 = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml" - loadFile fp = decodeFileEither (fpToString fp) >>= either throwIO toBC+ loadFile fp = decodeFileEither fp >>= either throwIO toBC loadReq req = httpLbs req man >>= either throwIO toBC . decodeEither' . toStrict . responseBody @@ -143,9 +142,9 @@ _ -> fail $ "Invalid GHC major version: " ++ unpack t data MismatchedGhcVersion = MismatchedGhcVersion- { mgvGhcOnPath :: !Version- , mgvExpectedMajor :: !Int- , mgcExpectedMinor :: !Int+ { _mgvGhcOnPath :: !Version+ , _mgvExpectedMajor :: !Int+ , _mgcExpectedMinor :: !Int } deriving (Show, Typeable) instance Exception MismatchedGhcVersion
Stackage/BuildPlan.hs view
@@ -19,9 +19,7 @@ ) where import Control.Monad.State.Strict (execState, get, put)-import Data.Aeson import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Distribution.Compiler import Distribution.PackageDescription import Stackage.BuildConstraints
Stackage/CompleteBuild.hs view
@@ -5,9 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Stackage.CompleteBuild- ( BuildType (..)- , BumpType (..)- , BuildFlags (..)+ ( BuildFlags (..) , checkPlan , getStackageAuthToken , createPlan@@ -22,14 +20,11 @@ import System.Directory (getAppUserDataDirectory) import Distribution.Package (Dependency)-import Filesystem (isDirectory, createTree, isFile, rename)+import Filesystem (createTree, isFile, rename) import Filesystem.Path (parent)+import qualified Filesystem.Path.CurrentOS as F import Control.Concurrent (threadDelay, getNumCapabilities) import Control.Concurrent.Async (withAsync)-import Data.Default.Class (def)-import Data.Semigroup (Max (..), Option (..))-import Data.Text.Read (decimal)-import Data.Time import Data.Yaml (decodeFileEither, encodeFile, decodeEither') import Network.HTTP.Client import Network.HTTP.Client.Conduit (bodyReaderSource)@@ -43,11 +38,12 @@ import Stackage.UpdateBuildPlan import Stackage.Upload import System.Environment (lookupEnv)-import System.IO (BufferMode (LineBuffering), hSetBuffering)+import Filesystem.Path (dropExtension) import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift) import Data.Function (fix) import Control.Concurrent.Async (Concurrently (..)) import Stackage.Curator.UploadDocs (uploadDocs)+import System.Directory (doesDirectoryExist, doesFileExist) -- | Flags passed in from the command line. data BuildFlags = BuildFlags@@ -69,106 +65,12 @@ , bfLoadPlan :: !Bool } deriving (Show) -data BuildType = Nightly | LTS BumpType Text- deriving (Show, Read, Eq, Ord)--data BumpType = Major | Minor- deriving (Show, Read, Eq, Ord)--data Settings = Settings- { plan :: BuildPlan- , planFile :: FilePath- , buildDir :: FilePath- , logDir :: FilePath- , title :: Text -> Text -- ^ GHC version -> title- , slug :: Text- , postBuild :: IO ()- , distroName :: Text -- ^ distro name on Hackage- , snapshotType :: SnapshotType- , bundleDest :: FilePath- }--nightlyPlanFile :: Text -- ^ day- -> FilePath-nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"--nightlySettings :: Day- -> BuildFlags- -> BuildPlan- -> Settings-nightlySettings day' bf plan' = Settings- { planFile = fromMaybe (nightlyPlanFile day) (bfPlanFile bf)- , buildDir = fpFromText $ "builds/nightly"- , logDir = fpFromText $ "logs/stackage-nightly-" ++ day- , title = \ghcVer -> concat- [ "Stackage Nightly "- , day- , ", GHC "- , ghcVer- ]- , slug = slug'- , plan = plan'- , postBuild = return ()- , distroName = "Stackage"- , snapshotType = STNightly2 day'- , bundleDest = fromMaybe- (fpFromText $ "stackage-nightly-" ++ day ++ ".bundle")- (bfBundleDest bf)- }- where- slug' = "nightly-" ++ day- day = tshow day'--parseGoal :: MonadThrow m- => BumpType- -> Text- -> m (LTSVer -> Bool)-parseGoal _ "" = return $ const True-parseGoal bumpType t =- case decimal t of- Right (major, "") -> return $ \(LTSVer major' _) ->- case bumpType of- -- For major bumps: specifying 2 means we want to ignore- -- anything in the 2.* range- Major -> major' < major-- -- But for minor bumps, specifying 2 means we want to include- -- everything in 2.*, and start ignore 3.*- Minor -> major' <= major- _ ->- case parseLTSRaw t of- Nothing -> throwM $ ParseGoalFailure t- Just x -> return (< x)--data ParseGoalFailure = ParseGoalFailure Text- deriving (Show, Typeable)-instance Exception ParseGoalFailure--data LTSVer = LTSVer !Int !Int- deriving (Eq, Ord)-instance Show LTSVer where- show (LTSVer x y) = concat [show x, ".", show y]-incrLTSVer :: LTSVer -> LTSVer-incrLTSVer (LTSVer x y) = LTSVer x (y + 1)--parseLTSVer :: FilePath -> Maybe LTSVer-parseLTSVer fp = do- w <- stripPrefix "lts-" $ fpToText fp- x <- stripSuffix ".yaml" w- parseLTSRaw x--parseLTSRaw :: Text -> Maybe LTSVer-parseLTSRaw x = do- Right (major, y) <- Just $ decimal x- z <- stripPrefix "." y- Right (minor, "") <- Just $ decimal z- return $ LTSVer major minor- createPlan :: Target -> FilePath -> [Dependency] -- ^ additional constraints -> IO ()-createPlan target dest constraints = withManager tlsManagerSettings $ \man -> do+createPlan target dest constraints = do+ man <- newManager tlsManagerSettings putStrLn $ "Creating plan for: " ++ tshow target bc <- case target of@@ -190,21 +92,15 @@ plan <- planFromConstraints $ setConstraints constraints bc - putStrLn $ "Writing build plan to " ++ fpToText dest- encodeFile (fpToString dest) plan+ putStrLn $ "Writing build plan to " ++ pack dest+ encodeFile dest plan +planFromConstraints :: MonadIO m => BuildConstraints -> m BuildPlan planFromConstraints bc = do putStrLn "Creating build plan" plans <- getLatestAllowedPlans bc newBuildPlan plans bc -renderLTSVer :: LTSVer -> FilePath-renderLTSVer lts = fpFromText $ concat- [ "lts-"- , tshow lts- , ".yaml"- ]- -- | Just print a message saying "still alive" every minute, to appease Travis. stillAlive :: IO () -> IO () stillAlive inner =@@ -213,13 +109,14 @@ printer i = forever $ do threadDelay 60000000 putStrLn $ "Still alive: " ++ tshow i- printer $! i + 1+ printer $! i + (1 :: Int) -- | Generate and check a new build plan, but do not execute it. -- -- Since 0.3.1 checkPlan :: Maybe FilePath -> IO ()-checkPlan mfp = stillAlive $ withManager tlsManagerSettings $ \man -> do+checkPlan mfp = stillAlive $ do+ man <- newManager tlsManagerSettings plan <- case mfp of Nothing -> do@@ -233,14 +130,15 @@ return plan Just fp -> do- putStrLn $ "Loading plan from " ++ fpToText fp- decodeFileEither (fpToString fp) >>= either throwM return+ putStrLn $ "Loading plan from " ++ pack fp+ decodeFileEither fp >>= either throwM return putStrLn "Checking plan" checkBuildPlan plan putStrLn "Plan seems valid!" +{- FIXME remove getPerformBuild :: BuildFlags -> Settings -> IO PerformBuild getPerformBuild buildFlags Settings {..} = do jobs <- maybe getNumCapabilities return $ bfJobs buildFlags@@ -260,11 +158,11 @@ , pbBuildHoogle = bfBuildHoogle buildFlags } -{- FIXME remove -- | Make a complete plan, build, test and upload bundle, docs and -- distro. completeBuild :: BuildType -> BuildFlags -> IO ()-completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do+completeBuild buildType buildFlags = do+ man <- newManager tlsManagerSettings hSetBuffering stdout LineBuffering settings@Settings {..} <- if bfLoadPlan buildFlags@@ -279,7 +177,7 @@ settings@Settings {..} <- getSettings man buildFlags buildType Nothing putStrLn $ "Writing build plan to: " ++ fpToText planFile- encodeFile (fpToString planFile) plan+ encodeFile planFile plan if bfSkipCheck buildFlags then putStrLn "Skipping build plan check"@@ -347,8 +245,9 @@ :: FilePath -- ^ plan file -> Target -> IO ()-hackageDistro planFile target = withManager tlsManagerSettings $ \man -> do- plan <- decodeFileEither (fpToString planFile) >>= either throwM return+hackageDistro planFile target = do+ man <- newManager tlsManagerSettings+ plan <- decodeFileEither planFile >>= either throwM return ecreds <- tryIO $ readFile "/hackage-creds" case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of [username, password] -> do@@ -364,7 +263,7 @@ checkoutRepo :: Target -> IO ([String] -> IO (), FilePath, FilePath) checkoutRepo target = do- root <- fmap (</> "curator") $ fpFromString <$> getAppUserDataDirectory "stackage"+ root <- fmap (</> "curator") $ getAppUserDataDirectory "stackage" let repoDir = case target of@@ -373,25 +272,25 @@ runIn wdir cmd args = do putStrLn $ concat- [ fpToText wdir+ [ pack wdir , ": " , tshow (cmd:args) ] withCheckedProcess (proc cmd args)- { cwd = Just $ fpToString wdir+ { cwd = Just wdir } $ \ClosedStream Inherited Inherited -> return () git = runIn repoDir "git" name = case target of- TargetNightly day -> fpFromString $ concat+ TargetNightly day -> concat [ "nightly-" , show day , ".yaml" ]- TargetLts x y -> fpFromString $ concat+ TargetLts x y -> concat [ "lts-" , show x , "."@@ -402,19 +301,19 @@ destFPPlan = repoDir </> name destFPDocmap = repoDir </> "docs" </> name - exists <- isDirectory repoDir+ exists <- doesDirectoryExist repoDir if exists then do git ["fetch"] git ["checkout", "origin/master"] else do- createTree $ parent repoDir- runIn "." "git" ["clone", repoUrl, fpToString repoDir]+ createTree $ parent $ fromString repoDir+ runIn "." "git" ["clone", repoUrl, repoDir] - whenM (liftIO $ isFile destFPPlan)- $ error $ "File already exists: " ++ fpToString destFPPlan- whenM (liftIO $ isFile destFPDocmap)- $ error $ "File already exists: " ++ fpToString destFPDocmap+ whenM (liftIO $ doesFileExist destFPPlan)+ $ error $ "File already exists: " ++ destFPPlan+ whenM (liftIO $ doesFileExist destFPDocmap)+ $ error $ "File already exists: " ++ destFPDocmap return (git, destFPPlan, destFPDocmap) where@@ -431,20 +330,21 @@ uploadGithub planFile docmapFile target = do (git, destFPPlan, destFPDocmap) <- checkoutRepo target - createTree $ parent destFPDocmap+ createTree $ parent $ fromString destFPDocmap runResourceT $ do sourceFile planFile $$ (sinkFile destFPPlan :: Sink ByteString (ResourceT IO) ()) sourceFile docmapFile $$ (sinkFile destFPDocmap :: Sink ByteString (ResourceT IO) ()) - git ["add", fpToString destFPPlan, fpToString destFPDocmap]- git ["commit", "-m", "Checking in " ++ fpToString (basename destFPPlan)]+ git ["add", destFPPlan, destFPDocmap]+ git ["commit", "-m", "Checking in " ++ F.encodeString (dropExtension $ fromString destFPPlan)] git ["push", "origin", "HEAD:master"] upload :: FilePath -- ^ bundle file -> StackageServer -- ^ server URL -> IO ()-upload bundleFile server = withManager tlsManagerSettings $ \man -> do+upload bundleFile server = do+ man <- newManager tlsManagerSettings putStrLn "Uploading bundle to Stackage Server" token <- getStackageAuthToken@@ -474,7 +374,7 @@ installDest target = case target of TargetNightly _ -> "builds/nightly"- TargetLts x _ -> fpFromText $ "builds/lts-" ++ tshow x+ TargetLts x _ -> unpack $ "builds/lts-" ++ tshow x makeBundle :: FilePath -- ^ plan file@@ -494,7 +394,7 @@ planFile docmapFile bundleFile target mjobs skipTests skipHaddocks skipHoogle enableLibraryProfiling enableExecutableDynamic verbose allowNewer = do- plan <- decodeFileEither (fpToString planFile) >>= either throwM return+ plan <- decodeFileEither planFile >>= either throwM return jobs <- maybe getNumCapabilities return mjobs let pb = PerformBuild { pbPlan = plan@@ -503,7 +403,7 @@ , pbLogDir = case target of TargetNightly _ -> "logs/nightly"- TargetLts x _ -> fpFromText $ "logs/lts-" ++ tshow x+ TargetLts x _ -> unpack $ "logs/lts-" ++ tshow x , pbJobs = jobs , pbGlobalInstall = False , pbEnableTests = not skipTests@@ -518,7 +418,7 @@ putStrLn "Performing build" performBuild pb >>= mapM_ putStrLn - putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleFile+ putStrLn $ "Creating bundle (v2) at: " ++ pack bundleFile createBundleV2 CreateBundleV2 { cb2Plan = plan , cb2Type =@@ -531,14 +431,15 @@ } fetch :: FilePath -> IO ()-fetch planFile = withManager tlsManagerSettings $ \man -> do+fetch planFile = do+ man <- newManager tlsManagerSettings -- First make sure to fetch all of the dependencies... just in case Hackage -- has an outage. Don't feel like wasting hours of CPU time. putStrLn "Pre-fetching all packages" - plan <- decodeFileEither (fpToString planFile) >>= either throwM return+ plan <- decodeFileEither planFile >>= either throwM return - cabalDir <- fpFromString <$> getAppUserDataDirectory "cabal"+ cabalDir <- getAppUserDataDirectory "cabal" parMapM_ 8 (download man cabalDir) $ mapToList $ bpPackages plan where download man cabalDir (display -> name, display . ppVersion -> version) = do@@ -553,9 +454,9 @@ createTree $ parent fp req <- parseUrl url withResponse req man $ \res -> do- let tmp = fp <.> "tmp"+ let tmp = F.encodeString fp <.> "tmp" runResourceT $ bodyReaderSource (responseBody res) $$ sinkFile tmp- rename tmp fp+ rename (fromString tmp) fp where url = unpack $ concat [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"@@ -564,12 +465,12 @@ , version , ".tar.gz" ]- fp = cabalDir </>+ fp = fromString $ cabalDir </> "packages" </> "hackage.haskell.org" </>- fpFromText name </>- fpFromText version </>- fpFromText (concat [name, "-", version, ".tar.gz"])+ unpack name </>+ unpack version </>+ unpack (concat [name, "-", version, ".tar.gz"]) parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono) => Int
Stackage/CorePackages.hs view
@@ -11,10 +11,11 @@ import Control.Monad.State.Strict (StateT, execStateT, get, modify, put) import qualified Data.Map.Lazy as Map-import qualified Data.Text as T import Filesystem (listDirectory)+import qualified Filesystem.Path.CurrentOS as F import Stackage.Prelude import System.Directory (findExecutable)+import System.FilePath (takeDirectory, takeFileName) addDeepDepends :: PackageName -> StateT (Map PackageName Version) IO () addDeepDepends name@(PackageName name') = do@@ -107,8 +108,8 @@ dir <- case mfp of Nothing -> error "No ghc executable found on PATH"- Just fp -> return $ directory $ fpFromString fp- (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir+ Just fp -> return $ takeDirectory fp+ (setFromList . map (ExeName . pack . takeFileName . F.encodeString)) <$> listDirectory (fromString dir) getGhcVersion :: IO Version getGhcVersion = do
Stackage/Curator/UploadDocs.hs view
@@ -29,15 +29,17 @@ import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import Network.AWS (Credentials (Discover), Env,- Region (NorthVirginia), getEnv,- send)-import Network.AWS.Data (toBody)-import Network.AWS.S3 (ObjectCannedACL (PublicRead),+ Region (NorthVirginia), newEnv,+ send, toBody, runAWS)+import Network.AWS.S3 (ObjectCannedACL (OPublicRead), poACL, poCacheControl, poContentEncoding,- poContentType, putObject)+ poContentType, putObject,+ BucketName (..), ObjectKey (..)) import Network.Mime (defaultMimeLookup) import Stackage.Types (simpleParse)+import qualified System.Directory as Dir+import qualified System.FilePath as FP import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.HTML.DOM (eventConduit)@@ -62,25 +64,23 @@ then set poContentEncoding (Just "gzip") else id) $ set poCacheControl (Just "maxage=31536000")- $ set poACL (Just PublicRead)- $ putObject (toBody body) bucket name+ $ set poACL (Just OPublicRead)+ $ putObject (BucketName bucket) (ObjectKey name) (toBody body) putStrLn $ "Sending " ++ name- eres <- liftResourceT $ send env po- case eres of- Left e -> error $ show e- Right _ -> return ()+ _pors <- liftResourceT $ runAWS env $ send po+ return () --- | Uses 'getEnv' for S3 credentials.+-- | Uses 'newEnv' for S3 credentials. uploadDocs :: FilePath -- ^ directory containing docs -> FilePath -- ^ the bundle file -> Text -- ^ name of current docs, used as prefix in object names -> Text -- ^ bucket name -> IO () uploadDocs input' bundleFile name bucket = do- env <- getEnv NorthVirginia Discover+ env <- newEnv NorthVirginia Discover - unlessM (F.isDirectory input') $ error $ "Could not find directory: " ++ show input'- input <- fmap (</> "") $ F.canonicalizePath input'+ unlessM (Dir.doesDirectoryExist input') $ error $ "Could not find directory: " ++ show input'+ input <- fmap (</> "") $ Dir.canonicalizePath input' let inner = sourceDirectoryDeep False input $$ mapM_C (go input name) runResourceT $ do@@ -94,8 +94,8 @@ -- | Create a TAR entry for each Hoogle txt file. Unfortunately doesn't stream. toEntry :: FilePath -> IO Tar.Entry toEntry fp = do- tp <- either error return $ Tar.toTarPath False $ fpToString $ F.filename fp- Tar.packFileEntry (fpToString fp) tp+ tp <- either error return $ Tar.toTarPath False $ F.encodeString $ F.filename $ fromString fp+ Tar.packFileEntry fp tp upload' :: (MonadResource m, MonadReader (Env, Text) m) => Bool -- ^ compress?@@ -104,14 +104,23 @@ -> m () upload' toCompress name src = do (env, bucket) <- ask- liftResourceT $ src $$ upload toCompress env bucket name+ let loop i = do+ eres <- liftResourceT $ tryAny $ src $$ upload toCompress env bucket name+ case eres of+ Left e+ | i <= (0 :: Int) -> throwIO e+ | otherwise -> do+ putStrLn $ "Exception, retrying: " ++ tshow e+ loop $! i - 1+ Right () -> return ()+ loop 3 isHoogleFile :: FilePath -> FilePath -> Bool isHoogleFile input fp' = fromMaybe False $ do- fp <- F.stripPrefix input fp'+ fp <- F.stripPrefix (fromString input) (fromString fp') [dir, name] <- Just $ F.splitDirectories fp- pkgver <- stripSuffix "/" $ fpToText dir- (fpToText -> pkg, ["txt"]) <- Just $ F.splitExtensions name+ pkgver <- stripSuffix "/" $ pack $ F.encodeString dir+ (pack . F.encodeString -> pkg, ["txt"]) <- Just $ F.splitExtensions name PackageIdentifier pkg1 _ver <- simpleParse pkgver pkg2 <- simpleParse pkg return $ pkg1 == pkg2@@ -123,7 +132,7 @@ -> m () go input name fp | isHoogleFile input fp = tell $! singletonSet fp- | hasExtension fp "html" = do+ | F.hasExtension (fromString fp) "html" = do doc <- sourceFile fp $= eventConduit $= (do@@ -138,12 +147,12 @@ -- Sink to a Document and then use blaze-html to render to avoid using -- XML rendering rules (e.g., empty elements) upload' True key $ sourceLazy (renderHtml $ toHtml doc)- | any (hasExtension fp) $ words "css js png svg gif" = void $ getName fp+ | any (F.hasExtension $ fromString fp) $ words "css js png svg gif" = void $ getName fp | otherwise = upload' True key $ sourceFile fp where- Just suffix = F.stripPrefix input fp+ Just suffix = F.stripPrefix (fromString input) (fromString fp) toRoot = concat $ asList $ replicate (length $ F.splitDirectories suffix) $ asText "../"- key = name ++ "/" ++ fpToText suffix+ key = name ++ "/" ++ pack (F.encodeString suffix) goEvent :: M m => FilePath -- HTML file path@@ -161,8 +170,8 @@ -> m (Name, [Content]) goAttr htmlfp toRoot pair@(name, [ContentText value]) | isRef name && not (".html" `isSuffixOf` value) = do- let fp = F.parent htmlfp </> fpFromText value- exists <- liftIO $ F.isFile fp+ let fp = FP.takeDirectory htmlfp </> unpack value+ exists <- liftIO $ F.isFile $ fromString fp if exists then do x <- getName fp@@ -186,14 +195,14 @@ Just x -> return x Nothing -> do x <- toHash src- modify $ \(m, s) -> (insertMap src x m, s)+ modify $ \(m', s) -> (insertMap src x m', s) return x toHash :: M m => FilePath -> m Text toHash src = do (digest, lbs) <- sourceFile src $$ sink- let hash' = decodeUtf8 $ B16.encode $ toBytes (digest :: Digest SHA256)- name = fpToText $ F.addExtensions ("byhash" </> fpFromText hash') (F.extensions src)+ let hash' = unpack $ decodeUtf8 $ B16.encode $ toBytes (digest :: Digest SHA256)+ name = pack $ F.encodeString $ F.addExtensions (fromString $ "byhash" </> hash') (F.extensions $ fromString src) (m, s) <- get unless (name `member` s) $ do put (m, insertSet name s)
Stackage/Curator/UploadIndex.hs view
@@ -8,47 +8,17 @@ ( uploadIndex ) where -import System.Directory (getAppUserDataDirectory)-import Distribution.Package (Dependency)-import Filesystem (isDirectory, createTree, isFile, rename)-import Filesystem.Path (parent)-import Control.Concurrent (threadDelay, getNumCapabilities)-import Control.Concurrent.Async (withAsync)-import Data.Default.Class (def)-import Data.Semigroup (Max (..), Option (..))-import Data.Text.Read (decimal)-import Data.Time-import Data.Yaml (decodeFileEither, encodeFile, decodeEither')-import Network.HTTP.Client-import Network.HTTP.Client.Conduit (bodyReaderSource)-import Network.HTTP.Client.TLS (tlsManagerSettings)+import Data.Yaml (decodeFileEither) import Stackage.BuildConstraints import Stackage.BuildPlan-import Stackage.CheckBuildPlan-import Stackage.PerformBuild import Stackage.Prelude-import Stackage.ServerBundle-import Stackage.UpdateBuildPlan-import Stackage.Upload-import System.Environment (lookupEnv)-import System.IO (BufferMode (LineBuffering), hSetBuffering)-import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift)-import Data.Function (fix)-import Control.Concurrent.Async (Concurrently (..))-import Stackage.Curator.UploadDocs (uploadDocs) import Stackage.Install (defaultIndexLocation) import Stackage.PackageIndex.Conduit import qualified Codec.Archive.Tar as Tar import Data.Conduit.Lazy (lazyConsume) import Codec.Compression.GZip (compress)-import Network.AWS (Credentials (Discover), Env,- Region (NorthVirginia), getEnv,- send)-import Network.AWS.Data (toBody)-import Network.AWS.S3 (ObjectCannedACL (PublicRead),- poACL, poCacheControl,- poContentEncoding,- poContentType, putObject)+import Network.AWS (Credentials (Discover),+ Region (NorthVirginia), newEnv) import Stackage.Curator.UploadDocs (upload) uploadIndex@@ -58,8 +28,8 @@ -> Text -- ^ key prefix -> IO () uploadIndex bpFile target bucket prefix = do- env <- getEnv NorthVirginia Discover- bp <- decodeFileEither (fpToString bpFile) >>= either throwM return+ env <- newEnv NorthVirginia Discover+ bp <- decodeFileEither bpFile >>= either throwM return let toInclude = getToInclude bp runResourceT $ do entries <- lazyConsume
Stackage/DiffPlans.hs view
@@ -1,66 +1,161 @@-{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, GADTs, NoImplicitPrelude, OverloadedStrings,+ ScopedTypeVariables #-} module Stackage.DiffPlans ( diffPlans ) where -import Stackage.Prelude-import Data.Yaml (decodeFileEither)+import Data.Map (filterWithKey)+import Data.Text (Text, justifyLeft)+import qualified Data.Text as T+import Data.Yaml (decodeFileEither)+import qualified Distribution.Text as DT+import Network.HTTP.Client+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Stackage.Prelude +import Data.Maybe+import Lucid+import System.Directory+ data Change = Added | Deleted | MajorBump | MinorBump | Unchanged deriving (Show, Eq, Ord) data AndOr a = Old a | New a | Both a a deriving Show instance Semigroup (AndOr a) where- Old x <> New y = Both x y- New y <> Old x = Both x y- Old x <> Old _ = Old x- New x <> New _ = New x- Both x y <> _ = Both x y+ Old x <> New y = Both x y+ New y <> Old x = Both x y+ Old x <> Old _ = Old x+ New x <> New _ = New x+ Both x y <> _ = Both x y +type DiffMap = Map Change (Map PackageName (Text,Maybe Text))+ diffPlans :: FilePath -- ^ old YAML build plan file -> FilePath -- ^ new YAML build plan file+ -> Bool -- ^ show just changed packages+ -> Bool -- ^ use colours+ -> Bool -- ^ fetch YAML files from GitHub repo+ -> Bool -- ^ wrap output in HTML -> IO ()-diffPlans oldFP newFP = do+diffPlans oldFP newFP diffsOnly useColor True asHtml = do+ (oldFP', newFP') <- (,) <$> getLTS (fpToString oldFP) <*> getLTS (fpToString newFP)+ diffPlans oldFP' newFP' diffsOnly useColor False asHtml+ delFile $ fpToString oldFP'+ delFile $ fpToString newFP'++ where+ delFile fp = removeFile fp `catch` \(_::SomeException) -> return ()++diffPlans oldFP newFP diffsOnly useColor False asHtml = do old <- fmap Old <$> parse oldFP new <- fmap New <$> parse newFP let combined = unionWith (<>) old new- m :: Map Change (Map PackageName Text)- m = unionsWith mappend $ map go $ mapToList combined+ m :: DiffMap+ m = f . unionsWith mappend . map go $ mapToList combined+ f = if diffsOnly+ then filterWithKey (\k _ -> k /= Unchanged)+ else id - forM_ (mapToList m) $ \(change, m') -> do- print change- forM_ (mapToList m') $ \(pkg, msg) -> do- putStrLn $ concat- [ display pkg- , ": "- , msg- ]- putStrLn ""+ if asHtml+ then print $ htmlOut True m+ else consoleOut useColor m where parse fp = decodeFileEither (fpToString fp) >>= either throwIO (return . toSimple) toSimple = fmap ppVersion . bpPackages - go (name, Old x) = singletonMap Deleted $ singletonMap name $ display x- go (name, New x) = singletonMap Added $ singletonMap name $ display x+ go (name, Old x) = singletonMap Deleted $ singletonMap name (display x, Nothing)+ go (name, New x) = singletonMap Added $ singletonMap name (display x, Nothing) go (name, Both x y)- | x == y = singletonMap Unchanged $ singletonMap name $ display x- | otherwise = singletonMap- (if isMajor x y then MajorBump else MinorBump)- (singletonMap name (concat- [ display x- , " ==> "- , display y- ]))+ | x == y = singletonMap Unchanged $ singletonMap name (display x, Nothing)+ | otherwise = singletonMap+ (if isMajor x y then MajorBump else MinorBump)+ (singletonMap name $ (display x, Just $ display y)) isMajor :: Version -> Version -> Bool isMajor (Version old _) (Version new _) = toPair old /= toPair new where- toPair [] = (0, 0)- toPair [i] = (i, 0)+ toPair [] = (0, 0)+ toPair [i] = (i, 0) toPair (i:j:_) = (i, j)+++-- | Download LTS file from GitHub to TMP dir+-- LTS should not contain extension nor path, i.e. just "lts-2.19"+getLTS :: String -> IO FilePath+getLTS lts = do+ createDirectoryIfMissing True tmpDir+ withManager tlsManagerSettings $ \man -> do+ req <- parseUrl $ ltsRepo <> lts <> ".yaml"+ res <- httpLbs req man+ writeFile fName $ responseBody res+ return fName+ where+ fName = fpFromString $ tmpDir <> lts <> ".yaml"+ ltsRepo = "https://raw.githubusercontent.com/fpco/lts-haskell/master/"+ tmpDir = "/tmp/stackage-curator/"+++-- | Return coloured string, or html colour style, depending on *change* param+colorize :: Bool -> Change -> Text -> Text+colorize useHtml change s =+ case change of+ Deleted -> red s+ Added -> green s+ Unchanged -> s+ MajorBump -> yellow s+ MinorBump -> blue s+ where+ showInColor consCol htmlColor s+ | useHtml = "color: " <> htmlColor+ | otherwise = "\ESC[" <> consCol <> "m" <> s <> "\ESC[0m"++ black = showInColor "30" "black"+ red = showInColor "31" "red"+ green = showInColor "32" "green"+ yellow = showInColor "33" "yellow"+ blue = showInColor "34" "blue"+ magenta = showInColor "35" "magenta"+ cyan = showInColor "36" "cyan"+ white = showInColor "37" "white"+++-- | Display to console+consoleOut :: Bool -> DiffMap -> IO ()+consoleOut useColor m =+ forM_ (mapToList m) $ \(change, m') -> do+ print change+ forM_ (mapToList m') $ \(pkg, (x,y)) ->+ let pkgName = (if useColor then colorize False change else id)+ $ justifyLeft 25 ' ' $ display pkg+ in putStrLn $ pkgName <>+ justifyLeft 9 ' ' x <>+ if isJust y+ then " => " <> fromJust y+ else ""+ putStrLn ""+++-- | Display as HTML. If fullPage is True, display as complete page+htmlOut :: Bool -> DiffMap -> Html ()+htmlOut fullPage m = do+ when fullPage $+ doctypehtml_$ head_ $ do+ meta_ [charset_ "utf-8"]+ style_ "table, th, td {border : 1px solid black; border-collapse: collapse;}\+ \th, td {padding: 5px; text-align: left;}"+ body_ $+ div_ [class_ "ltsDiffs"] $ do+ h3_ "Differences"+ forM_ (mapToList m) $ \(change, m') -> do+ p_ [style_ $ colorize True change ""] $ toHtml $ show change+ table_ $ forM_ (mapToList m') $ \(pkg, (x,y)) ->+ tr_ $ do+ td_ $ toHtml $ display pkg+ td_ $ toHtml $ x+ when (isJust y) $+ td_ $ toHtml $ fromJust y+ br_ []
Stackage/GhcPkg.hs view
@@ -11,15 +11,11 @@ import Data.Conduit.Process import qualified Data.Conduit.Text as CT import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T import Distribution.Compat.ReadP import Distribution.Package import Distribution.Text (parse)-import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP-import Data.Map (Map)-import Data.Version (Version) import Stackage.Prelude import Filesystem (removeTree) @@ -32,9 +28,9 @@ -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup setupPackageDatabase mdb docDir log' toInstall onUnregister = do registered1 <- getRegisteredPackages flags- forM_ registered1 $ \pi@(PackageIdentifier name version) ->+ forM_ registered1 $ \pi'@(PackageIdentifier name version) -> case lookup name toInstall of- Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi+ Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi' _ -> return () broken <- getBrokenPackages flags forM_ broken $ unregisterPackage log' onUnregister docDir flags@@ -48,7 +44,7 @@ "--no-user-package-db" : case mdb of Nothing -> ["--global"]- Just fp -> ["--package-db=" ++ fpToString fp]+ Just fp -> ["--package-db=" ++ fp] -- | Get broken packages. getBrokenPackages :: [String] -> IO [PackageIdentifier]@@ -87,18 +83,18 @@ onUnregister ident -- Delete libraries- sourceProcessWithConsumer+ (_exitCode, ()) <- sourceProcessWithConsumer (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident])) (CT.decodeUtf8 $= CT.lines $= CL.mapMaybe parseLibraryDir- $= CL.mapM_ (void . tryIO . removeTree))+ $= CL.mapM_ (void . tryIO . removeTree . FP.decodeString)) void (readProcessWithExitCode "ghc-pkg" ("unregister": flags ++ ["--force", unpack $ display name]) "") - void $ tryIO $ removeTree $ docDir </> fpFromText (display ident)+ void $ tryIO $ removeTree $ FP.decodeString $ docDir </> unpack (display ident) where- parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: "+ parseLibraryDir = fmap unpack . stripPrefix "library-dirs: "
Stackage/InstallBuild.hs view
@@ -67,12 +67,13 @@ putStrLn $ "Loading build plan" plan <- case ifPlanSource of- BPSBundleWeb url -> withManager tlsManagerSettings $ \man -> do+ BPSBundleWeb url -> do+ man <- newManager tlsManagerSettings req <- parseUrl url res <- httpLbs req man planBSL <- getPlanEntry $ Tar.read $ GZip.decompress (responseBody res) decodeBuildPlan planBSL- BPSFile path -> Yaml.decodeFileEither (fpToString path) >>= either throwM return+ BPSFile path -> Yaml.decodeFileEither path >>= either throwM return if ifSkipCheck then putStrLn "Skipping build plan check"
Stackage/PackageDescription.hs view
@@ -19,8 +19,6 @@ import Control.Monad.Writer.Strict (MonadWriter, execWriterT, tell)-import Data.Aeson-import qualified Data.Map as Map import Distribution.Compiler (CompilerFlavor) import Distribution.Package (Dependency (..)) import Distribution.PackageDescription
Stackage/PackageIndex.hs view
@@ -39,11 +39,11 @@ _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" where getCabalRoot :: IO FilePath- getCabalRoot = fpFromString <$> getAppUserDataDirectory "cabal"+ getCabalRoot = getAppUserDataDirectory "cabal" getRemoteCache s = do ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s- Just $ fpFromText $ T.strip v+ Just $ unpack $ T.strip v -- | A cabal file with name and version parsed from the filepath, and the -- package description itself ready to be parsed. It's left in unparsed form@@ -81,12 +81,12 @@ goContent fp name version lbs = case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of- ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e+ ParseFailed e -> throwM $ CabalParseException fp e ParseOk _warnings gpd -> do let pd = packageDescription gpd PackageIdentifier name' version' = package pd when (name /= name' || version /= version') $- throwM $ MismatchedNameVersion (fpFromString fp)+ throwM $ MismatchedNameVersion fp name name' version version' return gpd @@ -119,13 +119,18 @@ -> (GenericPackageDescription -> IO desc) -> m (Map PackageName desc) getLatestDescriptions f parseDesc = liftIO $ do- m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty- forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc+ -- Parse twice to avoid keeping stuff in memory: once to determine which+ -- versions to keep, once to do the actual parsing.+ liftIO $ putStrLn "Determining target package versions"+ mvers <- runResourceT $ sourcePackageIndex $$ filterC f' =$ flip foldlC mempty+ (\m ucf -> insertWith max (ucfName ucf) (ucfVersion ucf) m)+ liftIO $ putStrLn "Parsing package descriptions"+ runResourceT $ sourcePackageIndex $$ flip foldMC mempty+ (\m ucf ->+ if lookup (ucfName ucf) (asMap mvers) == Just (ucfVersion ucf)+ then do+ desc <- liftIO $ ucfParse ucf >>= parseDesc+ return $! insertMap (ucfName ucf) desc m+ else return m) where f' ucf = f (ucfName ucf) (ucfVersion ucf)- add m ucf =- case lookup name m of- Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m- _ -> insertMap name ucf m- where- name = ucfName ucf
Stackage/PerformBuild.hs view
@@ -19,21 +19,21 @@ import qualified Data.Map as Map import Data.NonNull (fromNullable) import Filesystem (canonicalizePath, createTree,- getWorkingDirectory, isDirectory,- removeTree, rename, isFile, removeFile)+ getWorkingDirectory,+ removeTree, rename, removeFile) import Filesystem.Path (parent)-import qualified Filesystem.Path as F+import qualified Filesystem.Path.CurrentOS as F import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.GhcPkg import Stackage.PackageDescription import Stackage.Prelude hiding (pi)-import System.Directory (findExecutable)+import System.Directory (doesDirectoryExist, doesFileExist, findExecutable)+import qualified System.FilePath as FP import System.Environment (getEnvironment) import System.IO (IOMode (WriteMode), openBinaryFile) import System.IO.Temp (withSystemTempDirectory)-import Data.Yaml (decodeFileEither) data BuildException = BuildException (Map PackageName BuildFailure) [Text] deriving Typeable@@ -150,19 +150,19 @@ performBuild pb = do cwd <- getWorkingDirectory performBuild' pb- { pbInstallDest = cwd </> pbInstallDest pb- , pbLogDir = cwd </> pbLogDir pb+ { pbInstallDest = F.encodeString cwd </> pbInstallDest pb+ , pbLogDir = F.encodeString cwd </> pbLogDir pb } performBuild' :: PerformBuild -> IO [Text] performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do- let removeTree' fp = whenM (isDirectory fp) (removeTree fp)- removeTree' pbLogDir+ let removeTree' fp = whenM (doesDirectoryExist fp) (removeTree $ fromString fp)+ removeTree' $ fromString pbLogDir forM_ (pbDatabase pb) $ \db ->- unlessM (isFile $ db </> "package.cache") $ do- createTree $ parent db- withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])+ unlessM (doesFileExist $ db </> "package.cache") $ do+ createTree $ parent $ fromString db+ withCheckedProcess (proc "ghc-pkg" ["init", db]) $ \ClosedStream Inherited Inherited -> return () pbLog $ encodeUtf8 "Copying built-in Haddocks\n" copyBuiltInHaddocks (pbDocDir pb)@@ -206,7 +206,7 @@ , sbRegisterMutex = mutex , sbModifiedEnv = maybe id- (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))+ (\db -> (("HASKELL_PACKAGE_SANDBOX", db):)) (pbDatabase pb) (filter allowedEnv $ map fixEnv env) , sbHaddockFiles = haddockFiles@@ -220,11 +220,11 @@ when (not $ null errs) $ throwM $ BuildException errs warnings return warnings where- withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)+ withBuildDir f = withSystemTempDirectory "stackage-build" f fixEnv (p, x) -- Thank you Windows having case-insensitive environment variables...- | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)+ | toUpper p == "PATH" = (p, pbBinDir pb ++ pathSep : x) | otherwise = (p, x) allowedEnv (k, _) = k `notMember` bannedEnvs@@ -293,14 +293,14 @@ (return () :: IO ()) where cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))- { cwd = Just $ fpToString wdir+ { cwd = Just wdir , std_out = UseHandle outH , std_err = UseHandle outH , env = Just sbModifiedEnv } runParent = runIn sbBuildDir runChild = runIn childDir- childDir = sbBuildDir </> fpFromText namever+ childDir = sbBuildDir </> unpack namever log' t = do i <- readTVarIO sbActive@@ -313,9 +313,9 @@ , tshow $ length errs , ")\n" ]- libOut = pbLogDir </> fpFromText namever </> "build.out"- testOut = pbLogDir </> fpFromText namever </> "test.out"- testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"+ libOut = pbLogDir </> unpack namever </> "build.out"+ testOut = pbLogDir </> unpack namever </> "test.out"+ testRunOut = pbLogDir </> unpack namever </> "test-run.out" wf fp inner' = do ref <- newIORef Nothing@@ -327,8 +327,8 @@ case mh of Just h -> return h Nothing -> mask_ $ do- createTree $ parent fp- h <- openBinaryFile (fpToString fp) WriteMode+ createTree $ parent $ fromString fp+ h <- openBinaryFile fp WriteMode writeIORef ref $ Just h return h @@ -338,13 +338,13 @@ when pbAllowNewer $ tell' "--allow-newer" tell' "--package-db=clear" tell' "--package-db=global"- forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db- tell' $ "--libdir=" ++ fpToText (pbLibDir pb)- tell' $ "--bindir=" ++ fpToText (pbBinDir pb)- tell' $ "--datadir=" ++ fpToText (pbDataDir pb)- tell' $ "--docdir=" ++ fpToText (pbDocDir pb </> fpFromText namever)- tell' $ "--htmldir=" ++ fpToText (pbDocDir pb </> fpFromText namever)- tell' $ "--haddockdir=" ++ fpToText (pbDocDir pb </> fpFromText namever)+ forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ pack db+ tell' $ "--libdir=" ++ pack (pbLibDir pb)+ tell' $ "--bindir=" ++ pack (pbBinDir pb)+ tell' $ "--datadir=" ++ pack (pbDataDir pb)+ tell' $ "--docdir=" ++ pack (pbDocDir pb </> unpack namever)+ tell' $ "--htmldir=" ++ pack (pbDocDir pb </> unpack namever)+ tell' $ "--haddockdir=" ++ pack (pbDocDir pb </> unpack namever) tell' $ "--flags=" ++ flags when (pbEnableLibProfiling && pcEnableLibProfile) $ tell' "--enable-library-profiling"@@ -369,20 +369,20 @@ runChild getOutH a b isUnpacked <- newIORef False- let withUnpacked inner = do+ let withUnpacked inner' = do unlessM (readIORef isUnpacked) $ do log' $ "Unpacking " ++ namever runParent getOutH "cabal" ["unpack", namever] writeIORef isUnpacked True- inner+ inner' isConfiged <- newIORef False- let withConfiged inner = withUnpacked $ do+ let withConfiged inner' = withUnpacked $ do unlessM (readIORef isConfiged) $ do log' $ "Configuring " ++ namever run "cabal" $ "configure" : configArgs writeIORef isConfiged True- inner+ inner' prevBuildResult <- getPreviousResult pb Build pident toBuild <- case () of@@ -439,7 +439,7 @@ , "../" , pkgVer , "/,"- , fpToText hf+ , pack hf ] args = ($ hfsOpts) $ execWriter $ do let tell' x = tell (x:)@@ -453,19 +453,20 @@ forM_ eres $ \() -> do renameOrCopy- (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)- (pbDocDir pb </> fpFromText namever)+ (childDir </> "dist" </> "doc" </> "html" </> unpack name)+ (pbDocDir pb </> unpack namever) enewPath <- tryIO $ canonicalizePath+ $ fromString $ pbDocDir pb- </> fpFromText namever- </> fpFromText name <.> "haddock"+ </> unpack namever+ </> unpack name <.> "haddock" case enewPath of Left e -> warn $ tshow e Right newPath -> atomically $ modifyTVar sbHaddockFiles- $ insertMap namever newPath+ $ insertMap namever (F.encodeString newPath) savePreviousResult pb Haddock pident $ either (const False) (const True) eres case (eres, pcHaddocks) of@@ -491,7 +492,7 @@ run "cabal" ["build"] log' $ "Test run " ++ namever- run "cabal" ["test", "--log=" ++ fpToText testRunOut]+ run "cabal" ["test", "--log=" ++ pack testRunOut] savePreviousResult pb Test pident $ either (const False) (const True) eres case (eres, pcTests) of@@ -515,7 +516,9 @@ Nothing -> BuildFailureException exc renameOrCopy :: FilePath -> FilePath -> IO ()-renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest+renameOrCopy src dest =+ rename (fromString src) (fromString dest)+ `catchIO` \_ -> copyDir src dest copyBuiltInHaddocks :: FilePath -> IO () copyBuiltInHaddocks docdir = do@@ -523,9 +526,9 @@ case mghc of Nothing -> error "GHC not found on PATH" Just ghc -> do- src <- canonicalizePath- (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")- copyDir src docdir+ src <- canonicalizePath $ fromString+ (F.encodeString (parent (fromString ghc)) </> "../share/doc/ghc/html/libraries")+ copyDir (F.encodeString src) docdir ------------- Previous results @@ -547,10 +550,10 @@ withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a withPRPath pb rt ident inner = do- createTree $ parent fp+ createTree $ parent $ fromString fp inner fp where- fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)+ fp = pbPrevResDir pb </> show rt </> unpack (display ident) successBS, failureBS :: ByteString successBS = "success"@@ -574,7 +577,7 @@ deletePreviousResults pb name = forM_ [minBound..maxBound] $ \rt -> withPRPath pb rt name $ \fp ->- void $ tryIO $ removeFile fp+ void $ tryIO $ removeFile $ fromString fp -- | Discover existing .haddock files in the docs directory getHaddockFiles :: PerformBuild -> IO (Map Text FilePath)@@ -587,14 +590,14 @@ go dir = case simpleParse nameVerText of Nothing -> return mempty- Just pi@(PackageIdentifier (PackageName name) _) -> do- let fp = dir </> fpFromString name <.> "haddock"- exists <- isFile fp+ Just (PackageIdentifier (PackageName name) _) -> do+ let fp = dir </> name <.> "haddock"+ exists <- doesFileExist fp return $ if exists then singletonMap nameVerText fp else mempty where- nameVerText = fpToText $ filename dir+ nameVerText = pack $ FP.takeFileName dir getHaddockDeps :: BuildPlan -> TVar (Map PackageName (Set PackageName))
Stackage/Prelude.hs view
@@ -9,20 +9,17 @@ ) where import ClassyPrelude.Conduit as X-import Data.Aeson (FromJSON, ToJSON) import Data.Conduit.Process as X import qualified Data.Map as Map-import Data.Typeable (TypeRep, typeOf) import Distribution.Package as X (PackageIdentifier (..), PackageName (PackageName)) import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription)-import qualified Distribution.Text as DT import Distribution.Version as X (Version (..), VersionRange) import Distribution.Version as X (withinRange) import qualified Distribution.Version as C import Filesystem (createTree) import Filesystem.Path (parent)-import qualified Filesystem.Path as F+import qualified Filesystem.Path.CurrentOS as F import Stackage.Types as X -- | There seems to be a bug in Cabal where serializing and deserializing@@ -64,10 +61,10 @@ copyDir src dest = runResourceT $ sourceDirectoryDeep False src $$ mapM_C go where- src' = src </> ""- go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do- let dest' = dest </> suffix- liftIO $ createTree $ parent dest'+ src' = fromString src F.</> ""+ go fp = forM_ (F.stripPrefix src' $ fromString fp) $ \suffix -> do+ let dest' = dest </> F.encodeString suffix+ liftIO $ createTree $ parent $ fromString dest' sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) data Target = TargetNightly !Day
Stackage/ServerBundle.hs view
@@ -20,20 +20,18 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import qualified Data.Map as M-import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)-import System.IO.Temp (withTempDirectory) import qualified Data.Yaml as Y-import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)+import Filesystem (getWorkingDirectory, listDirectory)+import qualified Filesystem.Path.CurrentOS as F import Foreign.C.Types (CTime (CTime)) import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.Prelude-import System.IO.Temp (withTempDirectory) import qualified System.PosixCompat.Time as PC import qualified Text.XML as X import Text.XML.Cursor-import System.PosixCompat.Files (createSymbolicLink)-import Stackage.Types+import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)+import System.FilePath (takeFileName) -- | Get current time epochTime :: IO Tar.EpochTime@@ -93,13 +91,13 @@ where go :: (PackageName, Version) -> IO DocMap go (package, version) = do -- handleAny (const $ return mempty) $ do- let dirname = fpFromText (concat+ let dirname = unpack (concat [ display package , "-" , display version ]) indexFP = (docsDir </> dirname </> "index.html")- ie <- isFile indexFP+ ie <- doesFileExist indexFP if ie then do doc <- flip X.readFile indexFP X.def@@ -114,10 +112,10 @@ pairs = cursor $// attributeIs "class" "module" &/ laxElement "a" >=> getPair m <- fmap fold $ forM pairs $ \(href, name) -> do- let suffix = dirname </> fpFromText href- e <- isFile $ docsDir </> suffix+ let suffix = dirname </> unpack href+ e <- doesFileExist $ docsDir </> suffix return $ if e- then asMap $ singletonMap name [fpToText dirname, href]+ then asMap $ singletonMap name [pack dirname, href] else mempty return $ singletonMap (display package) $ PackageDocs { pdVersion = display version@@ -140,20 +138,20 @@ docsDir <- canonicalizePath cb2DocsDir docMap <- docsListing cb2Plan cb2DocsDir - Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan- Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type- Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap- Y.encodeFile (fpToString cb2DocmapFile) docMap+ Y.encodeFile (docsDir </> "build-plan.yaml") cb2Plan+ Y.encodeFile (docsDir </> "build-type.yaml") cb2Type+ Y.encodeFile (docsDir </> "docs-map.yaml") docMap+ Y.encodeFile cb2DocmapFile docMap void $ writeIndexStyle Nothing cb2DocsDir currentDir <- getWorkingDirectory- files <- listDirectory docsDir+ files <- listDirectory $ fromString docsDir let args = "cfJ"- : fpToString (currentDir </> cb2Dest)+ : (F.encodeString currentDir </> cb2Dest) : "--dereference"- : map (fpToString . filename) files- cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }+ : map (takeFileName . F.encodeString) files+ cp = (proc "tar" args) { cwd = Just docsDir } withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () writeIndexStyle :: Maybe Text -- ^ snapshot id@@ -163,8 +161,8 @@ dirs <- fmap sort $ runResourceT $ sourceDirectory dir- $$ filterMC (liftIO . isDirectory)- =$ mapC (fpToString . filename)+ $$ filterMC (liftIO . doesDirectoryExist)+ =$ mapC takeFileName =$ sinkList writeFile (dir </> "index.html") $ mkIndex (unpack <$> msnapid)
Stackage/Stats.hs view
@@ -9,7 +9,7 @@ printStats :: FilePath -- ^ YAML build plan file -> IO () printStats fp = do- bp <- decodeFileEither (fpToString fp) >>= either throwIO return+ bp <- decodeFileEither fp >>= either throwIO return let core = length $ siCorePackages $ bpSystemInfo bp pkgs = length $ bpPackages bp maintainers = length $ asSet $ flip foldMap (bpPackages bp)
Stackage/Upload.hs view
@@ -14,19 +14,13 @@ , unStackageServer ) where -import Control.Monad.Writer.Strict (execWriter, tell) import Data.Default.Class (Default (..)) import Data.Function (fix)-import Filesystem (isDirectory, isFile) import Network.HTTP.Client import qualified Network.HTTP.Client.Conduit as HCC-import Network.HTTP.Client.MultipartFormData-import Stackage.BuildPlan (BuildPlan) import Stackage.Prelude-import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle)-import System.IO.Temp (withSystemTempFile)+import Stackage.ServerBundle (bpAllPackages) import qualified System.IO as IO-import qualified Data.Yaml as Y newtype StackageServer = StackageServer { unStackageServer :: Text } deriving (Show, Eq, Ord, Hashable, IsString)@@ -61,13 +55,13 @@ $ map go $ mapToList $ bpAllPackages bp- go (name, version) =+ go (name', version) = "\"" ++- (toBuilder $ display name) +++ (toBuilder $ display name') ++ "\",\"" ++ (toBuilder $ display version) ++ "\",\"https://www.stackage.org/package/" ++- (toBuilder $ display name) +++ (toBuilder $ display name') ++ "\"" data UploadBundleV2 = UploadBundleV2@@ -77,7 +71,7 @@ } uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text-uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile ub2Bundle IO.ReadMode $ \h -> do size <- IO.hFileSize h putStrLn $ "Bundle size: " ++ tshow size req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
app/stackage.hs view
@@ -1,31 +1,23 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, TupleSections #-} module Main where +import Control.Monad+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Options.Applicative+import Paths_stackage_curator (version) import qualified Prelude-import Control.Monad-import Data.String (fromString)-import Data.Version-import Data.Text (pack, stripPrefix)-import Data.Text.Read (decimal)-import Options.Applicative-import Filesystem.Path.CurrentOS (decodeString)-import Paths_stackage_curator (version)-import Stackage.CLI-import Stackage.CompleteBuild-import Stackage.DiffPlans-import Stackage.Upload-import Stackage.Update-import Stackage.InstallBuild-import Stackage.Prelude hiding ((<>))-import Stackage.Stats-import Network.HTTP.Client (withManager)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified Data.Text as T-import System.IO (hSetBuffering, stdout, BufferMode (LineBuffering))-import Stackage.Curator.UploadIndex+import Stackage.CLI+import Stackage.CompleteBuild+import Stackage.Curator.UploadIndex+import Stackage.DiffPlans+import Stackage.InstallBuild+import Stackage.Prelude hiding ((<>))+import Stackage.Stats+import Stackage.Update+import Stackage.Upload+import System.IO (BufferMode (LineBuffering), hSetBuffering) main :: IO () main = do@@ -65,7 +57,8 @@ addCommand "stats" "Print statistics on a build plan" id (printStats <$> planFile) addCommand "diff" "Show the high-level differences between two build plans" id- (diffPlans <$> planFileArg <*> planFileArg)+ (diffPlans <$> planFileArg <*> planFileArg+ <*> diffsOnly <*> useColor <*> githubFetch <*> html) addCommand "upload-index" "Upload the 00-index.tar.gz file to S3" id (uploadIndex <$> planFile@@ -100,18 +93,16 @@ metavar "URL" <> help "Stackage bundle containing build plan")) <|> fmap- (BPSFile . decodeString)+ BPSFile (strOption (long "build-plan" <> metavar "PATH" <> help "Build-plan YAML file"))) <*>- fmap- decodeString- (strArgument+ (strArgument (metavar "DESTINATION-PATH" <> help "Destination directory path")) <*> (fmap- (Just . decodeString)+ Just (strOption (long "log-dir" <> metavar "PATH" <>@@ -221,24 +212,24 @@ return $ TargetLts i j _ -> onErr - planFile = fmap decodeString $ strOption+ planFile = strOption ( metavar "YAML-FILE" ++ long "plan-file" ++ help "YAML file containing a build plan" ) - docmapFile = fmap decodeString $ strOption+ docmapFile = strOption ( metavar "YAML-FILE" ++ long "docmap-file" ++ help "YAML file containing the docmap (list of all generated Haddock modules)" ) - planFileArg = fmap decodeString $ strArgument+ planFileArg = strArgument ( metavar "YAML-FILE" ++ help "YAML file containing a build plan" ) - bundleFile = fmap decodeString $ strOption+ bundleFile = strOption ( metavar "BUNDLE-FILE" ++ long "bundle-file" ++ help "Path to bundle file"@@ -262,3 +253,23 @@ case simpleParse $ T.pack s of Nothing -> fail $ "Invalid constraint: " ++ s Just d -> return d++ diffsOnly =+ switch+ (long "diffsOnly" <> short 'd' <>+ help "Show changed packages only")++ useColor =+ switch+ (long "useColor" <> short 'c' <>+ help "Show differences in color")++ githubFetch =+ switch+ (long "githubFetch" <> short 'g' <>+ help "Fetch YAML files from GitHub")++ html =+ switch+ (long "html" <> short 'h' <>+ help "Wrap the output in HTML <ul>/<li> tags")
stackage-curator.cabal view
@@ -1,5 +1,5 @@ name: stackage-curator-version: 0.10.0+version: 0.11.0 synopsis: Tools for curating Stackage bundles description: Please see <http://www.stackage.org/package/stackage-curator> for a description and documentation. homepage: https://github.com/fpco/stackage@@ -51,7 +51,7 @@ , utf8-string , conduit-extra- , classy-prelude-conduit < 0.12+ , classy-prelude-conduit >= 0.12 , text , system-fileio , system-filepath@@ -69,7 +69,7 @@ , async , streaming-commons >= 0.1.7.1 , semigroups- , xml-conduit < 1.3+ , xml-conduit , conduit , stackage-types >= 1.1 , monad-unlift >= 0.1.1@@ -77,7 +77,7 @@ , blaze-html , html-conduit , mime-types- , amazonka+ , amazonka >= 1.1 , amazonka-s3 , amazonka-core , xml-types@@ -88,6 +88,7 @@ , resourcet , stackage-metadata >= 0.3 , stackage-install >= 0.1.1+ , lucid executable stackage-curator default-language: Haskell2010