haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-22 08:51:55 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Add JSON build plan (which includes flags #91)

Browse Source
This commit is contained in:
Michael Snoyman 2015-04-22 11:53:59 +03:00
parent 1b4d149801
commit ddfce6e551
1 changed files with 18 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
Handler/BuildPlan.hs
View File

@ -11,7 +11,7 @@ import Stackage.Types
import Distribution.Package (PackageName (..)) import Distribution.Package (PackageName (..))
import Data.Version (Version) import Data.Version (Version)
getBuildPlanR :: SnapSlug -> Handler Text getBuildPlanR :: SnapSlug -> Handler TypedContent
getBuildPlanR slug = do getBuildPlanR slug = do
mlts <- runDB $ do mlts <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSnapshot slug Entity sid _ <- getBy404 $ UniqueSnapshot slug
@ -31,8 +31,10 @@ getBuildPlanR slug = do
let eres = runCatch $ execStateT (getDeps bp fullDeps packages) (mempty, id) let eres = runCatch $ execStateT (getDeps bp fullDeps packages) (mempty, id)
case eres of case eres of
Left e -> invalidArgs [tshow e] Left e -> invalidArgs [tshow e]
Right (_, front) -> return $ unlines $ flip map (front []) Right (_, front) -> selectRep $ do
$ \(x, y) -> unwords [display x, display y] provideRep $ return $ unlines $ flip map (front [])
$ \(x, y, _) -> unwords [display x, display y]
provideRep $ return $ toJSON $ map tupleToValue $ front []
type HttpM env m = type HttpM env m =
( MonadReader env m ( MonadReader env m
@ -72,9 +74,16 @@ download ltsVer dest = do
withResponse req $ \res -> liftIO $ F.withFile dest F.WriteMode $ \h -> withResponse req $ \res -> liftIO $ F.withFile dest F.WriteMode $ \h ->
responseBody res $$ sinkHandle h responseBody res $$ sinkHandle h
tupleToValue :: (PackageName, Version, Map Text Bool) -> Value
tupleToValue (name, version, flags) = object
[ "name" .= display name
, "version" .= display version
, "flags" .= flags
]
type TheState = type TheState =
( Set PackageName ( Set PackageName
, DList (PackageName, Version) , DList (PackageName, Version, Map Text Bool)
) )
type DList a = [a] -> [a] type DList a = [a] -> [a]
@ -95,7 +104,7 @@ getDeps BuildPlan {..} fullDeps =
case lookup name $ siCorePackages bpSystemInfo of case lookup name $ siCorePackages bpSystemInfo of
Just version -> do Just version -> do
addToSet name addToSet name
addToList name version addToList name version mempty
Nothing -> throwM $ PackageNotFound name Nothing -> throwM $ PackageNotFound name
goPkg name PackagePlan {..} = do goPkg name PackagePlan {..} = do
@ -103,13 +112,15 @@ getDeps BuildPlan {..} fullDeps =
forM_ (mapToList $ sdPackages ppDesc) $ \(name', depInfo) -> forM_ (mapToList $ sdPackages ppDesc) $ \(name', depInfo) ->
when (includeDep depInfo) (goName name') when (includeDep depInfo) (goName name')
addToList name ppVersion addToList name ppVersion
(mapKeysWith const unFlagName
$ pcFlagOverrides ppConstraints)
addToSet name = modify $ \(s, front) -> (insertSet name s, front) addToSet name = modify $ \(s, front) -> (insertSet name s, front)
addToList name version = addToList name version flags =
modify $ \(s, front) -> (s, front . (x:)) modify $ \(s, front) -> (s, front . (x:))
where where
x = (name, version) x = (name, version, flags)
includeDep DepInfo {..} = includeDep DepInfo {..} =
fullDeps || fullDeps ||