mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
Merge branch 'master' into ghc7.10
Conflicts: build-constraints.yaml
This commit is contained in:
Michael Snoyman
commit
4e5ba05a27
@ -1,3 +1,11 @@
|
||||
## 0.6.1
|
||||
|
||||
* Switch to V2 upload by default
|
||||
|
||||
## 0.6.0
|
||||
|
||||
* Upload bundle V2 stuff
|
||||
|
||||
## 0.5.2
|
||||
|
||||
* Upload LTS to Hackage with the name LTSHaskell
|
||||
|
||||
@ -14,9 +14,9 @@ ADD debian-bootstrap.sh /tmp/debian-bootstrap.sh
|
||||
RUN DEBIAN_FRONTEND=noninteractive bash /tmp/debian-bootstrap.sh
|
||||
RUN rm /tmp/debian-bootstrap.sh
|
||||
|
||||
RUN DEBIAN_FRONTEND=noninteractive apt-get install -y cabal-install-1.20 ghc-7.8.4
|
||||
RUN DEBIAN_FRONTEND=noninteractive apt-get install -y cabal-install-1.20 ghc-7.8.4 alex-3.1.3 happy-1.19.4
|
||||
|
||||
ENV PATH /home/stackage/.cabal/bin:/usr/local/sbin:/usr/local/bin:/opt/ghc/7.8.4/bin:/opt/cabal/1.20/bin:/usr/sbin:/usr/bin:/sbin:/bin
|
||||
ENV PATH /home/stackage/.cabal/bin:/usr/local/sbin:/usr/local/bin:/opt/ghc/7.8.4/bin:/opt/cabal/1.20/bin:/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:/usr/sbin:/usr/bin:/sbin:/bin
|
||||
|
||||
RUN cabal update
|
||||
ADD . /tmp/stackage
|
||||
|
||||
@ -120,7 +120,7 @@ instance FromJSON PackageConstraints where
|
||||
pcBuildBenchmarks <- o .: "build-benchmarks"
|
||||
pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags"
|
||||
pcMaintainer <- o .:? "maintainer"
|
||||
pcEnableLibProfile <- fmap (fromMaybe False) (o .:? "library-profiling")
|
||||
pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling")
|
||||
return PackageConstraints {..}
|
||||
|
||||
-- | The proposed plan from the requirements provided by contributors.
|
||||
|
||||
@ -8,6 +8,7 @@ module Stackage.CompleteBuild
|
||||
, completeBuild
|
||||
, justCheck
|
||||
, justUploadNightly
|
||||
, getStackageAuthToken
|
||||
) where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
@ -33,10 +34,14 @@ import System.IO (BufferMode (LineBuffering), hSetBuffering)
|
||||
-- | Flags passed in from the command line.
|
||||
data BuildFlags = BuildFlags
|
||||
{ bfEnableTests :: !Bool
|
||||
, bfEnableHaddock :: !Bool
|
||||
, bfDoUpload :: !Bool
|
||||
, bfEnableLibProfile :: !Bool
|
||||
, bfEnableExecDyn :: !Bool
|
||||
, bfVerbose :: !Bool
|
||||
, bfSkipCheck :: !Bool
|
||||
, bfUploadV1 :: !Bool
|
||||
, bfServer :: !StackageServer
|
||||
} deriving (Show)
|
||||
|
||||
data BuildType = Nightly | LTS BumpType
|
||||
@ -55,6 +60,8 @@ data Settings = Settings
|
||||
, setArgs :: Text -> UploadBundle -> UploadBundle
|
||||
, postBuild :: IO ()
|
||||
, distroName :: Text -- ^ distro name on Hackage
|
||||
, snapshotType :: SnapshotType
|
||||
, bundleDest :: FilePath
|
||||
}
|
||||
|
||||
nightlyPlanFile :: Text -- ^ day
|
||||
@ -66,7 +73,7 @@ nightlySettings :: Text -- ^ day
|
||||
-> Settings
|
||||
nightlySettings day plan' = Settings
|
||||
{ planFile = nightlyPlanFile day
|
||||
, buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
|
||||
, buildDir = fpFromText $ "builds/nightly"
|
||||
, logDir = fpFromText $ "logs/stackage-nightly-" ++ day
|
||||
, title = \ghcVer -> concat
|
||||
[ "Stackage Nightly "
|
||||
@ -79,6 +86,8 @@ nightlySettings day plan' = Settings
|
||||
, plan = plan'
|
||||
, postBuild = return ()
|
||||
, distroName = "Stackage"
|
||||
, snapshotType = STNightly
|
||||
, bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle"
|
||||
}
|
||||
where
|
||||
slug' = "nightly-" ++ day
|
||||
@ -119,7 +128,7 @@ getSettings man (LTS bumpType) = do
|
||||
|
||||
return Settings
|
||||
{ planFile = newfile
|
||||
, buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new
|
||||
, buildDir = fpFromText $ "builds/lts"
|
||||
, logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
|
||||
, title = \ghcVer -> concat
|
||||
[ "LTS Haskell "
|
||||
@ -140,6 +149,10 @@ getSettings man (LTS bumpType) = do
|
||||
putStrLn "Pushing to Git repository"
|
||||
git ["push"]
|
||||
, distroName = "LTSHaskell"
|
||||
, snapshotType =
|
||||
case new of
|
||||
LTSVer x y -> STLTS x y
|
||||
, bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle"
|
||||
}
|
||||
|
||||
data LTSVer = LTSVer !Int !Int
|
||||
@ -203,7 +216,9 @@ getPerformBuild buildFlags Settings {..} = PerformBuild
|
||||
, pbJobs = 8
|
||||
, pbGlobalInstall = False
|
||||
, pbEnableTests = bfEnableTests buildFlags
|
||||
, pbEnableHaddock = bfEnableHaddock buildFlags
|
||||
, pbEnableLibProfiling = bfEnableLibProfile buildFlags
|
||||
, pbEnableExecDyn = bfEnableExecDyn buildFlags
|
||||
, pbVerbose = bfVerbose buildFlags
|
||||
, pbAllowNewer = bfSkipCheck buildFlags
|
||||
}
|
||||
@ -227,10 +242,23 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do
|
||||
checkBuildPlan plan
|
||||
|
||||
putStrLn "Performing build"
|
||||
performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn
|
||||
let pb = getPerformBuild buildFlags settings
|
||||
performBuild pb >>= mapM_ putStrLn
|
||||
|
||||
putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest
|
||||
createBundleV2 CreateBundleV2
|
||||
{ cb2Plan = plan
|
||||
, cb2Type = snapshotType
|
||||
, cb2DocsDir = pbDocDir pb
|
||||
, cb2Dest = bundleDest
|
||||
}
|
||||
|
||||
when (bfDoUpload buildFlags) $
|
||||
finallyUpload settings man
|
||||
finallyUpload
|
||||
(not $ bfUploadV1 buildFlags)
|
||||
(bfServer buildFlags)
|
||||
settings
|
||||
man
|
||||
|
||||
justUploadNightly
|
||||
:: Text -- ^ nightly date
|
||||
@ -238,41 +266,64 @@ justUploadNightly
|
||||
justUploadNightly day = do
|
||||
plan <- decodeFileEither (fpToString $ nightlyPlanFile day)
|
||||
>>= either throwM return
|
||||
withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan
|
||||
withManager tlsManagerSettings $ finallyUpload False def $ nightlySettings day plan
|
||||
|
||||
getStackageAuthToken :: IO Text
|
||||
getStackageAuthToken = do
|
||||
mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
|
||||
case mtoken of
|
||||
Nothing -> decodeUtf8 <$> readFile "/auth-token"
|
||||
Just token -> return $ pack token
|
||||
|
||||
-- | The final part of the complete build process: uploading a bundle,
|
||||
-- docs and a distro to hackage.
|
||||
finallyUpload :: Settings -> Manager -> IO ()
|
||||
finallyUpload settings@Settings{..} man = do
|
||||
finallyUpload :: Bool -- ^ use v2 upload
|
||||
-> StackageServer
|
||||
-> Settings -> Manager -> IO ()
|
||||
finallyUpload useV2 server settings@Settings{..} man = do
|
||||
putStrLn "Uploading bundle to Stackage Server"
|
||||
|
||||
mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
|
||||
token <-
|
||||
case mtoken of
|
||||
Nothing -> decodeUtf8 <$> readFile "/auth-token"
|
||||
Just token -> return $ pack token
|
||||
token <- getStackageAuthToken
|
||||
|
||||
now <- epochTime
|
||||
let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
|
||||
(ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
|
||||
{ ubContents = serverBundle now (title ghcVer) slug plan
|
||||
, ubAuthToken = token
|
||||
}
|
||||
putStrLn $ "New ident: " ++ unSnapshotIdent ident
|
||||
forM_ mloc $ \loc ->
|
||||
putStrLn $ "Track progress at: " ++ loc
|
||||
if useV2
|
||||
then do
|
||||
res <- flip uploadBundleV2 man UploadBundleV2
|
||||
{ ub2Server = server
|
||||
, ub2AuthToken = token
|
||||
, ub2Bundle = bundleDest
|
||||
}
|
||||
putStrLn $ "New snapshot available at: " ++ res
|
||||
else do
|
||||
now <- epochTime
|
||||
let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
|
||||
(ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
|
||||
{ ubContents = serverBundle now (title ghcVer) slug plan
|
||||
, ubAuthToken = token
|
||||
}
|
||||
putStrLn $ "New ident: " ++ unSnapshotIdent ident
|
||||
forM_ mloc $ \loc ->
|
||||
putStrLn $ "Track progress at: " ++ loc
|
||||
|
||||
putStrLn "Uploading docs to Stackage Server"
|
||||
res1 <- tryAny $ uploadDocs UploadDocs
|
||||
{ udServer = def
|
||||
, udAuthToken = token
|
||||
, udDocs = pbDocDir pb
|
||||
, udSnapshot = ident
|
||||
} man
|
||||
putStrLn $ "Doc upload response: " ++ tshow res1
|
||||
|
||||
putStrLn "Uploading doc map"
|
||||
tryAny (uploadDocMap UploadDocMap
|
||||
{ udmServer = def
|
||||
, udmAuthToken = token
|
||||
, udmSnapshot = ident
|
||||
, udmDocDir = pbDocDir pb
|
||||
, udmPlan = plan
|
||||
} man) >>= print
|
||||
|
||||
postBuild `catchAny` print
|
||||
|
||||
putStrLn "Uploading docs to Stackage Server"
|
||||
res1 <- uploadDocs UploadDocs
|
||||
{ udServer = def
|
||||
, udAuthToken = token
|
||||
, udDocs = pbDocDir pb
|
||||
, udSnapshot = ident
|
||||
} man
|
||||
putStrLn $ "Doc upload response: " ++ tshow res1
|
||||
|
||||
ecreds <- tryIO $ readFile "/hackage-creds"
|
||||
case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
|
||||
[username, password] -> do
|
||||
@ -280,14 +331,5 @@ finallyUpload settings@Settings{..} man = do
|
||||
res2 <- uploadHackageDistroNamed distroName plan username password man
|
||||
putStrLn $ "Distro upload response: " ++ tshow res2
|
||||
_ -> putStrLn "No creds found, skipping Hackage distro upload"
|
||||
|
||||
putStrLn "Uploading doc map"
|
||||
uploadDocMap UploadDocMap
|
||||
{ udmServer = def
|
||||
, udmAuthToken = token
|
||||
, udmSnapshot = ident
|
||||
, udmDocDir = pbDocDir pb
|
||||
, udmPlan = plan
|
||||
} man >>= print
|
||||
where
|
||||
pb = getPerformBuild (error "finallyUpload.buildFlags") settings
|
||||
|
||||
104
Stackage/GhcPkg.hs
Normal file
104
Stackage/GhcPkg.hs
Normal file
@ -0,0 +1,104 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | General commands related to ghc-pkg.
|
||||
|
||||
module Stackage.GhcPkg
|
||||
( setupPackageDatabase
|
||||
) where
|
||||
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.List as CL
|
||||
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)
|
||||
|
||||
setupPackageDatabase
|
||||
:: Maybe FilePath -- ^ database location, Nothing if using global DB
|
||||
-> FilePath -- ^ documentation root
|
||||
-> (ByteString -> IO ()) -- ^ logging
|
||||
-> Map PackageName Version -- ^ packages and versions to be installed
|
||||
-> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package
|
||||
-> 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) ->
|
||||
case lookup name toInstall of
|
||||
Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi
|
||||
_ -> return ()
|
||||
broken <- getBrokenPackages flags
|
||||
forM_ broken $ unregisterPackage log' onUnregister docDir flags
|
||||
foldMap (\(PackageIdentifier name _) -> singletonSet name)
|
||||
<$> getRegisteredPackages flags
|
||||
where
|
||||
flags = ghcPkgFlags mdb
|
||||
|
||||
ghcPkgFlags :: Maybe FilePath -> [String]
|
||||
ghcPkgFlags mdb =
|
||||
"--no-user-package-db" :
|
||||
case mdb of
|
||||
Nothing -> ["--global"]
|
||||
Just fp -> ["--package-db=" ++ fpToString fp]
|
||||
|
||||
-- | Get broken packages.
|
||||
getBrokenPackages :: [String] -> IO [PackageIdentifier]
|
||||
getBrokenPackages flags = do
|
||||
(_,ps) <- sourceProcessWithConsumer
|
||||
(proc
|
||||
"ghc-pkg"
|
||||
("check" : "--simple-output" : flags))
|
||||
(CT.decodeUtf8 $= CT.lines $= CL.consume)
|
||||
return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
|
||||
|
||||
-- | Get available packages.
|
||||
getRegisteredPackages :: [String] -> IO [PackageIdentifier]
|
||||
getRegisteredPackages flags = do
|
||||
(_,ps) <- sourceProcessWithConsumer
|
||||
(proc
|
||||
"ghc-pkg"
|
||||
("list" : "--simple-output" : flags))
|
||||
(CT.decodeUtf8 $= CT.lines $= CL.consume)
|
||||
return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
|
||||
|
||||
-- | Parse a package identifier: foo-1.2.3
|
||||
parsePackageIdent :: Text -> Maybe PackageIdentifier
|
||||
parsePackageIdent = fmap fst .
|
||||
listToMaybe .
|
||||
filter (null . snd) .
|
||||
readP_to_S parse . T.unpack
|
||||
|
||||
-- | Unregister a package.
|
||||
unregisterPackage :: (ByteString -> IO ()) -- ^ log func
|
||||
-> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package
|
||||
-> FilePath -- ^ doc directory
|
||||
-> [String] -> PackageIdentifier -> IO ()
|
||||
unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do
|
||||
log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"
|
||||
onUnregister ident
|
||||
|
||||
-- Delete libraries
|
||||
sourceProcessWithConsumer
|
||||
(proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident]))
|
||||
(CT.decodeUtf8
|
||||
$= CT.lines
|
||||
$= CL.mapMaybe parseLibraryDir
|
||||
$= CL.mapM_ (void . tryIO . removeTree))
|
||||
|
||||
void (readProcessWithExitCode
|
||||
"ghc-pkg"
|
||||
("unregister": flags ++ ["--force", unpack $ display name])
|
||||
"")
|
||||
|
||||
void $ tryIO $ removeTree $ docDir </> fpFromText (display ident)
|
||||
where
|
||||
parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: "
|
||||
@ -28,7 +28,9 @@ data InstallFlags = InstallFlags
|
||||
, ifJobs :: !Int
|
||||
, ifGlobalInstall :: !Bool
|
||||
, ifEnableTests :: !Bool
|
||||
, ifEnableHaddock :: !Bool
|
||||
, ifEnableLibProfiling :: !Bool
|
||||
, ifEnableExecDyn :: !Bool
|
||||
, ifVerbose :: !Bool
|
||||
, ifSkipCheck :: !Bool
|
||||
} deriving (Show)
|
||||
@ -48,7 +50,9 @@ getPerformBuild plan InstallFlags{..} =
|
||||
, pbJobs = ifJobs
|
||||
, pbGlobalInstall = ifGlobalInstall
|
||||
, pbEnableTests = ifEnableTests
|
||||
, pbEnableHaddock = ifEnableHaddock
|
||||
, pbEnableLibProfiling = ifEnableLibProfiling
|
||||
, pbEnableExecDyn = ifEnableExecDyn
|
||||
, pbVerbose = ifVerbose
|
||||
, pbAllowNewer = ifSkipCheck
|
||||
}
|
||||
|
||||
@ -19,17 +19,18 @@ import qualified Data.Map as Map
|
||||
import Data.NonNull (fromNullable)
|
||||
import Filesystem (canonicalizePath, createTree,
|
||||
getWorkingDirectory, isDirectory,
|
||||
removeTree, rename)
|
||||
removeTree, rename, isFile, removeFile)
|
||||
import Filesystem.Path (parent)
|
||||
import qualified Filesystem.Path 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.Environment (getEnvironment)
|
||||
import System.IO (IOMode (WriteMode),
|
||||
withBinaryFile)
|
||||
openBinaryFile)
|
||||
import System.IO.Temp (withSystemTempDirectory)
|
||||
|
||||
data BuildException = BuildException (Map PackageName BuildFailure) [Text]
|
||||
@ -62,7 +63,9 @@ data PerformBuild = PerformBuild
|
||||
, pbGlobalInstall :: Bool
|
||||
-- ^ Register packages in the global database
|
||||
, pbEnableTests :: Bool
|
||||
, pbEnableHaddock :: Bool
|
||||
, pbEnableLibProfiling :: Bool
|
||||
, pbEnableExecDyn :: Bool
|
||||
, pbVerbose :: Bool
|
||||
, pbAllowNewer :: Bool
|
||||
-- ^ Pass --allow-newer to cabal configure
|
||||
@ -89,7 +92,7 @@ waitForDeps toolMap packageMap activeComps bp pi action = do
|
||||
Nothing
|
||||
| isCoreExe exe -> return ()
|
||||
-- https://github.com/jgm/zip-archive/issues/23
|
||||
-- | otherwise -> throwSTM $ ToolMissing exe
|
||||
-- - | otherwise -> throwSTM $ ToolMissing exe
|
||||
| otherwise -> return ()
|
||||
Just packages -> ofoldl1' (<|>) packages
|
||||
action
|
||||
@ -133,6 +136,10 @@ pbLibDir pb = pbInstallDest pb </> "lib"
|
||||
pbDataDir pb = pbInstallDest pb </> "share"
|
||||
pbDocDir pb = pbInstallDest pb </> "doc"
|
||||
|
||||
-- | Directory keeping previous result info
|
||||
pbPrevResDir :: PerformBuild -> FilePath
|
||||
pbPrevResDir pb = pbInstallDest pb </> "prevres"
|
||||
|
||||
performBuild :: PerformBuild -> IO [Text]
|
||||
performBuild pb = do
|
||||
cwd <- getWorkingDirectory
|
||||
@ -160,12 +167,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
|
||||
$ \ClosedStream Inherited Inherited -> return ()
|
||||
|
||||
let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
|
||||
mapM_ removeTree' [pbInstallDest, pbLogDir]
|
||||
removeTree' pbLogDir
|
||||
|
||||
forM_ (pbDatabase pb) $ \db -> do
|
||||
createTree $ parent db
|
||||
withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
|
||||
$ \ClosedStream Inherited Inherited -> return ()
|
||||
forM_ (pbDatabase pb) $ \db ->
|
||||
unlessM (isFile $ db </> "package.cache") $ do
|
||||
createTree $ parent db
|
||||
withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
|
||||
$ \ClosedStream Inherited Inherited -> return ()
|
||||
pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
|
||||
copyBuiltInHaddocks (pbDocDir pb)
|
||||
pbLog $ encodeUtf8 "Finished copying built-in Haddocks\n"
|
||||
@ -186,7 +194,15 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
|
||||
env <- getEnvironment
|
||||
haddockFiles <- newTVarIO mempty
|
||||
|
||||
forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
|
||||
registeredPackages <- setupPackageDatabase
|
||||
(pbDatabase pb)
|
||||
(pbDocDir pb)
|
||||
pbLog
|
||||
(ppVersion <$> bpPackages pbPlan)
|
||||
(deletePreviousResults pb)
|
||||
|
||||
forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
|
||||
SingleBuild
|
||||
{ sbSem = sem
|
||||
, sbErrsVar = errsVar
|
||||
, sbWarningsVar = warningsVar
|
||||
@ -248,8 +264,10 @@ data SingleBuild = SingleBuild
|
||||
, sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
|
||||
}
|
||||
|
||||
singleBuild :: PerformBuild -> SingleBuild -> IO ()
|
||||
singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
singleBuild :: PerformBuild
|
||||
-> Set PackageName -- ^ registered packages
|
||||
-> SingleBuild -> IO ()
|
||||
singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
|
||||
withCounter sbActive
|
||||
$ handle updateErrs
|
||||
$ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
|
||||
@ -261,22 +279,25 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
let wfd comps =
|
||||
waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
|
||||
. withTSem sbSem
|
||||
wfd libComps buildLibrary
|
||||
withUnpacked <- wfd libComps buildLibrary
|
||||
|
||||
wfd testComps runTests
|
||||
wfd testComps (runTests withUnpacked)
|
||||
|
||||
name = display $ piName sbPackageInfo
|
||||
pname = piName sbPackageInfo
|
||||
pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
|
||||
name = display pname
|
||||
namever = concat
|
||||
[ name
|
||||
, "-"
|
||||
, display $ ppVersion $ piPlan sbPackageInfo
|
||||
]
|
||||
|
||||
runIn wdir outH cmd args =
|
||||
withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
|
||||
runIn wdir getOutH cmd args = do
|
||||
outH <- getOutH
|
||||
withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
|
||||
(return () :: IO ())
|
||||
where
|
||||
cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
|
||||
cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))
|
||||
{ cwd = Just $ fpToString wdir
|
||||
, std_out = UseHandle outH
|
||||
, std_err = UseHandle outH
|
||||
@ -302,8 +323,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
|
||||
|
||||
wf fp inner' = do
|
||||
createTree $ parent fp
|
||||
withBinaryFile (fpToString fp) WriteMode inner'
|
||||
ref <- newIORef Nothing
|
||||
let cleanup = do
|
||||
mh <- readIORef ref
|
||||
forM_ mh hClose
|
||||
getH = do
|
||||
mh <- readIORef ref
|
||||
case mh of
|
||||
Just h -> return h
|
||||
Nothing -> mask_ $ do
|
||||
createTree $ parent fp
|
||||
h <- openBinaryFile (fpToString fp) WriteMode
|
||||
writeIORef ref $ Just h
|
||||
return h
|
||||
|
||||
inner' getH `finally` cleanup
|
||||
|
||||
configArgs = ($ []) $ execWriter $ do
|
||||
when pbAllowNewer $ tell' "--allow-newer"
|
||||
@ -317,6 +351,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
tell' $ "--flags=" ++ flags
|
||||
when (pbEnableLibProfiling && pcEnableLibProfile) $
|
||||
tell' "--enable-library-profiling"
|
||||
when pbEnableExecDyn $ tell' "--enable-executable-dynamic"
|
||||
where
|
||||
tell' x = tell (x:)
|
||||
|
||||
@ -330,22 +365,40 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
|
||||
PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
|
||||
|
||||
buildLibrary = wf libOut $ \outH -> do
|
||||
buildLibrary = wf libOut $ \getOutH -> do
|
||||
let run a b = do when pbVerbose $ log' (unwords (a : b))
|
||||
runChild outH a b
|
||||
log' $ "Unpacking " ++ namever
|
||||
runParent outH "cabal" ["unpack", namever]
|
||||
runChild getOutH a b
|
||||
|
||||
log' $ "Configuring " ++ namever
|
||||
run "cabal" $ "configure" : configArgs
|
||||
isUnpacked <- newIORef False
|
||||
let withUnpacked inner = do
|
||||
unlessM (readIORef isUnpacked) $ do
|
||||
log' $ "Unpacking " ++ namever
|
||||
runParent getOutH "cabal" ["unpack", namever]
|
||||
writeIORef isUnpacked True
|
||||
inner
|
||||
|
||||
log' $ "Building " ++ namever
|
||||
run "cabal" ["build"]
|
||||
isConfiged <- newIORef False
|
||||
let withConfiged inner = withUnpacked $ do
|
||||
unlessM (readIORef isConfiged) $ do
|
||||
log' $ "Configuring " ++ namever
|
||||
run "cabal" $ "configure" : configArgs
|
||||
writeIORef isConfiged True
|
||||
inner
|
||||
|
||||
log' $ "Copying/registering " ++ namever
|
||||
run "cabal" ["copy"]
|
||||
withMVar sbRegisterMutex $ const $
|
||||
run "cabal" ["register"]
|
||||
prevBuildResult <- getPreviousResult pb Build pident
|
||||
unless (prevBuildResult == PRSuccess) $ withConfiged $ do
|
||||
assert (pname `notMember` registeredPackages) $ do
|
||||
deletePreviousResults pb pident
|
||||
|
||||
log' $ "Building " ++ namever
|
||||
run "cabal" ["build"]
|
||||
|
||||
log' $ "Copying/registering " ++ namever
|
||||
run "cabal" ["copy"]
|
||||
withMVar sbRegisterMutex $ const $
|
||||
run "cabal" ["register"]
|
||||
|
||||
savePreviousResult pb Build pident True
|
||||
|
||||
-- Even if the tests later fail, we can allow other libraries to build
|
||||
-- on top of our successful results
|
||||
@ -355,7 +408,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
-- dependency's haddocks before this finishes
|
||||
atomically $ putTMVar (piResult sbPackageInfo) True
|
||||
|
||||
when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
|
||||
prevHaddockResult <- getPreviousResult pb Haddock pident
|
||||
let needHaddock = pbEnableHaddock
|
||||
&& checkPrevResult prevHaddockResult pcHaddocks
|
||||
&& not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
|
||||
when needHaddock $ withConfiged $ do
|
||||
log' $ "Haddocks " ++ namever
|
||||
hfs <- readTVarIO sbHaddockFiles
|
||||
let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
|
||||
@ -389,15 +446,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
$ modifyTVar sbHaddockFiles
|
||||
$ insertMap namever newPath
|
||||
|
||||
savePreviousResult pb Haddock pident $ either (const False) (const True) eres
|
||||
case (eres, pcHaddocks) of
|
||||
(Left e, ExpectSuccess) -> throwM e
|
||||
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
|
||||
_ -> return ()
|
||||
|
||||
runTests = wf testOut $ \outH -> do
|
||||
let run = runChild outH
|
||||
return withUnpacked
|
||||
|
||||
when (pbEnableTests && pcTests /= Don'tBuild) $ do
|
||||
runTests withUnpacked = wf testOut $ \getOutH -> do
|
||||
let run = runChild getOutH
|
||||
|
||||
prevTestResult <- getPreviousResult pb Test pident
|
||||
let needTest = pbEnableTests
|
||||
&& checkPrevResult prevTestResult pcTests
|
||||
when needTest $ withUnpacked $ do
|
||||
log' $ "Test configure " ++ namever
|
||||
run "cabal" $ "configure" : "--enable-tests" : configArgs
|
||||
|
||||
@ -408,6 +471,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
log' $ "Test run " ++ namever
|
||||
run "cabal" ["test", "--log=" ++ fpToText testRunOut]
|
||||
|
||||
savePreviousResult pb Test pident $ either (const False) (const True) eres
|
||||
case (eres, pcTests) of
|
||||
(Left e, ExpectSuccess) -> throwM e
|
||||
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
|
||||
@ -434,16 +498,6 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
|
||||
renameOrCopy :: FilePath -> FilePath -> IO ()
|
||||
renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
|
||||
|
||||
copyDir :: FilePath -> FilePath -> IO ()
|
||||
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'
|
||||
sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
|
||||
|
||||
copyBuiltInHaddocks :: FilePath -> IO ()
|
||||
copyBuiltInHaddocks docdir = do
|
||||
mghc <- findExecutable "ghc"
|
||||
@ -453,3 +507,52 @@ copyBuiltInHaddocks docdir = do
|
||||
src <- canonicalizePath
|
||||
(parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
|
||||
copyDir src docdir
|
||||
|
||||
------------- Previous results
|
||||
|
||||
-- | The previous actions that can be run
|
||||
data ResultType = Build | Haddock | Test
|
||||
deriving (Show, Enum, Eq, Ord, Bounded, Read)
|
||||
|
||||
-- | The result generated on a previous run
|
||||
data PrevResult = PRNoResult | PRSuccess | PRFailure
|
||||
deriving (Show, Enum, Eq, Ord, Bounded, Read)
|
||||
|
||||
-- | Check if we should rerun based on a PrevResult and the expected status
|
||||
checkPrevResult :: PrevResult -> TestState -> Bool
|
||||
checkPrevResult _ Don'tBuild = False
|
||||
checkPrevResult PRNoResult _ = True
|
||||
checkPrevResult PRSuccess _ = False
|
||||
checkPrevResult PRFailure ExpectSuccess = True
|
||||
checkPrevResult PRFailure _ = False
|
||||
|
||||
withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
|
||||
withPRPath pb rt ident inner = do
|
||||
createTree $ parent fp
|
||||
inner fp
|
||||
where
|
||||
fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
|
||||
|
||||
successBS, failureBS :: ByteString
|
||||
successBS = "success"
|
||||
failureBS = "failure"
|
||||
|
||||
getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
|
||||
getPreviousResult w x y = withPRPath w x y $ \fp -> do
|
||||
eres <- tryIO $ readFile fp
|
||||
return $ case eres of
|
||||
Right bs
|
||||
| bs == successBS -> PRSuccess
|
||||
| bs == failureBS -> PRFailure
|
||||
_ -> PRNoResult
|
||||
|
||||
savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
|
||||
savePreviousResult pb rt ident res =
|
||||
withPRPath pb rt ident $ \fp -> writeFile fp $
|
||||
if res then successBS else failureBS
|
||||
|
||||
deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
|
||||
deletePreviousResults pb name =
|
||||
forM_ [minBound..maxBound] $ \rt ->
|
||||
withPRPath pb rt name $ \fp ->
|
||||
void $ tryIO $ removeFile fp
|
||||
|
||||
@ -20,6 +20,9 @@ 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
|
||||
|
||||
unPackageName :: PackageName -> Text
|
||||
unPackageName (PackageName str) = pack str
|
||||
@ -101,3 +104,13 @@ topologicalSort toFinal toDeps =
|
||||
data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
|
||||
deriving (Show, Typeable)
|
||||
instance (Show key, Typeable key) => Exception (TopologicalSortException key)
|
||||
|
||||
copyDir :: FilePath -> FilePath -> IO ()
|
||||
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'
|
||||
sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
|
||||
|
||||
@ -7,21 +7,31 @@ module Stackage.ServerBundle
|
||||
, epochTime
|
||||
, bpAllPackages
|
||||
, docsListing
|
||||
, createBundleV2
|
||||
, CreateBundleV2 (..)
|
||||
, SnapshotType (..)
|
||||
, writeIndexStyle
|
||||
, DocMap
|
||||
, PackageDocs (..)
|
||||
) where
|
||||
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
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)
|
||||
import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)
|
||||
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)
|
||||
|
||||
-- | Get current time
|
||||
epochTime :: IO Tar.EpochTime
|
||||
@ -73,13 +83,30 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
|
||||
map (\(PackageName name) -> name)
|
||||
(M.keys $ siCorePackages bpSystemInfo)
|
||||
|
||||
-- | Package name is key
|
||||
type DocMap = Map Text PackageDocs
|
||||
data PackageDocs = PackageDocs
|
||||
{ pdVersion :: Text
|
||||
, pdModules :: Map Text [Text]
|
||||
-- ^ module name, path
|
||||
}
|
||||
instance ToJSON PackageDocs where
|
||||
toJSON PackageDocs {..} = object
|
||||
[ "version" .= pdVersion
|
||||
, "modules" .= pdModules
|
||||
]
|
||||
instance FromJSON PackageDocs where
|
||||
parseJSON = withObject "PackageDocs" $ \o -> PackageDocs
|
||||
<$> o .: "version"
|
||||
<*> o .: "modules"
|
||||
|
||||
docsListing :: BuildPlan
|
||||
-> FilePath -- ^ docs directory
|
||||
-> IO ByteString
|
||||
-> IO DocMap
|
||||
docsListing bp docsDir =
|
||||
fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
|
||||
fmap fold $ mapM go $ mapToList $ bpAllPackages bp
|
||||
where
|
||||
go :: (PackageName, Version) -> IO (Map Text Y.Value)
|
||||
go :: (PackageName, Version) -> IO DocMap
|
||||
go (package, version) = do -- handleAny (const $ return mempty) $ do
|
||||
let dirname = fpFromText (concat
|
||||
[ display package
|
||||
@ -107,8 +134,138 @@ docsListing bp docsDir =
|
||||
return $ if e
|
||||
then asMap $ singletonMap name [fpToText dirname, href]
|
||||
else mempty
|
||||
return $ singletonMap (display package) $ Y.object
|
||||
[ "version" Y..= display version
|
||||
, "modules" Y..= m
|
||||
]
|
||||
return $ singletonMap (display package) $ PackageDocs
|
||||
{ pdVersion = display version
|
||||
, pdModules = m
|
||||
}
|
||||
else return mempty
|
||||
|
||||
data SnapshotType = STNightly
|
||||
| STLTS !Int !Int -- ^ major, minor
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
instance ToJSON SnapshotType where
|
||||
toJSON STNightly = object
|
||||
[ "type" .= asText "nightly"
|
||||
]
|
||||
toJSON (STLTS major minor) = object
|
||||
[ "type" .= asText "lts"
|
||||
, "major" .= major
|
||||
, "minor" .= minor
|
||||
]
|
||||
instance FromJSON SnapshotType where
|
||||
parseJSON = withObject "SnapshotType" $ \o -> do
|
||||
t <- o .: "type"
|
||||
case asText t of
|
||||
"nightly" -> return STNightly
|
||||
"lts" -> STLTS
|
||||
<$> o .: "major"
|
||||
<*> o .: "minor"
|
||||
_ -> fail $ "Unknown type for SnapshotType: " ++ unpack t
|
||||
|
||||
data CreateBundleV2 = CreateBundleV2
|
||||
{ cb2Plan :: BuildPlan
|
||||
, cb2Type :: SnapshotType
|
||||
, cb2DocsDir :: FilePath
|
||||
, cb2Dest :: FilePath
|
||||
}
|
||||
|
||||
-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc
|
||||
-- map.
|
||||
createBundleV2 :: CreateBundleV2 -> IO ()
|
||||
createBundleV2 CreateBundleV2 {..} = do
|
||||
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
|
||||
void $ writeIndexStyle Nothing cb2DocsDir
|
||||
|
||||
currentDir <- getWorkingDirectory
|
||||
files <- listDirectory docsDir
|
||||
|
||||
let args = "cfJ"
|
||||
: fpToString (currentDir </> cb2Dest)
|
||||
: "--dereference"
|
||||
: map (fpToString . filename) files
|
||||
cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }
|
||||
withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
|
||||
|
||||
writeIndexStyle :: Maybe Text -- ^ snapshot id
|
||||
-> FilePath -- ^ docs dir
|
||||
-> IO [String]
|
||||
writeIndexStyle msnapid dir = do
|
||||
dirs <- fmap sort
|
||||
$ runResourceT
|
||||
$ sourceDirectory dir
|
||||
$$ filterMC (liftIO . isDirectory)
|
||||
=$ mapC (fpToString . filename)
|
||||
=$ sinkList
|
||||
writeFile (dir </> "index.html") $ mkIndex
|
||||
(unpack <$> msnapid)
|
||||
dirs
|
||||
writeFile (dir </> "style.css") styleCss
|
||||
return dirs
|
||||
|
||||
mkIndex :: Maybe String -> [String] -> String
|
||||
mkIndex msnapid dirs = concat
|
||||
[ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
|
||||
, "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
|
||||
, "<link rel='stylesheet' href='style.css'>"
|
||||
, "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
|
||||
, "</head>"
|
||||
, "<body><div class='container'>"
|
||||
, "<div class='row'><div class='span12 col-md-12'>"
|
||||
, "<h1>Haddock documentation index</h1>"
|
||||
, flip foldMap msnapid $ \snapid -> concat
|
||||
[ "<p class='return'><a href=\"http://www.stackage.org/stackage/"
|
||||
, snapid
|
||||
, "\">Return to snapshot</a></p>"
|
||||
]
|
||||
, "<ul>"
|
||||
, concatMap toLI dirs
|
||||
, "</ul></div></div></div></body></html>"
|
||||
]
|
||||
where
|
||||
toLI name = concat
|
||||
[ "<li><a href='"
|
||||
, name
|
||||
, "/index.html'>"
|
||||
, name
|
||||
, "</a></li>"
|
||||
]
|
||||
|
||||
styleCss :: String
|
||||
styleCss = concat
|
||||
[ "@media (min-width: 530px) {"
|
||||
, "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
|
||||
, "}"
|
||||
, "@media (min-width: 760px) {"
|
||||
, "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
|
||||
, "}"
|
||||
, "ul {"
|
||||
, " margin-left: 0;"
|
||||
, " padding-left: 0;"
|
||||
, " list-style-type: none;"
|
||||
, "}"
|
||||
, "body {"
|
||||
, " background: #f0f0f0;"
|
||||
, " font-family: 'Lato', sans-serif;"
|
||||
, " text-shadow: 1px 1px 1px #ffffff;"
|
||||
, " font-size: 20px;"
|
||||
, " line-height: 30px;"
|
||||
, " padding-bottom: 5em;"
|
||||
, "}"
|
||||
, "h1 {"
|
||||
, " font-weight: normal;"
|
||||
, " color: #06537d;"
|
||||
, " font-size: 45px;"
|
||||
, "}"
|
||||
, ".return a {"
|
||||
, " color: #06537d;"
|
||||
, " font-style: italic;"
|
||||
, "}"
|
||||
, ".return {"
|
||||
, " margin-bottom: 1em;"
|
||||
, "}"]
|
||||
|
||||
@ -14,17 +14,26 @@ module Stackage.Upload
|
||||
, uploadHackageDistroNamed
|
||||
, UploadDocMap (..)
|
||||
, uploadDocMap
|
||||
, uploadBundleV2
|
||||
, UploadBundleV2 (..)
|
||||
, def
|
||||
, StackageServer
|
||||
, 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)
|
||||
import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle)
|
||||
import System.IO.Temp (withSystemTempFile)
|
||||
import qualified System.IO as IO
|
||||
import qualified Data.Yaml as Y
|
||||
|
||||
newtype StackageServer = StackageServer { unStackageServer :: Text }
|
||||
deriving (Show, Eq, Ord, Hashable, IsString)
|
||||
@ -107,17 +116,7 @@ uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do
|
||||
where
|
||||
uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do
|
||||
hClose h
|
||||
dirs <- fmap sort
|
||||
$ runResourceT
|
||||
$ sourceDirectory fp0
|
||||
$$ filterMC (liftIO . isDirectory)
|
||||
=$ mapC (fpToString . filename)
|
||||
=$ sinkList
|
||||
writeFile (fp0 </> "index.html") $ mkIndex
|
||||
(unpack $ unSnapshotIdent ident)
|
||||
dirs
|
||||
writeFile (fp0 </> "style.css") styleCss
|
||||
-- FIXME write index.html, style.css
|
||||
dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0
|
||||
let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)
|
||||
{ cwd = Just $ fpToString fp0
|
||||
}
|
||||
@ -201,7 +200,7 @@ uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)
|
||||
uploadDocMap UploadDocMap {..} man = do
|
||||
docmap <- docsListing udmPlan udmDocDir
|
||||
req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"
|
||||
req2 <- formDataBody (formData docmap) req1
|
||||
req2 <- formDataBody (formData $ Y.encode docmap) req1
|
||||
let req3 = req2
|
||||
{ method = "PUT"
|
||||
, requestHeaders =
|
||||
@ -219,61 +218,55 @@ uploadDocMap UploadDocMap {..} man = do
|
||||
, partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
|
||||
]
|
||||
|
||||
mkIndex :: String -> [String] -> String
|
||||
mkIndex snapid dirs = concat
|
||||
[ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
|
||||
, "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
|
||||
, "<link rel='stylesheet' href='style.css'>"
|
||||
, "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
|
||||
, "</head>"
|
||||
, "<body><div class='container'>"
|
||||
, "<div class='row'><div class='span12 col-md-12'>"
|
||||
, "<h1>Haddock documentation index</h1>"
|
||||
, "<p class='return'><a href=\"http://www.stackage.org/stackage/"
|
||||
, snapid
|
||||
, "\">Return to snapshot</a></p><ul>"
|
||||
, concatMap toLI dirs
|
||||
, "</ul></div></div></div></body></html>"
|
||||
]
|
||||
where
|
||||
toLI name = concat
|
||||
[ "<li><a href='"
|
||||
, name
|
||||
, "/index.html'>"
|
||||
, name
|
||||
, "</a></li>"
|
||||
]
|
||||
data UploadBundleV2 = UploadBundleV2
|
||||
{ ub2Server :: StackageServer
|
||||
, ub2AuthToken :: Text
|
||||
, ub2Bundle :: FilePath
|
||||
}
|
||||
|
||||
styleCss :: String
|
||||
styleCss = concat
|
||||
[ "@media (min-width: 530px) {"
|
||||
, "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
|
||||
, "}"
|
||||
, "@media (min-width: 760px) {"
|
||||
, "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
|
||||
, "}"
|
||||
, "ul {"
|
||||
, " margin-left: 0;"
|
||||
, " padding-left: 0;"
|
||||
, " list-style-type: none;"
|
||||
, "}"
|
||||
, "body {"
|
||||
, " background: #f0f0f0;"
|
||||
, " font-family: 'Lato', sans-serif;"
|
||||
, " text-shadow: 1px 1px 1px #ffffff;"
|
||||
, " font-size: 20px;"
|
||||
, " line-height: 30px;"
|
||||
, " padding-bottom: 5em;"
|
||||
, "}"
|
||||
, "h1 {"
|
||||
, " font-weight: normal;"
|
||||
, " color: #06537d;"
|
||||
, " font-size: 45px;"
|
||||
, "}"
|
||||
, ".return a {"
|
||||
, " color: #06537d;"
|
||||
, " font-style: italic;"
|
||||
, "}"
|
||||
, ".return {"
|
||||
, " margin-bottom: 1em;"
|
||||
, "}"]
|
||||
uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text
|
||||
uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do
|
||||
size <- IO.hFileSize h
|
||||
putStrLn $ "Bundle size: " ++ tshow size
|
||||
req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
|
||||
let req2 = req1
|
||||
{ method = "PUT"
|
||||
, requestHeaders =
|
||||
[ ("Authorization", encodeUtf8 ub2AuthToken)
|
||||
, ("Accept", "application/json")
|
||||
, ("Content-Type", "application/x-tar")
|
||||
]
|
||||
, requestBody = HCC.requestBodySource (fromIntegral size)
|
||||
$ sourceHandle h $= printProgress size
|
||||
}
|
||||
sink = decodeUtf8C =$ fix (\loop -> do
|
||||
mx <- peekC
|
||||
case mx of
|
||||
Nothing -> error $ "uploadBundleV2: premature end of stream"
|
||||
Just _ -> do
|
||||
l <- lineC $ takeCE 4096 =$ foldC
|
||||
let (cmd, msg') = break (== ':') l
|
||||
msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
|
||||
case cmd of
|
||||
"CONT" -> do
|
||||
putStrLn msg
|
||||
loop
|
||||
"FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
|
||||
"SUCCESS" -> return msg
|
||||
_ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
|
||||
)
|
||||
withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink
|
||||
where
|
||||
printProgress total =
|
||||
loop 0 0
|
||||
where
|
||||
loop sent lastPercent =
|
||||
await >>= maybe (putStrLn "Upload complete") go
|
||||
where
|
||||
go bs = do
|
||||
yield bs
|
||||
let sent' = sent + fromIntegral (length bs)
|
||||
percent = sent' * 100 `div` total
|
||||
when (percent /= lastPercent)
|
||||
$ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"
|
||||
loop sent' percent
|
||||
|
||||
@ -10,7 +10,11 @@ import Options.Applicative
|
||||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
import Paths_stackage (version)
|
||||
import Stackage.CompleteBuild
|
||||
import Stackage.Upload
|
||||
import Stackage.InstallBuild
|
||||
import Network.HTTP.Client (withManager)
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
import qualified Data.Text as T
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
@ -62,7 +66,13 @@ main =
|
||||
installBuild
|
||||
installFlags
|
||||
"install"
|
||||
"Install a snapshot from an existing build plan"]
|
||||
"Install a snapshot from an existing build plan"
|
||||
, cmnd
|
||||
uploadv2
|
||||
uploadv2Flags
|
||||
"upload2"
|
||||
"Upload a pre-existing v2 bundle"
|
||||
]
|
||||
|
||||
cmnd exec parse name desc =
|
||||
command name $
|
||||
@ -77,6 +87,11 @@ main =
|
||||
(switch
|
||||
(long "skip-tests" <>
|
||||
help "Skip build and running the test suites")) <*>
|
||||
fmap
|
||||
not
|
||||
(switch
|
||||
(long "skip-haddock" <>
|
||||
help "Skip generating haddock documentation")) <*>
|
||||
fmap
|
||||
not
|
||||
(switch
|
||||
@ -85,12 +100,23 @@ main =
|
||||
switch
|
||||
(long "enable-library-profiling" <>
|
||||
help "Enable profiling when building") <*>
|
||||
switch
|
||||
(long "enable-executable-dynamic" <>
|
||||
help "Enable dynamic executables when building") <*>
|
||||
switch
|
||||
(long "verbose" <> short 'v' <>
|
||||
help "Output verbose detail about the build steps") <*>
|
||||
switch
|
||||
(long "skip-check" <>
|
||||
help "Skip the check phase, and pass --allow-newer to cabal configure")
|
||||
help "Skip the check phase, and pass --allow-newer to cabal configure") <*>
|
||||
switch
|
||||
(long "upload-v1" <>
|
||||
help "Use the V1 upload code") <*>
|
||||
(fmap fromString (strOption
|
||||
(long "server-url" <>
|
||||
metavar "SERVER-URL" <>
|
||||
showDefault <> value (T.unpack $ unStackageServer def) <>
|
||||
help "Server to upload bundle to")))
|
||||
|
||||
nightlyUploadFlags = fromString <$> strArgument
|
||||
(metavar "DATE" <>
|
||||
@ -136,12 +162,39 @@ main =
|
||||
(switch
|
||||
(long "skip-tests" <>
|
||||
help "Skip build and running the test suites")) <*>
|
||||
fmap
|
||||
not
|
||||
(switch
|
||||
(long "skip-haddock" <>
|
||||
help "Skip generating haddock documentation")) <*>
|
||||
switch
|
||||
(long "enable-library-profiling" <>
|
||||
help "Enable profiling when building") <*>
|
||||
switch
|
||||
(long "enable-executable-dynamic" <>
|
||||
help "Enable dynamic executables when building") <*>
|
||||
switch
|
||||
(long "verbose" <> short 'v' <>
|
||||
help "Output verbose detail about the build steps") <*>
|
||||
switch
|
||||
(long "skip-check" <>
|
||||
help "Skip the check phase, and pass --allow-newer to cabal configure")
|
||||
|
||||
uploadv2 (path, url) = withManager tlsManagerSettings $ \man -> do
|
||||
token <- getStackageAuthToken
|
||||
res <- flip uploadBundleV2 man UploadBundleV2
|
||||
{ ub2AuthToken = token
|
||||
, ub2Server = fromString url
|
||||
, ub2Bundle = decodeString path
|
||||
}
|
||||
putStrLn $ "New URL: " ++ T.unpack res
|
||||
|
||||
uploadv2Flags = (,)
|
||||
<$> (strArgument
|
||||
(metavar "BUNDLE-PATH" <>
|
||||
help "Bundle path"))
|
||||
<*> strOption
|
||||
(long "server-url" <>
|
||||
metavar "SERVER-URL" <>
|
||||
showDefault <> value (T.unpack $ unStackageServer def) <>
|
||||
help "Server to upload bundle to")
|
||||
|
||||
@ -379,6 +379,7 @@ packages:
|
||||
- pipes
|
||||
- pipes-parse
|
||||
- pipes-concurrency
|
||||
- pipes-safe
|
||||
|
||||
"Chris Allen <cma@bitemyapp.com>":
|
||||
- bloodhound
|
||||
@ -390,9 +391,12 @@ packages:
|
||||
- fay-jquery
|
||||
- fay-text
|
||||
- fay-uri
|
||||
- fclabels
|
||||
- snaplet-fay
|
||||
|
||||
"Sebastiaan Visser <haskell@fvisser.nl>":
|
||||
- clay
|
||||
- fclabels
|
||||
|
||||
"Rodrigo Setti <rodrigosetti@gmail.com>":
|
||||
- messagepack
|
||||
- messagepack-rpc
|
||||
@ -473,7 +477,8 @@ packages:
|
||||
- openpgp-asciiarmor
|
||||
- MusicBrainz
|
||||
- DAV
|
||||
- hopenpgp-tools
|
||||
# https://github.com/fpco/stackage/issues/463
|
||||
#- hopenpgp-tools
|
||||
|
||||
# https://github.com/fpco/stackage/issues/160
|
||||
"Ketil Malde":
|
||||
@ -503,9 +508,9 @@ packages:
|
||||
- code-builder
|
||||
- fay-builder
|
||||
- generic-aeson
|
||||
- generic-xmlpickler
|
||||
- hxt-pickle-utils
|
||||
- imagesize-conduit
|
||||
- imagesize-conduit
|
||||
- json-schema
|
||||
- multipart
|
||||
- regular-xmlpickler
|
||||
@ -518,8 +523,6 @@ packages:
|
||||
- rest-types
|
||||
- rest-wai
|
||||
- tostring
|
||||
- tostring
|
||||
- uri-encode
|
||||
- uri-encode
|
||||
|
||||
"Simon Michael <simon@joyful.com>":
|
||||
@ -529,7 +532,10 @@ packages:
|
||||
- io-manager
|
||||
|
||||
"Dimitri Sabadie <dimitri.sabadie@gmail.com":
|
||||
# https://github.com/fpco/stackage/pull/461#issuecomment-76914158
|
||||
# - al
|
||||
- monad-journal
|
||||
- smoothie
|
||||
|
||||
"Thomas Schilling <nominolo@googlemail.com>":
|
||||
- ghc-syb-utils
|
||||
@ -574,6 +580,7 @@ packages:
|
||||
- haddock-api
|
||||
- here
|
||||
- hlibgit2
|
||||
- gitlib-libgit2
|
||||
- hostname-validate
|
||||
- interpolatedstring-perl6
|
||||
- iproute
|
||||
@ -612,6 +619,9 @@ packages:
|
||||
- Spock
|
||||
- Spock-digestive
|
||||
- Spock-worker
|
||||
- users
|
||||
- users-test
|
||||
- users-postgresql-simple
|
||||
|
||||
"Joey Eremondi <joey@eremondi.com>":
|
||||
- aeson-pretty
|
||||
@ -641,6 +651,11 @@ packages:
|
||||
"Samplecount stefan@samplecount.com @kaoskorobase":
|
||||
- shake-language-c
|
||||
|
||||
"Marcin Mrotek <marcin.jan.mrotek@gmail.com>":
|
||||
- diagrams-hsqml
|
||||
- type-list
|
||||
- vinyl-utils
|
||||
|
||||
"Marcin Mrotek <marcin.jan.mrotek@gmail.com>":
|
||||
- type-list
|
||||
|
||||
@ -703,19 +718,37 @@ packages:
|
||||
"Gabríel Arthúr Pétursson gabriel@system.is":
|
||||
- sdl2
|
||||
|
||||
"Stackage upper bounds":
|
||||
"Leon Mergen leon@solatis.com @solatis":
|
||||
- network-attoparsec
|
||||
- network-anonymous-i2p
|
||||
|
||||
# https://github.com/fpco/stackage/issues/291
|
||||
- random < 1.0.1.3
|
||||
"Timothy Jones git@zmthy.io @zmthy":
|
||||
- cabal-test-quickcheck
|
||||
- http-media
|
||||
|
||||
"Greg V greg@unrelenting.technology @myfreeweb":
|
||||
- gitson
|
||||
- pcre-heavy
|
||||
|
||||
"Francesco Mazzoli f@mazzo.li @bitonic":
|
||||
- language-c-quote
|
||||
|
||||
"Sönke Hahn soenkehahn@gmail.com @soenkehahn":
|
||||
- string-conversions
|
||||
|
||||
"Oleg Grenrus oleg.grenrus@iki.fi @phadej":
|
||||
- waitra
|
||||
|
||||
"Adam C. Foltzer acfoltzer@galois.com @acfoltzer":
|
||||
- gitrev
|
||||
|
||||
"Stackage upper bounds":
|
||||
|
||||
# https://github.com/fpco/stackage/issues/390
|
||||
# NOTE: When this issue is resolved, remove the expected test failure
|
||||
# for language-ecmascript as well.
|
||||
- language-ecmascript < 0.17
|
||||
|
||||
# https://github.com/fpco/stackage/issues/402
|
||||
- vector-space < 0.9
|
||||
|
||||
# https://github.com/fpco/stackage/issues/407
|
||||
- HStringTemplate < 0.8
|
||||
|
||||
@ -731,22 +764,32 @@ packages:
|
||||
# https://github.com/fpco/stackage/issues/426
|
||||
- utf8-string < 1
|
||||
|
||||
# https://github.com/d12frosted/CanonicalPath/issues/3
|
||||
- system-canonicalpath < 0.3
|
||||
|
||||
# https://github.com/fpco/stackage/issues/440
|
||||
- th-orphans < 0.9
|
||||
- file-location < 0.4.7
|
||||
- th-desugar < 1.5.1
|
||||
|
||||
# https://github.com/fpco/stackage/issues/442
|
||||
- blaze-builder < 0.4
|
||||
- blaze-markup < 0.7
|
||||
- blaze-html < 0.8
|
||||
|
||||
# https://github.com/fpco/stackage/issues/443
|
||||
- exceptions < 0.7
|
||||
- resourcet < 1.1.4
|
||||
- rest-client < 0.5
|
||||
- rest-types < 1.13
|
||||
- rest-core < 0.35
|
||||
- rest-gen < 0.17
|
||||
- rest-wai < 0.1.0.7
|
||||
|
||||
# https://github.com/fpco/stackage/issues/445
|
||||
- semigroupoids < 4.3
|
||||
# https://github.com/fpco/stackage/issues/467
|
||||
- lens < 4.8
|
||||
|
||||
# https://github.com/fpco/stackage/issues/476
|
||||
- vector-space < 0.10
|
||||
|
||||
# https://github.com/ekmett/linear/issues/70
|
||||
- linear < 1.18
|
||||
|
||||
# Package flags are applied to individual packages, and override the values of
|
||||
# global-flags
|
||||
@ -918,9 +961,6 @@ expected-test-failures:
|
||||
# https://github.com/BioHaskell/octree/issues/4
|
||||
- Octree
|
||||
|
||||
# https://github.com/goldfirere/th-desugar/issues/12
|
||||
- th-desugar
|
||||
|
||||
# https://github.com/jmillikin/haskell-filesystem/issues/3
|
||||
- system-filepath
|
||||
|
||||
@ -993,20 +1033,52 @@ expected-test-failures:
|
||||
# https://github.com/haskell-distributed/distributed-process-execution/issues/2
|
||||
- distributed-process-execution
|
||||
|
||||
# Seems to depend on mtl being installed in user package database, which
|
||||
# isn't always the case (e.g., build server)
|
||||
- happy
|
||||
|
||||
# https://github.com/jberryman/directory-tree/issues/4
|
||||
- directory-tree
|
||||
|
||||
# https://github.com/zmthy/http-media/issues/11
|
||||
- http-media
|
||||
|
||||
# https://github.com/ekmett/semigroupoids/issues/18
|
||||
- semigroupoids
|
||||
|
||||
# https://github.com/ndmitchell/hoogle/issues/101
|
||||
- hoogle
|
||||
|
||||
# https://github.com/myfreeweb/gitson/issues/1
|
||||
- gitson
|
||||
|
||||
# https://github.com/jcristovao/enclosed-exceptions/issues/6
|
||||
- enclosed-exceptions
|
||||
|
||||
# Expects a running PostgreSQL server
|
||||
- users-postgresql-simple
|
||||
|
||||
# Problems with linking with system libraries on Ubuntu 12.04
|
||||
- nettle
|
||||
|
||||
# Requires locally running services
|
||||
- network-anonymous-i2p
|
||||
|
||||
# Haddocks which are expected to fail. Same concept as expected test failures.
|
||||
expected-haddock-failures:
|
||||
# https://github.com/acw/bytestring-progress/issues/4
|
||||
- bytestring-progress
|
||||
|
||||
# https://github.com/ekmett/gl/issues/4
|
||||
- gl
|
||||
|
||||
# https://github.com/leventov/yarr/issues/5
|
||||
- yarr
|
||||
|
||||
# https://github.com/wereHamster/rethinkdb-client-driver/issues/1
|
||||
- rethinkdb-client-driver
|
||||
|
||||
# Requires build before haddock, which doesn't always happen in incremental
|
||||
# builds. Could consider special-casing this requirement.
|
||||
- gtk
|
||||
|
||||
# Benchmarks which should not be built. Note that Stackage does *not* generally
|
||||
# build benchmarks. The difference here will be whether dependencies for these
|
||||
# benchmarks are included or not.
|
||||
|
||||
@ -18,6 +18,9 @@ apt-get install -y \
|
||||
build-essential \
|
||||
libncurses-dev \
|
||||
git \
|
||||
wget \
|
||||
m4 \
|
||||
texlive-full \
|
||||
libgmp3c2 \
|
||||
libgmp3-dev \
|
||||
zlib1g-dev \
|
||||
@ -34,11 +37,11 @@ apt-get install -y \
|
||||
llvm \
|
||||
libbz2-dev \
|
||||
libjudy-dev \
|
||||
libsqlite3-dev \
|
||||
libmysqlclient-dev \
|
||||
libpq-dev \
|
||||
libicu-dev \
|
||||
libssl-dev \
|
||||
nettle-dev \
|
||||
libgsl0-dev \
|
||||
libblas-dev \
|
||||
liblapack-dev \
|
||||
@ -49,4 +52,20 @@ apt-get install -y \
|
||||
libyaml-dev \
|
||||
liblzma-dev \
|
||||
libsdl2-dev \
|
||||
libxss-dev \
|
||||
libzmq3-dev
|
||||
|
||||
mkdir /tmp/nettle-build
|
||||
(
|
||||
cd /tmp/nettle-build
|
||||
wget https://ftp.gnu.org/gnu/nettle/nettle-2.7.1.tar.gz
|
||||
tar zxf nettle-2.7.1.tar.gz
|
||||
cd nettle-2.7.1
|
||||
./configure --prefix=/usr
|
||||
make
|
||||
make install
|
||||
|
||||
mkdir -p /usr/lib/x86_64-linux-gnu/
|
||||
ln -sfv /usr/lib/libnettle.so.4.7 /usr/lib/x86_64-linux-gnu/libnettle.so.4
|
||||
)
|
||||
rm -rf /tmp/nettle-build
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: stackage
|
||||
version: 0.5.2
|
||||
version: 0.6.0.1
|
||||
synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage.
|
||||
description: Please see <http://www.stackage.org/package/stackage> for a description and documentation.
|
||||
homepage: https://github.com/fpco/stackage
|
||||
@ -23,6 +23,7 @@ library
|
||||
Stackage.BuildPlan
|
||||
Stackage.CheckBuildPlan
|
||||
Stackage.UpdateBuildPlan
|
||||
Stackage.GhcPkg
|
||||
Stackage.GithubPings
|
||||
Stackage.InstallBuild
|
||||
Stackage.PackageDescription
|
||||
@ -54,6 +55,7 @@ library
|
||||
, yaml
|
||||
, unix-compat
|
||||
, http-client
|
||||
, http-conduit
|
||||
, http-client-tls
|
||||
, temporary
|
||||
, data-default-class
|
||||
@ -63,6 +65,7 @@ library
|
||||
, streaming-commons >= 0.1.7.1
|
||||
, semigroups
|
||||
, xml-conduit
|
||||
, conduit
|
||||
|
||||
executable stackage
|
||||
default-language: Haskell2010
|
||||
@ -72,6 +75,9 @@ executable stackage
|
||||
, stackage
|
||||
, optparse-applicative >= 0.11
|
||||
, system-filepath
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, text
|
||||
ghc-options: -rtsopts -threaded -with-rtsopts=-N
|
||||
|
||||
test-suite spec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user