Add BuildPlanR

Application.hs

@@ -72,6 +72,7 @@ import           Handler.Hoogle
 import           Handler.BuildVersion
 import           Handler.PackageCounts
 import           Handler.Sitemap
+import           Handler.BuildPlan
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

Handler/Alias.hs

@@ -10,6 +10,7 @@ import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackage
 import Handler.StackageIndex (getStackageIndexR)
 import Handler.StackageSdist (getStackageSdistR)
 import Handler.Hoogle (getHoogleR)
+import Handler.BuildPlan (getBuildPlanR)
 
 handleAliasR :: Slug -> Slug -> [Text] -> Handler ()
 handleAliasR user name pieces = do
@@ -78,4 +79,5 @@ goSid sid pieces = do
                 SnapshotPackagesR -> getSnapshotPackagesR slug >>= sendResponse
                 DocsR -> getDocsR slug >>= sendResponse
                 HoogleR -> getHoogleR slug >>= sendResponse
+                BuildPlanR -> getBuildPlanR slug >>= sendResponse
         _ -> notFound

Handler/BuildPlan.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE ConstraintKinds #-}
+module Handler.BuildPlan where
+
+import Import hiding (get, PackageName (..), Version (..))
+import Data.Slug (SnapSlug)
+import qualified Filesystem as F
+import Data.Yaml (decodeFileEither)
+import Control.Monad.State.Strict (get, modify, execStateT, MonadState)
+import Control.Monad.Catch.Pure (runCatch)
+import Stackage.Types
+import Distribution.Package (PackageName (..))
+import Data.Version (Version)
+
+getBuildPlanR :: SnapSlug -> Handler Text
+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
+    packages <- 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) -> return $ unlines $ flip map (front [])
+            $ \(x, y) -> unwords [display x, display y]
+
+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 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
+
+type TheState =
+    ( Set PackageName
+    , DList (PackageName, Version)
+    )
+type DList a = [a] -> [a]
+
+getDeps :: (MonadThrow m, MonadState TheState m)
+        => BuildPlan
+        -> Bool
+        -> [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
+                        Nothing -> throwM $ PackageNotFound name
+
+    goPkg name PackagePlan {..} = do
+        addToSet name
+        forM_ (mapToList $ sdPackages ppDesc) $ \(name', depInfo) ->
+            when (includeDep depInfo) (goName name')
+        addToList name ppVersion
+
+    addToSet name = modify $ \(s, front) -> (insertSet name s, front)
+
+    addToList name version =
+        modify $ \(s, front) -> (s, front . (x:))
+      where
+        x = (name, version)
+
+    includeDep DepInfo {..} =
+        fullDeps ||
+        CompLibrary    `member` diComponents ||
+        CompExecutable `member` diComponents
+
+data PackageNotFound = PackageNotFound PackageName
+    deriving (Show, Typeable)
+instance Exception PackageNotFound

config/routes

@@ -26,6 +26,7 @@
     /packages SnapshotPackagesR GET
     /docs DocsR GET
     /hoogle HoogleR GET
+    /build-plan BuildPlanR GET
 
 /aliases AliasesR PUT
 /alias/#Slug/#Slug/*Texts AliasR

stackage-server.cabal

@@ -53,6 +53,7 @@ library
                      Handler.BuildVersion
                      Handler.PackageCounts
                      Handler.Sitemap
+                     Handler.BuildPlan
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT