stackage-build-plan (empty) → 0.1.0.0
raw patch · 7 files changed
+580/−0 lines, 7 filesdep +Cabaldep +aesondep +basesetup-changed
Dependencies added: Cabal, aeson, base, bytestring, containers, directory, exceptions, filepath, http-client, http-client-tls, mtl, optparse-applicative, stackage-build-plan, stackage-cli, stackage-types, text, time, yaml
Files
- ChangeLog.md +3/−0
- LICENSE +22/−0
- README.md +18/−0
- Setup.hs +2/−0
- Stackage/BuildPlan.hs +406/−0
- app/stackage-build-plan.hs +80/−0
- stackage-build-plan.cabal +49/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2015 FP Complete++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ README.md view
@@ -0,0 +1,18 @@+# stackage-build-plan++[](https://travis-ci.org/fpco/stackage-build-plan)++Calculate and print (in different formats) Stackage build plans. This includes+generating bootstrap shell scripts, such as needed by cabal-install. In fact,+that use case is [the primary+motivation](https://github.com/fpco/stackage-server/issues/95) for releasing+this code as its own package.++## Why Stackage?++This package takes advantage of the Stackage Nightly and LTS Haskell snapshots+to calculate known-good build plans to display to users.++## Future enhancements++None planned
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Stackage/BuildPlan.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Stackage.BuildPlan+ ( Settings+ , SnapshotSpec+ , parseSnapshotSpec+ , defaultSettings+ , setMirror+ , setSnapshot+ , ShellCommands+ , setShellCommands+ , abstractCommands+ , simpleCommands+ , getBuildPlan+ , toSimpleText+ , toShellScript+ , mkPackageName+ ) where++import Control.Applicative ((<|>))+import qualified Control.Exception as E+import Control.Monad (forM_, unless, when)+import Control.Monad.Catch (Exception, MonadThrow, throwM)+import Control.Monad.State.Strict (MonadState, execStateT, get,+ modify)+import Control.Monad.Writer.Strict (execWriter, tell)+import Data.Aeson (object, (.=))+import qualified Data.Aeson as A+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Foldable (Foldable)+import qualified Data.Foldable as F+import Data.Function (fix)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid ((<>))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Data.Time (Day)+import Data.Typeable (Typeable)+import Data.Version (Version)+import Data.Yaml (decodeFileEither)+import Distribution.Package (PackageName)+import Network.HTTP.Client (Manager, brRead, httpLbs,+ newManager, parseUrl,+ responseBody, withResponse)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Stackage.Types (BuildPlan (..), Component (..),+ DepInfo (..),+ PackageConstraints (..),+ PackagePlan (..), SystemInfo (..),+ display, mkPackageName,+ sdPackages, unFlagName)+import System.Directory (createDirectoryIfMissing,+ doesFileExist,+ getAppUserDataDirectory,+ renameFile)+import System.FilePath ((<.>), (</>))+import System.IO (IOMode (WriteMode),+ withBinaryFile)+import Text.Read (readMaybe)++catchIO :: IO a -> (E.IOException -> IO a) -> IO a+catchIO = E.catch++-- | Parse a snapshot specification from the given @Text@.+--+-- Since 0.1.0.0+parseSnapshotSpec :: MonadThrow m => Text -> m SnapshotSpec+parseSnapshotSpec "lts" = return $ IncompleteSpec LTSNewest+parseSnapshotSpec "nightly" = return $ IncompleteSpec NightlyNewest+parseSnapshotSpec s+ | Just t <- T.stripPrefix "nightly-" s+ , Just d <- readMaybe $ T.unpack t = return $ CompleteSpec $ Nightly d+parseSnapshotSpec s+ | Just t <- T.stripPrefix "lts-" s+ , Just x <- go t = return x+ where+ go t1 = do+ Right (x, t2) <- Just $ decimal t1+ if T.null t2+ then return $ IncompleteSpec $ LTSMajor x+ else do+ t3 <- T.stripPrefix "." t2+ Right (y, "") <- Just $ decimal t3+ return $ CompleteSpec $ LTS x y+parseSnapshotSpec s = throwM $ InvalidSnapshotSpec s++data CompleteSpec+ = Nightly !Day+ | LTS !Int !Int+instance Show CompleteSpec where+ show (Nightly d) = "nightly-" ++ show d+ show (LTS x y) = concat ["lts-", show x, ".", show y]+data IncompleteSpec+ = LTSMajor !Int+ | LTSNewest+ | NightlyNewest+ deriving Show+data SnapshotSpec+ = CompleteSpec !CompleteSpec+ | IncompleteSpec !IncompleteSpec+ deriving Show++resolveSpec :: Manager -> SnapshotSpec -> IO CompleteSpec+resolveSpec _ (CompleteSpec x) = return x+resolveSpec man (IncompleteSpec spec) = do+ res <- httpLbs "https://www.stackage.org/download/lts-snapshots.json" man+ let lbs = responseBody res+ m <-+ case A.eitherDecode' lbs of+ Left e -> throwM $ InvalidSnapshotsJson lbs e+ Right m -> return m+ case Map.lookup key m of+ Nothing -> throwM $ SpecNotResolved key m+ Just val -> parseCompleteSpec val+ where+ key =+ case spec of+ LTSMajor m -> T.pack $ "lts-" ++ show m+ LTSNewest -> "lts"+ NightlyNewest -> "nightly"++parseCompleteSpec :: MonadThrow m => Text -> m CompleteSpec+parseCompleteSpec t =+ maybe (throwM $ InvalidSpec t) return $+ parseNightly <|> parseLts+ where+ parseNightly = do+ d <- T.stripPrefix "nightly-" t+ x <- readMaybe $ T.unpack d+ Just $ Nightly x+ parseLts = do+ t1 <- T.stripPrefix "lts-" t+ Right (x, t2) <- Just $ decimal t1+ t3 <- T.stripPrefix "." t2+ Right (y, "") <- Just $ decimal t3+ Just $ LTS x y++data BuildPlanException+ = InvalidSnapshotsJson !L.ByteString !String+ | SpecNotResolved !Text !(Map Text Text)+ | InvalidSpec !Text+ | PackageNotFound !PackageName+ | InvalidSnapshotSpec !Text+ deriving (Show, Typeable)+instance Exception BuildPlanException++-- | Settings affecting various functions in this module.+--+-- Since 0.1.0.0+data Settings = Settings+ { _snapshot :: !SnapshotSpec+ , _getManager :: !(IO Manager)+ , _fullDeps :: !Bool+ -- ^ include test and benchmark deps+ , _mirror :: !Text+ , _shellCmds :: !ShellCommands+ }++-- | How to generate commands for shell output.+--+-- Since 0.1.0.0+data ShellCommands = ShellCommands+ { scFetch :: Text -> Text+ -- ^ URL+ , scUnpack :: Text -> Text+ -- ^ Tarball+ , scBuild :: Map Text Bool -> Text+ -- ^ Flags+ }++-- | Use abstract commands like build_plan_fetch.+--+-- See: https://github.com/fpco/stackage-server/issues/95#issuecomment-97146188+--+-- Since 0.1.0.0+abstractCommands :: ShellCommands+abstractCommands = ShellCommands+ { scFetch = ("build_plan_fetch " <>)+ , scUnpack = ("build_plan_unpack " <>)+ , scBuild = ("build_plan_build " <>) . showFlags+ }++-- | Use simple commands requiring no wrapper shell script+--+-- Since 0.1.0.0+simpleCommands :: ShellCommands+simpleCommands = ShellCommands+ { scFetch = ("wget " <>)+ , scUnpack = ("tar xf " <>)+ , scBuild = \flags -> T.concat+ [ T.concat+ [ "runghc Setup configure --user --flags='"+ , showFlags flags+ , "'"+ ]+ , "\nrunghc Setup build"+ , "\nrunghc Setup copy"+ , "\nrunghc Setup register"+ ]+ }++showFlags :: Map Text Bool -> Text+showFlags =+ T.unwords . map go . Map.toList+ where+ go (name, isOn) = (if isOn then id else (T.cons '-')) name+++-- | Set the shell commands when using shell formatting.+--+-- Default: 'abstractCommands'+--+-- Since 0.1.0.0+setShellCommands :: ShellCommands -> Settings -> Settings+setShellCommands x s = s { _shellCmds = x }++-- | Default settings, to be tweaked via setter functions.+--+-- Since 0.1.0.0+defaultSettings :: Settings+defaultSettings = Settings+ { _snapshot = IncompleteSpec LTSNewest+ , _getManager = newManager tlsManagerSettings+ , _fullDeps = False+ , _mirror = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"+ , _shellCmds = abstractCommands+ }++-- | Set the snapshot from which to pull the build plan.+--+-- Default: latest LTS release+--+-- Since 0.1.0.0+setSnapshot :: SnapshotSpec -> Settings -> Settings+setSnapshot x s = s { _snapshot = x }++-- | Set the mirror prefix for tarball downloads (shell script only).+--+-- Default: "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"+--+-- Since 0.1.0.0+setMirror :: Text -> Settings -> Settings+setMirror x s = s { _mirror = x }++yamlFP :: Manager -> SnapshotSpec -> IO FilePath+yamlFP man spec' = do+ spec <- resolveSpec man spec'+ root <- getAppUserDataDirectory "stackage"+ `catchIO` \_ -> return "/tmp/.stackage" -- server does not set HOME+ let dir = root </> "build-plan"+ fp = dir </> show spec <.> "yaml"+ exists <- doesFileExist fp+ if exists+ then return fp+ else do+ createDirectoryIfMissing True dir+ let tmp = fp <.> "tmp"+ download man spec tmp+ renameFile tmp fp+ return fp++download :: Manager -> CompleteSpec -> FilePath -> IO ()+download man spec dest = do+ req <- parseUrl $ specUrl spec+ withResponse req man $ \res -> withBinaryFile dest WriteMode $ \h ->+ fix $ \loop -> do+ bs <- brRead $ responseBody res+ unless (S.null bs) $ S.hPut h bs >> loop++specUrl :: CompleteSpec -> String+specUrl (LTS x y) = concat+ [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-"+ , show x+ , "."+ , show y+ , ".yaml"+ ]+specUrl (Nightly x) = concat+ [ "https://raw.githubusercontent.com/fpco/stackage-nightly/master/nightly-"+ , show x+ , ".yaml"+ ]++data ToInstall = ToInstall+ { tiPackage :: !PackageName+ , tiVersion :: !Version+ , tiIsCore :: !Bool+ , tiFlags :: !(Map Text Bool)+ }+ deriving Show++instance A.ToJSON ToInstall where+ toJSON ti = object+ [ "name" .= display (tiPackage ti)+ , "version" .= display (tiVersion ti)+ , "flags" .= tiFlags ti+ , "is-core" .= tiIsCore ti+ ]++getBuildPlan :: Settings -> [PackageName] -> IO [ToInstall]+getBuildPlan _ [] = return []+getBuildPlan set packages = do+ man <- _getManager set+ fp <- yamlFP man $ _snapshot set+ bp <- decodeFileEither fp >>= either throwM return+ (_, front) <- execStateT (getDeps bp (_fullDeps set) packages) (Set.empty, id)+ return $ front []++type TheState =+ ( Set PackageName+ , DList ToInstall+ )+type DList a = [a] -> [a]++getDeps :: forall f m. (MonadThrow m, MonadState TheState m, Foldable f)+ => BuildPlan+ -> Bool+ -> f PackageName+ -> m ()+getDeps bp fullDeps =+ F.mapM_ goName+ where+ goName :: PackageName -> m ()+ goName name = do+ (s, _) <- get+ when (name `Set.notMember` s) $+ case Map.lookup name $ bpPackages bp of+ Just pkg -> goPkg name pkg+ Nothing ->+ case Map.lookup name $ siCorePackages $ bpSystemInfo bp of+ Just version -> do+ addToSet name+ addToList name version Map.empty True+ Nothing -> throwM $ PackageNotFound name++ goPkg :: PackageName -> PackagePlan -> m ()+ goPkg name pp = do+ addToSet name+ forM_ (Map.toList $ sdPackages $ ppDesc pp) $ \(name', depInfo) ->+ when (includeDep depInfo) (goName name')+ addToList name (ppVersion pp)+ (Map.mapKeysWith const unFlagName+ $ pcFlagOverrides $ ppConstraints pp)+ False++ addToSet name = modify $ \(s, front) -> (Set.insert name s, front)++ addToList name version flags isCore =+ modify $ \(s, front) -> (s, front . (x:))+ where+ x = ToInstall+ { tiPackage = name+ , tiVersion = version+ , tiFlags = flags+ , tiIsCore = isCore+ }++ includeDep di =+ fullDeps ||+ CompLibrary `Set.member` diComponents di ||+ CompExecutable `Set.member` diComponents di++toSimpleText :: [ToInstall] -> Text+toSimpleText =+ T.unlines . map go+ where+ go ti = T.unwords+ [ display $ tiPackage ti+ , display $ tiVersion ti+ ]++toShellScript :: Settings -> [ToInstall] -> Text+toShellScript set packages = T.unlines $ ($ []) $ execWriter $ do+ yield "#!/usr/bin/env bash\nset -eux\n"+ forM_ packages $ \ti -> unless (tiIsCore ti) $ do+ let prefix = T.concat+ [ display $ tiPackage ti+ , "-"+ , display $ tiVersion ti+ ]+ tarball = prefix <> ".tar.gz"+ mapM_ yield+ [ ""+ , T.concat+ [ "rm -rf "+ , prefix+ , " "+ , tarball+ ]+ , scFetch sc $ _mirror set <> tarball+ , scUnpack sc tarball+ , "cd " <> prefix+ , scBuild sc $ tiFlags ti+ , "cd .."+ ]+ where+ yield x = tell (x:)+ sc = _shellCmds set
+ app/stackage-build-plan.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+import Data.Aeson (toJSON)+import Data.Aeson.Encode (encodeToTextBuilder)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Lazy.IO as TLIO+import Options.Applicative+import Paths_stackage_build_plan (version)+import Stackage.BuildPlan+import Stackage.CLI (simpleOptions, simpleVersion)++main :: IO ()+main = do+ ((set, render, packages), ()) <- simpleOptions+ $(simpleVersion version)+ "Calculate and print (in different formats) Stackage build plans"+ "Calculate and print (in different formats) Stackage build plans"+ options+ empty+ tis <- getBuildPlan set $ map (mkPackageName . T.pack) packages+ TLIO.putStr $ render set tis+ where+ options = (,,)+ <$> setOptions+ <*> renderOptions+ <*> some (argument str (metavar "PACKAGES..."))++ mkSettings mmirror msnapshot mcommands =+ maybe id (setMirror . T.pack) mmirror+ $ maybe id setSnapshot msnapshot+ $ maybe id setShellCommands mcommands+ $ defaultSettings++ setOptions = mkSettings+ <$> ((fmap Just $ strOption+ ( long "mirror"+ <> help "Mirror to download packages from"+ <> metavar "URL"+ )) <|> pure Nothing)+ <*> ((fmap Just $ option readSnapshot+ ( long "snapshot"+ <> help "Which snapshot to pull the build plan from"+ <> metavar "SNAPSHOT"+ )) <|> pure Nothing)+ <*> ((fmap Just $ option readCommands+ ( long "commands"+ <> help "Shell commands do use: abstract, simple"+ <> metavar "COMMANDS"+ )) <|> pure Nothing)++ readSnapshot =+ str >>=+ either (fail . show) return . parseSnapshotSpec . T.pack++ readCommands = do+ s <- str+ case s of+ "abstract" -> return abstractCommands+ "simple" -> return simpleCommands+ _ -> fail $ "Invalid commands: " ++ s++ renderOptions =+ (option readRender+ ( long "format"+ <> help "Output format: shell, simple, json"+ <> metavar "FORMAT"+ ))++ readRender = do+ x <- str+ case x of+ "shell" -> return $ \set tis ->+ TL.fromStrict $ toShellScript set tis+ "simple" -> return $ \_set tis ->+ TL.fromStrict $ toSimpleText tis+ "json" -> return $ \_set tis ->+ toLazyText $ encodeToTextBuilder $ toJSON tis+ _ -> fail $ "Invalid renderer: " ++ x
+ stackage-build-plan.cabal view
@@ -0,0 +1,49 @@+name: stackage-build-plan+version: 0.1.0.0+synopsis: Calculate and print (in different formats) Stackage build plans+description: For more information, see <https://www.stackage.org/package/stackage-build-plan>+homepage: https://github.com/fpco/stackage-build-plan+license: MIT+license-file: LICENSE+author: Michael Snoyman+maintainer: michael@snoyman.com+category: Distribution+build-type: Simple+extra-source-files: ChangeLog.md, README.md+cabal-version: >=1.10++library+ exposed-modules: Stackage.BuildPlan+ build-depends: base >= 4.5 && < 5+ , bytestring >= 0.9+ , text >= 0.11+ , http-client >= 0.4+ , http-client-tls >= 0.2+ , directory >= 1.1+ , filepath >= 1.2+ , containers+ , yaml+ , time+ , stackage-types+ , Cabal+ , aeson+ , mtl+ , exceptions+ default-language: Haskell2010++executable stackage-build-plan+ main-is: stackage-build-plan.hs+ other-modules: Paths_stackage_build_plan+ hs-source-dirs: app+ build-depends: base+ , stackage-build-plan + , stackage-cli+ , optparse-applicative+ , text+ , aeson+ default-language: Haskell2010+ other-extensions: TemplateHaskell++source-repository head+ type: git+ location: git://github.com/fpco/stackage-build-plan.git