module Stackage.CompleteBuild
( BuildType (..)
, BumpType (..)
, BuildFlags (..)
, checkPlan
, getStackageAuthToken
, createPlan
, fetch
, makeBundle
, upload
, hackageDistro
, uploadGithub
) where
import System.Directory (getAppUserDataDirectory)
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 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 (..))
data BuildFlags = BuildFlags
{ bfEnableTests :: !Bool
, bfEnableHaddock :: !Bool
, bfDoUpload :: !Bool
, bfEnableLibProfile :: !Bool
, bfEnableExecDyn :: !Bool
, bfVerbose :: !Bool
, bfSkipCheck :: !Bool
, bfServer :: !StackageServer
, bfBuildHoogle :: !Bool
, bfBundleDest :: !(Maybe FilePath)
, bfGitPush :: !Bool
, bfJobs :: !(Maybe Int)
, bfPlanFile :: !(Maybe FilePath)
, bfPreBuild :: !Bool
, 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
, slug :: Text
, postBuild :: IO ()
, distroName :: Text
, snapshotType :: SnapshotType
, bundleDest :: FilePath
}
nightlyPlanFile :: Text
-> FilePath
nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"
nightlySettings :: Text
-> 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 = STNightly
, bundleDest = fromMaybe
(fpFromText $ "stackage-nightly-" ++ day ++ ".bundle")
(bfBundleDest bf)
}
where
slug' = "nightly-" ++ 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
Major -> major' < major
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
getSettings :: Manager -> BuildFlags -> BuildType -> Maybe FilePath -> IO Settings
getSettings man bf Nightly mplanFile = do
day <- tshow . utctDay <$> getCurrentTime
plan' <- case mplanFile of
Nothing -> do
bc <- defaultBuildConstraints man
pkgs <- getLatestAllowedPlans bc
newBuildPlan pkgs bc
Just file -> decodeFileEither (fpToString file) >>= either throwIO return
return $ nightlySettings day bf plan'
getSettings man bf (LTS bumpType goal) Nothing = do
matchesGoal <- parseGoal bumpType goal
Option mlts <- fmap (fmap getMax) $ runResourceT
$ sourceDirectory "."
$= concatMapC (parseLTSVer . filename)
$= filterC matchesGoal
$$ foldMapC (Option . Just . Max)
(new, plan') <- case bumpType of
Major -> do
let new =
case mlts of
Nothing -> LTSVer 0 0
Just (LTSVer x _) -> LTSVer (x + 1) 0
bc <- defaultBuildConstraints man
pkgs <- getLatestAllowedPlans bc
plan' <- newBuildPlan pkgs bc
return (new, plan')
Minor -> do
old <- maybe (error "No LTS plans found in current directory") return mlts
oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
>>= either throwM return
let new = incrLTSVer old
let bc = updateBuildConstraints oldplan
pkgs <- getLatestAllowedPlans bc
plan' <- newBuildPlan pkgs bc
return (new, plan')
let newfile = renderLTSVer new
return Settings
{ planFile = fromMaybe newfile (bfPlanFile bf)
, buildDir = fpFromText $ "builds/lts"
, logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
, title = \ghcVer -> concat
[ "LTS Haskell "
, tshow new
, ", GHC "
, ghcVer
]
, slug = "lts-" ++ tshow new
, plan = plan'
, postBuild = do
let git args = withCheckedProcess
(proc "git" args) $ \ClosedStream Inherited Inherited ->
return ()
putStrLn "Committing new LTS file to Git"
git ["add", fpToString newfile]
git ["commit", "-m", "Added new LTS release: " ++ show new]
when (bfGitPush bf) $ do
putStrLn "Pushing to Git repository"
git ["push"]
, distroName = "LTSHaskell"
, snapshotType =
case new of
LTSVer x y -> STLTS x y
, bundleDest = fromMaybe
(fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle")
(bfBundleDest bf)
}
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
-> IO ()
createPlan target dest = withManager tlsManagerSettings $ \man -> do
putStrLn $ "Creating plan for: " ++ tshow target
bc <-
case target of
TargetMinor x y -> do
let url = concat
[ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-"
, show x
, "."
, show (y 1)
, ".yaml"
]
putStrLn $ "Downloading old plan from " ++ pack url
req <- parseUrl url
res <- httpLbs req man
oldplan <- either throwM return
$ decodeEither' (toStrict $ responseBody res)
return $ updateBuildConstraints oldplan
_ -> defaultBuildConstraints man
plan <- planFromConstraints bc
putStrLn $ "Writing build plan to " ++ fpToText dest
encodeFile (fpToString dest) plan
planFromConstraints bc = do
putStrLn "Creating build plan"
plans <- getLatestAllowedPlans bc
newBuildPlan plans bc
renderLTSVer :: LTSVer -> FilePath
renderLTSVer lts = fpFromText $ concat
[ "lts-"
, tshow lts
, ".yaml"
]
stillAlive :: IO () -> IO ()
stillAlive inner =
withAsync (printer 1) $ const inner
where
printer i = forever $ do
threadDelay 60000000
putStrLn $ "Still alive: " ++ tshow i
printer $! i + 1
checkPlan :: Maybe FilePath -> IO ()
checkPlan mfp = stillAlive $ withManager tlsManagerSettings $ \man -> do
plan <-
case mfp of
Nothing -> do
putStrLn "Loading default build constraints"
bc <- defaultBuildConstraints man
plan <- planFromConstraints bc
putStrLn $ "Writing build plan to check-plan.yaml"
encodeFile "check-plan.yaml" plan
return plan
Just fp -> do
putStrLn $ "Loading plan from " ++ fpToText fp
decodeFileEither (fpToString fp) >>= either throwM return
putStrLn "Checking plan"
checkBuildPlan plan
putStrLn "Plan seems valid!"
getPerformBuild :: BuildFlags -> Settings -> IO PerformBuild
getPerformBuild buildFlags Settings {..} = do
jobs <- maybe getNumCapabilities return $ bfJobs buildFlags
return PerformBuild
{ pbPlan = plan
, pbInstallDest = buildDir
, pbLogDir = logDir
, pbLog = hPut stdout
, pbJobs = jobs
, pbGlobalInstall = False
, pbEnableTests = bfEnableTests buildFlags
, pbEnableHaddock = bfEnableHaddock buildFlags
, pbEnableLibProfiling = bfEnableLibProfile buildFlags
, pbEnableExecDyn = bfEnableExecDyn buildFlags
, pbVerbose = bfVerbose buildFlags
, pbAllowNewer = bfSkipCheck buildFlags
, pbBuildHoogle = bfBuildHoogle buildFlags
}
getStackageAuthToken :: IO Text
getStackageAuthToken = do
mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"
case mtoken of
Nothing -> decodeUtf8 <$> readFile "/auth-token"
Just token -> return $ pack token
hackageDistro
:: FilePath
-> Target
-> IO ()
hackageDistro planFile target = withManager tlsManagerSettings $ \man -> do
plan <- decodeFileEither (fpToString planFile) >>= either throwM return
ecreds <- tryIO $ readFile "/hackage-creds"
case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
[username, password] -> do
putStrLn $ "Uploading as Hackage distro: " ++ distroName
res2 <- uploadHackageDistro distroName plan username password man
putStrLn $ "Distro upload response: " ++ tshow res2
_ -> error "No Hackage creds found at /hackage-creds"
where
distroName =
case target of
TargetNightly -> "Stackage"
TargetMajor _ -> "LTSHaskell"
TargetMinor _ _ -> "LTSHaskell"
uploadGithub
:: FilePath
-> Target
-> IO ()
uploadGithub planFile target = do
let repoUrl =
case target of
TargetNightly -> "git@github.com:fpco/stackage-nightly"
_ -> "git@github.com:fpco/lts-haskell"
root <- fpFromString <$> getAppUserDataDirectory "stackage-curator"
now <- getCurrentTime
let repoDir =
case target of
TargetNightly -> root </> "stackage-nightly"
_ -> root </> "lts-haskell"
destFP =
case target of
TargetNightly -> repoDir </> (fpFromString $ concat
[ "nightly-"
, show $ utctDay now
, ".yaml"
])
TargetMajor x -> repoDir </> (fpFromString $ concat
[ "lts-"
, show x
, ".0.yaml"
])
TargetMinor x y -> repoDir </> (fpFromString $ concat
[ "lts-"
, show x
, "."
, show y
, ".yaml"
])
runIn wdir cmd args = do
putStrLn $ concat
[ fpToText wdir
, ": "
, tshow (cmd:args)
]
withCheckedProcess
(proc cmd args)
{ cwd = Just $ fpToString wdir
} $ \ClosedStream Inherited Inherited -> return ()
git = runIn repoDir "git"
exists <- isDirectory repoDir
if exists
then do
git ["fetch"]
git ["checkout", "origin/master"]
else do
createTree $ parent repoDir
runIn "." "git" ["clone", repoUrl, fpToString repoDir]
runResourceT $ sourceFile planFile $$ (sinkFile destFP :: Sink ByteString (ResourceT IO) ())
git ["add", fpToString destFP]
git ["commit", "-m", "Checking in " ++ fpToString (filename destFP)]
git ["push", "origin", "HEAD:master"]
upload
:: FilePath
-> StackageServer
-> IO ()
upload bundleFile server = withManager tlsManagerSettings $ \man -> do
putStrLn "Uploading bundle to Stackage Server"
token <- getStackageAuthToken
res <- flip uploadBundleV2 man UploadBundleV2
{ ub2Server = server
, ub2AuthToken = token
, ub2Bundle = bundleFile
}
putStrLn $ "New snapshot available at: " ++ res
makeBundle
:: FilePath
-> FilePath
-> Target
-> Maybe Int
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> IO ()
makeBundle
planFile bundleFile target mjobs skipTests skipHaddocks skipHoogle
enableLibraryProfiling enableExecutableDynamic verbose allowNewer
= do
plan <- decodeFileEither (fpToString planFile) >>= either throwM return
jobs <- maybe getNumCapabilities return mjobs
let pb = PerformBuild
{ pbPlan = plan
, pbInstallDest =
case target of
TargetNightly -> "builds/nightly"
TargetMajor x -> fpFromText $ "builds/lts-" ++ tshow x
TargetMinor x _ -> fpFromText $ "builds/lts-" ++ tshow x
, pbLog = hPut stdout
, pbLogDir =
case target of
TargetNightly -> "logs/nightly"
TargetMajor x -> fpFromText $ "logs/lts-" ++ tshow x
TargetMinor x _ -> fpFromText $ "logs/lts-" ++ tshow x
, pbJobs = jobs
, pbGlobalInstall = False
, pbEnableTests = not skipTests
, pbEnableHaddock = not skipHaddocks
, pbEnableLibProfiling = enableLibraryProfiling
, pbEnableExecDyn = enableExecutableDynamic
, pbVerbose = verbose
, pbAllowNewer = allowNewer
, pbBuildHoogle = not skipHoogle
}
putStrLn "Performing build"
performBuild pb >>= mapM_ putStrLn
putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleFile
createBundleV2 CreateBundleV2
{ cb2Plan = plan
, cb2Type =
case target of
TargetNightly -> STNightly
TargetMajor x -> STLTS x 0
TargetMinor x y -> STLTS x y
, cb2DocsDir = pbDocDir pb
, cb2Dest = bundleFile
}
fetch :: FilePath -> IO ()
fetch planFile = withManager tlsManagerSettings $ \man -> do
putStrLn "Pre-fetching all packages"
plan <- decodeFileEither (fpToString planFile) >>= either throwM return
cabalDir <- fpFromString <$> getAppUserDataDirectory "cabal"
parMapM_ 8 (download man cabalDir) $ mapToList $ bpPackages plan
where
download man cabalDir (display -> name, display . ppVersion -> version) = do
unlessM (isFile fp) $ do
hPut stdout $ encodeUtf8 $ concat
[ "Downloading "
, name
, "-"
, version
, "\n"
]
createTree $ parent fp
req <- parseUrl url
withResponse req man $ \res -> do
let tmp = fp <.> "tmp"
runResourceT $ bodyReaderSource (responseBody res) $$ sinkFile tmp
rename tmp fp
where
url = unpack $ concat
[ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
, name
, "-"
, version
, ".tar.gz"
]
fp = cabalDir </>
"packages" </>
"hackage.haskell.org" </>
fpFromText name </>
fpFromText version </>
fpFromText (concat [name, "-", version, ".tar.gz"])
parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono)
=> Int
-> (Element mono -> m ())
-> mono
-> m ()
parMapM_ (max 1 -> 1) f xs = mapM_ f xs
parMapM_ cnt f xs0 = do
var <- liftBase $ newTVarIO $ toList xs0
run <- askRunBase
let worker :: IO ()
worker = run $ fix $ \loop -> join $ atomically $ do
xs <- readTVar var
case xs of
[] -> return $ return ()
x:xs' -> do
writeTVar var xs'
return $ do
f x
loop
workers 1 = Concurrently worker
workers i = Concurrently worker *> workers (i 1)
liftBase $ runConcurrently $ workers cnt