get-deep-deps.hs

{-# LANGUAGE RecordWildCards     #-}
import           Control.Exception
import           Control.Monad                    (forM_, when, unless)
import           Control.Monad.Trans.State.Strict
import qualified Data.ByteString                  as S
import qualified Data.Map                         as Map
import qualified Data.Set                         as Set
import           Data.Monoid
import qualified Data.Set                         as Set
import qualified Data.Text.IO                     as TIO
import           Data.Yaml (decodeFileEither)
import           Distribution.Package
import           Network.HTTP.Client
import           Network.HTTP.Client.TLS
import           Stackage.Types
import           System.Environment
import System.Directory
import System.FilePath
import System.IO
import Options.Applicative
import qualified Data.Text as T

ltsFP :: String -> IO FilePath
ltsFP ltsVer = do
    dir <- getAppUserDataDirectory "stackage-bootstrap"
    let fp = dir </> ("lts-" ++ ltsVer) <.> "yaml"
    exists <- doesFileExist fp
    if exists
        then return fp
        else do
            createDirectoryIfMissing True dir
            let tmp = fp <.> "tmp"
            download ltsVer tmp
            renameFile tmp fp
            return fp

download :: String -> FilePath -> IO ()
download ltsVer dest = do
    req <- parseUrl $ concat
        [ "https://raw.githubusercontent.com/fpco/lts-haskell/master/lts-"
        , ltsVer
        , ".yaml"
        ]
    manager <- newManager tlsManagerSettings
    withResponse req manager $ \res -> withBinaryFile dest WriteMode $ \h -> do
        let loop = do
                bs <- brRead $ responseBody res
                unless (S.null bs) $ do
                    S.hPut h bs
                    loop
        loop

data Opts = Opts
    { ltsVer :: String
    , packages :: [String]
    , fullDeps :: Bool
    }

optsParser :: Parser Opts
optsParser = Opts
    <$> argument str
         ( metavar "LTS-VERSION"
        <> help "LTS version number, e.g. 1.14"
         )
    <*> some (argument str
         ( metavar "PACKAGE-NAME[, PACKAGE-NAME...]"
        <> help "Packages to track dependencies for, e.g. exceptions"
         ))
    <*> switch
         ( long "full-deps"
        <> help "Including test suite and benchmark dependencies"
         )

getOpts :: IO Opts
getOpts =
    execParser opts
  where
    opts = info (helper <*> optsParser)
        ( fullDesc
       <> progDesc "Find dependencies necessary for for a given package and generate bootstrap scripts"
       <> header "stackage-bootstrap - package deps in LTS Haskell"
        )

main :: IO ()
main = do
    opts <- getOpts
    bp <- ltsFP (ltsVer opts) >>= decodeFileEither >>= either throwIO return
    (_, front) <- execStateT
        (getDeps bp (fullDeps opts) (packages opts))
        (Set.empty, id)
    putStrLn "#!/bin/bash"
    putStrLn "set -ex"
    forM_ (front []) $ \(pkg, flagOverrides) -> putStrLn $ unlines $ do
        let prefix = T.unpack $ display pkg
            tarball = prefix ++ ".tar.gz"
         in
            [ concat
                [ "rm -rf "
                , prefix
                , " "
                , tarball
                ]
            , "wget http://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 .."
            ]

showFlags =
    unwords . map go . Map.toList
  where
    go (name, isOn) =
        (if isOn then id else ('-':)) (T.unpack $ unFlagName name)

getDeps BuildPlan {..} fullDeps =
    mapM_ (goName . PackageName)
  where
    goName name = do
        (s, _) <- get
        when (name `Set.notMember` s) $
            case Map.lookup name bpPackages of
                Just pkg -> goPkg name pkg
                Nothing ->
                    case Map.lookup name $ siCorePackages bpSystemInfo of
                        Just _ -> addToSet name
                        Nothing -> error $ "Package not found: " ++ show name

    goPkg name PackagePlan {..} = do
        addToSet name
        forM_ (Map.toList $ sdPackages ppDesc) $ \(name', depInfo) ->
            when (includeDep depInfo) (goName name')
        let x =
                ( PackageIdentifier name ppVersion
                , pcFlagOverrides ppConstraints
                )
        modify $ \(s, front) -> (s, front . (x:))

    addToSet name = modify $ \(s, front) -> (Set.insert name s, front)

    includeDep DepInfo {..} =
        fullDeps ||
        CompLibrary    `Set.member` diComponents ||
        CompExecutable `Set.member` diComponents