diff --git a/Application.hs b/Application.hs index 42c2e18..6341e8f 100644 --- a/Application.hs +++ b/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 diff --git a/Handler/Alias.hs b/Handler/Alias.hs index c47baf2..1aacdd2 100644 --- a/Handler/Alias.hs +++ b/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 diff --git a/Handler/BuildPlan.hs b/Handler/BuildPlan.hs new file mode 100644 index 0000000..477300f --- /dev/null +++ b/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 diff --git a/config/routes b/config/routes index a055031..ef493b5 100644 --- a/config/routes +++ b/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 diff --git a/stackage-server.cabal b/stackage-server.cabal index 6e48634..d61739b 100644 --- a/stackage-server.cabal +++ b/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