diff --git a/Handler/BuildPlan.hs b/Handler/BuildPlan.hs index 1e2dbb0..de4acab 100644 --- a/Handler/BuildPlan.hs +++ b/Handler/BuildPlan.hs @@ -33,8 +33,43 @@ getBuildPlanR slug = do Left e -> invalidArgs [tshow e] Right (_, front) -> selectRep $ do provideRep $ return $ unlines $ flip map (front []) - $ \(x, y, _) -> unwords [display x, display y] + $ \(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 @@ -74,16 +109,18 @@ download ltsVer dest = do withResponse req $ \res -> liftIO $ F.withFile dest F.WriteMode $ \h -> responseBody res $$ sinkHandle h -tupleToValue :: (PackageName, Version, Map Text Bool) -> Value -tupleToValue (name, version, flags) = object +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) + , DList (PackageName, Version, Map Text Bool, IsCore) ) type DList a = [a] -> [a] @@ -104,7 +141,7 @@ getDeps BuildPlan {..} fullDeps = case lookup name $ siCorePackages bpSystemInfo of Just version -> do addToSet name - addToList name version mempty + addToList name version mempty True Nothing -> throwM $ PackageNotFound name goPkg name PackagePlan {..} = do @@ -114,13 +151,14 @@ getDeps BuildPlan {..} fullDeps = addToList name ppVersion (mapKeysWith const unFlagName $ pcFlagOverrides ppConstraints) + False addToSet name = modify $ \(s, front) -> (insertSet name s, front) - addToList name version flags = + addToList name version flags isCore = modify $ \(s, front) -> (s, front . (x:)) where - x = (name, version, flags) + x = (name, version, flags, isCore) includeDep DepInfo {..} = fullDeps ||