mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
Switch to stackage-build-plan
This commit is contained in:
Michael Snoyman
parent
4935dd4287
commit
9c57579caa
@ -10,161 +10,20 @@ import Control.Monad.Catch.Pure (runCatch)
|
||||
import Stackage.Types
|
||||
import Distribution.Package (PackageName (..))
|
||||
import Data.Version (Version)
|
||||
import Stackage.BuildPlan
|
||||
|
||||
getBuildPlanR :: SnapSlug -> Handler TypedContent
|
||||
getBuildPlanR slug = do
|
||||
mlts <- runDB $ do
|
||||
Entity sid _ <- getBy404 $ UniqueSnapshot slug
|
||||
selectFirst [LtsStackage ==. sid] [Desc LtsMajor, Desc LtsMinor]
|
||||
Entity _ (Lts major minor _) <-
|
||||
case mlts of
|
||||
Just lts -> return lts
|
||||
Nothing -> invalidArgs ["Build plans are only available for LTS snapshots"]
|
||||
|
||||
fp <- fmap fpToString $ ltsFP $ concat [tshow major, ".", tshow minor]
|
||||
bp <- liftIO $ decodeFileEither fp >>= either throwIO return
|
||||
-- treat packages as a set to skip duplicates and make order of parameters
|
||||
-- irrelevant
|
||||
packages <- setFromList <$> lookupGetParams "package"
|
||||
when (null packages) $ invalidArgs ["Must provide at least one package"]
|
||||
fullDeps <- (== Just "true") <$> lookupGetParam "full-deps"
|
||||
let eres = runCatch $ execStateT (getDeps bp fullDeps packages) (mempty, id)
|
||||
case eres of
|
||||
Left e -> invalidArgs [tshow e]
|
||||
Right (_, front) -> selectRep $ do
|
||||
provideRep $ return $ unlines $ flip map (front [])
|
||||
$ \(x, y, _, _) -> unwords [display x, display y]
|
||||
provideRep $ return $ toJSON $ map tupleToValue $ front []
|
||||
provideRepType "application/x-sh" $ return $ toShellScript $ front []
|
||||
|
||||
toShellScript :: [(PackageName, Version, Map Text Bool, Bool)]
|
||||
-> Source (ResourceT IO) Text
|
||||
toShellScript packages = do
|
||||
yield "#!/usr/bin/env bash\nset -eux\n"
|
||||
forM_ packages $ \(pkg, ver, flagOverrides, isCore) -> unless isCore $ do
|
||||
let prefix = concat [display pkg, "-", display ver]
|
||||
tarball = prefix ++ ".tar.gz"
|
||||
yield $ unlines
|
||||
[ ""
|
||||
, concat
|
||||
[ "rm -rf "
|
||||
, prefix
|
||||
, " "
|
||||
, tarball
|
||||
]
|
||||
, "wget https://s3.amazonaws.com/hackage.fpcomplete.com/package/" ++ tarball
|
||||
, "tar xf " ++ tarball
|
||||
, "cd " ++ prefix
|
||||
, concat
|
||||
[ "runghc Setup configure --user --flags='"
|
||||
, showFlags flagOverrides
|
||||
, "'"
|
||||
]
|
||||
, "runghc Setup build"
|
||||
, "runghc Setup copy"
|
||||
, "runghc Setup register"
|
||||
, "cd .."
|
||||
]
|
||||
where
|
||||
showFlags =
|
||||
unwords . map go . mapToList
|
||||
where
|
||||
go (name, isOn) = (if isOn then id else (cons '-')) name
|
||||
|
||||
type HttpM env m =
|
||||
( MonadReader env m
|
||||
, MonadIO m
|
||||
, HasHttpManager env
|
||||
, MonadBaseControl IO m
|
||||
, MonadThrow m
|
||||
)
|
||||
|
||||
ltsFP :: HttpM env m
|
||||
=> Text
|
||||
-> m FilePath
|
||||
ltsFP ltsVer = do
|
||||
--dir <- liftIO $ F.getAppDataDirectory "stackage-bootstrap"
|
||||
let dir = "/tmp/stackage-bootstrap" -- HOME not set on server
|
||||
let fp = dir </> fpFromText ("lts-" ++ ltsVer) <.> "yaml"
|
||||
exists <- liftIO $ F.isFile fp
|
||||
if exists
|
||||
then return fp
|
||||
else do
|
||||
liftIO $ F.createTree dir
|
||||
let tmp = fp <.> "tmp"
|
||||
download ltsVer tmp
|
||||
liftIO $ F.rename tmp fp
|
||||
return fp
|
||||
|
||||
download :: HttpM env m
|
||||
=> Text
|
||||
-> FilePath
|
||||
-> m ()
|
||||
download ltsVer dest = do
|
||||
req <- parseUrl $ unpack $ concat
|
||||
[ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-"
|
||||
, ltsVer
|
||||
, ".yaml"
|
||||
]
|
||||
withResponse req $ \res -> liftIO $ F.withFile dest F.WriteMode $ \h ->
|
||||
responseBody res $$ sinkHandle h
|
||||
|
||||
tupleToValue :: (PackageName, Version, Map Text Bool, Bool) -> Value
|
||||
tupleToValue (name, version, flags, isCore) = object
|
||||
[ "name" .= display name
|
||||
, "version" .= display version
|
||||
, "flags" .= flags
|
||||
, "is-core" .= isCore
|
||||
]
|
||||
|
||||
type IsCore = Bool
|
||||
type TheState =
|
||||
( Set PackageName
|
||||
, DList (PackageName, Version, Map Text Bool, IsCore)
|
||||
)
|
||||
type DList a = [a] -> [a]
|
||||
|
||||
getDeps :: (MonadThrow m, MonadState TheState m)
|
||||
=> BuildPlan
|
||||
-> Bool
|
||||
-> Set Text
|
||||
-> m ()
|
||||
getDeps BuildPlan {..} fullDeps =
|
||||
mapM_ (goName . PackageName . unpack)
|
||||
where
|
||||
goName name = do
|
||||
(s, _) <- get
|
||||
when (name `notMember` s) $
|
||||
case lookup name bpPackages of
|
||||
Just pkg -> goPkg name pkg
|
||||
Nothing ->
|
||||
case lookup name $ siCorePackages bpSystemInfo of
|
||||
Just version -> do
|
||||
addToSet name
|
||||
addToList name version mempty True
|
||||
Nothing -> throwM $ PackageNotFound name
|
||||
|
||||
goPkg name PackagePlan {..} = do
|
||||
addToSet name
|
||||
forM_ (mapToList $ sdPackages ppDesc) $ \(name', depInfo) ->
|
||||
when (includeDep depInfo) (goName name')
|
||||
addToList name ppVersion
|
||||
(mapKeysWith const unFlagName
|
||||
$ pcFlagOverrides ppConstraints)
|
||||
False
|
||||
|
||||
addToSet name = modify $ \(s, front) -> (insertSet name s, front)
|
||||
|
||||
addToList name version flags isCore =
|
||||
modify $ \(s, front) -> (s, front . (x:))
|
||||
where
|
||||
x = (name, version, flags, isCore)
|
||||
|
||||
includeDep DepInfo {..} =
|
||||
fullDeps ||
|
||||
CompLibrary `member` diComponents ||
|
||||
CompExecutable `member` diComponents
|
||||
|
||||
data PackageNotFound = PackageNotFound PackageName
|
||||
deriving (Show, Typeable)
|
||||
instance Exception PackageNotFound
|
||||
spec <- parseSnapshotSpec $ toPathPiece slug
|
||||
let set = setShellCommands simpleCommands
|
||||
$ setSnapshot spec
|
||||
$ setFullDeps fullDeps
|
||||
defaultSettings
|
||||
packages <- lookupGetParams "package" >>= mapM simpleParse
|
||||
when (null packages) $ invalidArgs ["Must provide at least one package"]
|
||||
toInstall <- liftIO $ getBuildPlan set packages
|
||||
selectRep $ do
|
||||
provideRep $ return $ toSimpleText toInstall
|
||||
provideRep $ return $ toJSON toInstall
|
||||
provideRepType "application/x-sh" $ return $ toShellScript set toInstall
|
||||
|
||||
@ -169,6 +169,7 @@ library
|
||||
, deepseq-generics
|
||||
, auto-update
|
||||
, stackage-types
|
||||
, stackage-build-plan >= 0.1.1
|
||||
, yesod-sitemap
|
||||
, streaming-commons
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user