diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -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 diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -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 diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -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 diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs --- a/Stackage/CorePackages.hs +++ b/Stackage/CorePackages.hs @@ -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 diff --git a/Stackage/Curator/UploadDocs.hs b/Stackage/Curator/UploadDocs.hs --- a/Stackage/Curator/UploadDocs.hs +++ b/Stackage/Curator/UploadDocs.hs @@ -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) diff --git a/Stackage/Curator/UploadIndex.hs b/Stackage/Curator/UploadIndex.hs --- a/Stackage/Curator/UploadIndex.hs +++ b/Stackage/Curator/UploadIndex.hs @@ -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 diff --git a/Stackage/DiffPlans.hs b/Stackage/DiffPlans.hs --- a/Stackage/DiffPlans.hs +++ b/Stackage/DiffPlans.hs @@ -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_ [] diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -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: " diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs --- a/Stackage/InstallBuild.hs +++ b/Stackage/InstallBuild.hs @@ -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" diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs --- a/Stackage/PackageDescription.hs +++ b/Stackage/PackageDescription.hs @@ -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 diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -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 diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -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)) diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs --- a/Stackage/Prelude.hs +++ b/Stackage/Prelude.hs @@ -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 diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs --- a/Stackage/ServerBundle.hs +++ b/Stackage/ServerBundle.hs @@ -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) diff --git a/Stackage/Stats.hs b/Stackage/Stats.hs --- a/Stackage/Stats.hs +++ b/Stackage/Stats.hs @@ -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) diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -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" diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -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