packages feed

stackage-cli (empty) → 0.0.0

raw patch · 12 files changed

+1268/−0 lines, 12 filesdep +basedep +bytestringdep +conduitsetup-changed

Dependencies added: base, bytestring, conduit, directory, either, exceptions, filepath, hashable, http-client, http-types, optparse-applicative, optparse-simple, parsec, process, split, stackage-cli, system-fileio, system-filepath, text, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 FP Complete, http://www.fpcomplete.com/++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ main/Init.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Filesystem+import Control.Applicative+import Control.Monad+import Stackage.CLI+import Options.Applicative (Parser)+import Options.Applicative.Builder (strArgument, metavar, value)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Typeable (Typeable)+import Network.HTTP.Client+import Network.HTTP.Types.Status (statusCode)+import Network.HTTP.Types.Header (hUserAgent)+import qualified Data.ByteString.Lazy as LBS+import System.Exit (exitFailure)+import System.Environment (getArgs)+import System.IO (hPutStrLn, stderr)+import Control.Exception+import qualified Paths_stackage_cli as CabalInfo++type Snapshot = String++data InitException+  = InvalidSnapshot+  | SnapshotNotFound+  | UnexpectedHttpException HttpException+  | CabalConfigExists+  deriving (Show, Typeable)+instance Exception InitException++version :: String+version = $(simpleVersion CabalInfo.version)++header :: String+header = "Initializes cabal.config"++progDesc :: String+progDesc = header++userAgent :: Text+userAgent = "stackage-init/" <> T.pack version++snapshotParser :: Parser Snapshot+snapshotParser = strArgument mods where+  mods = (metavar "SNAPSHOT" <> value "lts")++toUrl :: Snapshot -> String+toUrl t = "http://stackage.org/" <> t <> "/cabal.config"++snapshotReq :: Snapshot -> IO Request+snapshotReq snapshot = case parseUrl (toUrl snapshot) of+  Left _ -> throwIO $ InvalidSnapshot+  Right req -> return req+    { requestHeaders = [(hUserAgent, T.encodeUtf8 userAgent)]+    }++downloadSnapshot :: Snapshot -> IO LBS.ByteString+downloadSnapshot snapshot = withManager defaultManagerSettings $ \manager -> do+  let getResponseLbs req = do+        response <- httpLbs req manager+        return $ responseBody response+  let handle404 firstTry (StatusCodeException s _ _)+        | statusCode s == 404 = if firstTry+          then do+            req <- snapshotReq $ "snapshot/" <> snapshot+            getResponseLbs req `catch` handle404 False+          else do+            throwIO $ SnapshotNotFound+      handle404 _ e = throwIO $ UnexpectedHttpException e+  req <- snapshotReq snapshot+  getResponseLbs req `catch` handle404 True++initSnapshot :: Snapshot -> IO ()+initSnapshot snapshot = do+  configExists <- isFile "cabal.config"+  when configExists $ throwIO $ CabalConfigExists+  downloadSnapshot snapshot >>= LBS.writeFile "cabal.config"++handleInitExceptions :: Snapshot -> InitException -> IO ()+handleInitExceptions snapshot e = hPutStrLn stderr (err e) >> exitFailure where+  err InvalidSnapshot+    = "Invalid snapshot: " <> snapshot+  err SnapshotNotFound+    = "Snapshot not found: " <> snapshot+  err CabalConfigExists+    = "Warning: Cabal config already exists.\n"+   <> "No action taken."+  err (UnexpectedHttpException e)+    = "Unexpected http exception:\n"+   <> show e++main = do+  (snapshot, ()) <- simpleOptions+    version+    header+    progDesc+    snapshotParser -- global parser+    empty          -- subcommands+  initSnapshot snapshot `catch` handleInitExceptions snapshot
+ main/Main.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import           Control.Applicative+import           Control.Exception (catch)+import           Control.Monad+import           Data.Maybe (isJust)+import           Data.List as List+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Stackage.CLI+import           System.Environment+import           System.IO (hPutStr, stderr)+import           System.Exit+import qualified Paths_stackage_cli as CabalInfo++onPluginErr :: PluginException -> IO ()+onPluginErr (PluginNotFound _ name) = do+  hPutStr stderr $ "Stackage plugin unavailable: " ++ T.unpack name+  exitFailure+onPluginErr (PluginExitFailure _ i) = do+  exitWith (ExitFailure i)++version :: String+version = $(simpleVersion CabalInfo.version)++main :: IO ()+main = do+  stackage <- findPlugins "stackage"+  args <- getArgs+  case dropWhile (List.isPrefixOf "-") args of+    ((T.pack -> name):args')+      | isJust (lookupPlugin stackage name) ->+          callPlugin stackage name args' `catch` onPluginErr+    _ -> do+      simpleOptions+        version+        "Run stackage commands"+        "Run stackage commands"+        (pure ())+        (commandsFromPlugins stackage)+      return ()
+ main/Purge.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Data.Maybe (listToMaybe, mapMaybe)+import Stackage.CLI+import Filesystem+import Control.Exception (Exception, catch)+import Control.Monad+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Applicative+import Data.Monoid+import Data.Typeable (Typeable)+import Options.Applicative (Parser, flag, long, help)+import System.Process (readProcess)+import Data.Char (toLower)+import System.IO (stdout, stderr, hFlush, hPutStrLn)+import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import System.Environment (getArgs)+import System.Exit (exitFailure)+import qualified Paths_stackage_cli as CabalInfo++import Text.Parsec hiding ((<|>), many)+type ParsecParser = Parsec String ()++data Force = Prompt | Force+data PurgeOpts = PurgeOpts+  { purgeOptsForce :: Force }++data PackageGroup = PackageGroup+  { packageGroupDb :: String+  , packageGroupPackages :: [String]+  }++data PurgeException+  = ParsePackagesError ParseError+  deriving (Show, Typeable)+instance Exception PurgeException++prompt :: String -> IO String+prompt str = putStr str >> hFlush stdout >> getLine++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust (Just a) f = f a+whenJust Nothing _ = return ()++pluralize :: Int -> a -> a -> a+pluralize 1 a _ = a+pluralize _ _ a = a++unregisterPackages :: String -> [String] -> IO ()+unregisterPackages packageDb = mapM_ unregister where+  unregister package = do+    putStrLn $ "Unregistering: " <> package+    _ <- readProcess "ghc-pkg" (args package) ""+    return ()+  args package =+    [ "unregister"+    , package+    , "--force"+    ] <> dbToArgs (Just packageDb)++parsePackageDb :: IO (Maybe String)+parsePackageDb = do+  cabalSandboxConfigExists <- isFile "cabal.sandbox.config"+  if cabalSandboxConfigExists+    then do+      t <- Filesystem.readTextFile "cabal.sandbox.config"+      let packageDbLine = T.stripPrefix "package-db: "+      return $ fmap T.unpack $ listToMaybe $ mapMaybe packageDbLine $ T.lines t+    else+      return Nothing++dbToArgs :: Maybe String -> [String]+dbToArgs Nothing = []+dbToArgs (Just packageDb) =+  [ "--package-db"+  , packageDb+  ]++getGlobalPackageDb :: IO (Maybe String)+getGlobalPackageDb = do+  let fakePackage = "asdklfjasdklfajsdlkghaiwojgadjfkq"+  output <- readProcess "ghc-pkg" ["list", fakePackage] ""+  return $ fmap init $ listToMaybe (lines output)+  -- fmap init is to get rid of the trailing colon++getPackages :: Maybe String -> IO [PackageGroup]+getPackages mPackageDb = parsePackages =<< readProcess "ghc-pkg" args "" where+  args = ["list"] <> dbToArgs mPackageDb++parsePackages :: MonadThrow m => String -> m [PackageGroup]+parsePackages+  = either (throwM . ParsePackagesError) return+  . parse packagesParser ""++ending :: ParsecParser ()+ending = eof <|> void endOfLine++packagesParser :: ParsecParser [PackageGroup]+packagesParser = many1 parseGroup++parseGroup :: ParsecParser PackageGroup+parseGroup = PackageGroup <$> parseDb <*> parseDbPackages <* many endOfLine++parseDb :: ParsecParser String+parseDb = manyTill anyChar $ try (char ':' *> ending)++parseDbPackages :: ParsecParser [String]+parseDbPackages = try parseNoPackages <|> many1 parsePackage++parseNoPackages :: ParsecParser [String]+parseNoPackages = many1 (char ' ') *> string "(no packages)" *> ending *> pure []++parsePackage :: ParsecParser String+parsePackage = many1 (char ' ') *> manyTill anyChar ending+++purge :: PurgeOpts -> IO ()+purge opts = do+  cabalConfigExists <- isFile "cabal.config"+  when cabalConfigExists $ do+    removeFile "cabal.config"++  globalPackageDbMay <- getGlobalPackageDb+  sandboxPackageDbMay <- parsePackageDb++  let displaySandbox s+        | Just s == globalPackageDbMay =+          "(Global) " <> s+        | Just s == sandboxPackageDbMay =+          "(Sandbox) " <> s+        | otherwise = s++  packages <- getPackages sandboxPackageDbMay+  forM_ packages $ \(PackageGroup db packages) -> do+    putStrLn $ displaySandbox db+    let nPackages = length packages+    let showNPackages+           = show nPackages+          <> " "+          <> pluralize nPackages "package" "packages"++    putStrLn+      $ "Detected "+     <> showNPackages+     <> " to purge from this database"++    when (nPackages > 0) $ do+      when (nPackages < 15) $ mapM_ putStrLn packages+      shouldUnregister <- case purgeOptsForce opts of+        Force -> do+          putStrLn $ "(--force) Unregistering " <> showNPackages+          return True+        Prompt -> do+          line <- prompt+            $ "Unregister " <> showNPackages <> " (y/n)? [default: n] "+          case map toLower line of+            "y"   -> return True+            "yes" -> return True+            _   -> return False+      when shouldUnregister $ unregisterPackages db packages+  return ()++purgeOptsParser :: Parser PurgeOpts+purgeOptsParser = PurgeOpts <$> forceOpt where+  forceOpt = flag Prompt Force mods+  mods = long "force"+      <> help "Purge all packages without prompt"++version :: String+version = $(simpleVersion CabalInfo.version)++header :: String+header = "Delete cabal.config and purge your package database"++progDesc :: String+progDesc = header++handlePurgeExceptions :: PurgeException -> IO ()+handlePurgeExceptions (ParsePackagesError _) = do+  hPutStrLn stderr $ "Failed to parse ghc-pkg output"+  exitFailure++main :: IO ()+main = do+  (opts, ()) <- simpleOptions+    version+    header+    progDesc+    purgeOptsParser -- global parser+    empty           -- subcommands+  purge opts `catch` handlePurgeExceptions
+ main/Sandbox.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Exception (Exception, bracket_, catch, throwIO)+import Control.Monad (when)+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Typeable (Typeable)+import Filesystem.Path.CurrentOS as Path+import Filesystem+import Options.Applicative hiding (header, progDesc)+import Stackage.CLI+import System.Environment (lookupEnv)+import System.Exit+import System.FilePath (addTrailingPathSeparator)+import System.IO (hPutStrLn, stderr)+import System.IO.Error (isDoesNotExistError)+import System.Process (callProcess, readProcess)+import qualified Paths_stackage_cli as CabalInfo++type Snapshot = Text+type Package = Text+data Action+  = Init (Maybe Snapshot)+  | PackageDb+  | List (Maybe Package)+  | Unregister Package+  | Delete (Maybe Snapshot)+  | Upgrade (Maybe Snapshot)++data SandboxException+  = NoHomeEnvironmentVariable+  | AlreadyAtSnapshot+  | PackageDbLocMismatch Text Text+  | MissingConfig Bool Bool+  | SnapshotMismatch Text Text+  | NonStackageCabalConfig+  | EmptyCabalConfig+  | DecodePathFail Text+  | ConfigAlreadyExists+  | InvalidSnapshot Snapshot+  | GhcVersionFail+  | PackageDbNotFound+  deriving (Show, Typeable)+instance Exception SandboxException++mSnapshotToArgs :: Maybe Snapshot -> [String]+mSnapshotToArgs = fmap T.unpack . maybeToList++version :: String+version = $(simpleVersion CabalInfo.version)++header :: String+header = "Manages shared stackage sandboxes"++progDesc :: String+progDesc = header++snapshotParser :: Parser Snapshot+snapshotParser = T.pack <$> strArgument mods where+  mods = metavar "SNAPSHOT"++packageParser :: Parser Package+packageParser = T.pack <$> strArgument mods where+  mods = metavar "PACKAGE"++packageDbDesc :: String+packageDbDesc = "Prints '--package-db $db', or prints nothing"++listDesc :: String+listDesc = "Calls `ghc-pkg list` with the sandbox package-db"++unregisterDesc :: String+unregisterDesc = "Calls `ghc-pkg unregister PACKAGE with the sandbox package-db"++deleteDesc :: String+deleteDesc = "Deletes cabal.config and cabal.sandbox.config. "+  <> "If provided with a SNAPSHOT, instead deletes that snapshot's folder."++upgradeDesc :: String+upgradeDesc = "Upgrade to the given SNAPSHOT. Defaults to the latest LTS."++subcommands = do+  addCommand "init" "Init" Init (optional snapshotParser)+  addCommand "package-db" packageDbDesc (const PackageDb) (pure ())+  addCommand "list" listDesc List (optional packageParser)+  addCommand "unregister" unregisterDesc Unregister packageParser+  addCommand "delete" deleteDesc Delete (optional snapshotParser)+  addCommand "upgrade" upgradeDesc Upgrade (optional snapshotParser)++toText' :: Path.FilePath -> IO Text+toText' p = case toText p of+  Left e -> throwIO $ DecodePathFail e+  Right t -> return t++cabalSandboxInit :: Path.FilePath -> IO ()+cabalSandboxInit dir = do+  dirText <- toText' dir+  let args =+        [ "sandbox"+        , "init"+        , "--sandbox"+        , T.unpack dirText+        ]+  callProcess "cabal" args++-- precondition: cabal.config exists+parseConfigSnapshot :: IO Snapshot+parseConfigSnapshot = do+  ls <- T.lines <$> T.readFile "cabal.config"+  let p = "-- Stackage snapshot from: http://www.stackage.org/snapshot/"+  case ls of+    (l:_) -> case T.stripPrefix p l of+      Just snapshot -> return snapshot+      Nothing -> throwIO NonStackageCabalConfig+    _ -> throwIO EmptyCabalConfig++-- TODO: a stricter check?+snapshotEq :: Snapshot -> Snapshot -> Bool+snapshotEq short full = T.isPrefixOf (T.replace "/" "-" short) full++-- TODO: verify things about the packages in the sandbox+sandboxVerify :: IO ()+sandboxVerify = do+  cabalConfigExists <- isFile "cabal.config"+  cabalSandboxConfigExists <- isFile "cabal.sandbox.config"+  if (cabalConfigExists && cabalSandboxConfigExists)+    then do+      packageDb <- getPackageDb+      snapshot <- parseConfigSnapshot+      snapshotDir <- getSnapshotDir snapshot+      snapshotDirText <- toText' snapshotDir+      when (not $ T.isPrefixOf snapshotDirText packageDb) $ do+        throwIO $ PackageDbLocMismatch snapshotDirText packageDb+    else do+      throwIO $ MissingConfig cabalConfigExists cabalSandboxConfigExists++getGhcVersion :: IO Text+getGhcVersion = do+  output <- readProcess "ghc" ["--version"] ""+  case words output of+    [] -> throwIO $ GhcVersionFail+    ws -> return $ "ghc-" <> T.pack (last ws)++sandboxInit :: Maybe Snapshot -> IO ()+sandboxInit msnapshot = do+  cabalSandboxConfigExists <- isFile "cabal.sandbox.config"+  when cabalSandboxConfigExists $ do+    throwIO ConfigAlreadyExists++  cabalConfigExists <- isFile "cabal.config"+  when (not cabalConfigExists) $ do+    runStackagePlugin "init" (mSnapshotToArgs msnapshot)++  configSnapshot <- parseConfigSnapshot+  snapshot <- case msnapshot of+    Just s | snapshotEq s configSnapshot -> return configSnapshot+    Just s -> throwIO $ SnapshotMismatch s configSnapshot+    Nothing -> return configSnapshot++  T.putStrLn $ "Initializing at snapshot: " <> snapshot++  dir <- getSnapshotDir snapshot+  createTree dir+  cabalSandboxInit dir+  sandboxVerify++getHome :: IO Text+getHome = T.pack <$> do+  mHome <- lookupEnv "HOME"+  case mHome of+    Just home -> return home+    Nothing -> do+      mHomePath <- lookupEnv "HOMEPATH"+      mHomeDrive <- lookupEnv "HOMEDRIVE"+      case (++) <$> mHomeDrive <*> mHomePath of+        Just home -> return home+        Nothing -> throwIO NoHomeEnvironmentVariable++getSnapshotDirPrefix :: IO Path.FilePath+getSnapshotDirPrefix = do+  home <- getHome+  ghcVersion <- getGhcVersion+  let dir = Path.fromText home </> ".stackage" </> "sandboxes"+        </> Path.fromText ghcVersion+  return dir++getSnapshotDir :: Snapshot -> IO Path.FilePath+getSnapshotDir snapshot = do+  dir <- getSnapshotDirPrefix+  return $ dir </> Path.fromText snapshot+++-- copied from Purge.hs, tweaked+-- TODO: remove duplication+parsePackageDb :: IO (Maybe Text)+parsePackageDb = do+  cabalSandboxConfigExists <- isFile "cabal.sandbox.config"+  if cabalSandboxConfigExists+    then do+      t <- T.readFile "cabal.sandbox.config"+      let packageDbLine = T.stripPrefix "package-db: "+      return $ listToMaybe $ mapMaybe packageDbLine $ T.lines t+    else+      return Nothing++getPackageDb :: IO Text+getPackageDb = parsePackageDb >>= \mdb -> case mdb of+  Just packageDb -> return packageDb+  Nothing -> throwIO $ PackageDbNotFound++getPackageDbArg :: IO Text+getPackageDbArg = parsePackageDb >>= \mdb -> case mdb of+  Just packageDb -> return $ "--package-db=" <> packageDb+  Nothing -> return ""+++printPackageDb :: IO ()+printPackageDb = getPackageDbArg >>= T.putStrLn++ghcPkgList :: Maybe Package -> IO ()+ghcPkgList mPackage = do+  packageDb <- getPackageDbArg+  let args+        = ["list"]+       <> case mPackage of+            Nothing -> []+            Just package -> [T.unpack package]+       <> [T.unpack packageDb]+  callProcess "ghc-pkg" args++ghcPkgUnregister :: Package -> IO ()+ghcPkgUnregister package = do+  packageDb <- getPackageDbArg+  callProcess "ghc-pkg" ["unregister", T.unpack package, T.unpack packageDb]++sandboxDelete :: IO ()+sandboxDelete = do+  cabalConfigExists <- isFile "cabal.config"+  when cabalConfigExists $ do+    removeFile "cabal.config"+  cabalSandboxConfigExists <- isFile "cabal.sandbox.config"+  when cabalSandboxConfigExists $ do+    oldSandboxNotice+    removeFile "cabal.sandbox.config"++snapshotSanityCheck :: Snapshot -> IO ()+snapshotSanityCheck snapshot =+  if any (`T.isInfixOf` snapshot) ["..", "/"]+    then throwIO $ InvalidSnapshot snapshot+    else return ()++sandboxDeleteSnapshot :: Snapshot -> IO ()+sandboxDeleteSnapshot snapshot = do+  snapshotSanityCheck snapshot+  getSnapshotDir snapshot >>= removeTree++-- Find the canonical name for a snapshot by looking it up on stackage.org.+-- This can change over time. e.g. "lts" used to mean lts-1.0.+downloadSnapshot :: Maybe Snapshot -> IO Snapshot+downloadSnapshot mSnapshot = do+  workingDir <- getWorkingDirectory+  let tempDir = ".stackage-sandbox-tmp"+      enterTempDir = do+        createDirectory False tempDir+        setWorkingDirectory tempDir+      exitTempDir = do+        setWorkingDirectory workingDir+        removeTree tempDir+  bracket_ enterTempDir exitTempDir $ do+    runStackagePlugin "init" (mSnapshotToArgs mSnapshot)+    parseConfigSnapshot+++sandboxUpgrade :: Maybe Snapshot -> IO ()+sandboxUpgrade mSnapshot = do+  cabalConfigExists <- isFile "cabal.config"+  cabalSandboxConfigExists <- isFile "cabal.sandbox.config"++  mConfigSnapshot <- if cabalConfigExists+    then Just <$> parseConfigSnapshot+    else return Nothing++  snapshot <- downloadSnapshot mSnapshot++  when (Just snapshot == mConfigSnapshot && cabalSandboxConfigExists) $ do+    packageDb <- getPackageDb+    snapshotDir <- getSnapshotDir snapshot+    snapshotDirText <- toText' snapshotDir+    if T.isPrefixOf snapshotDirText packageDb+      then do+        T.putStrLn $ "Already at snapshot: " <> snapshot+        -- TODO: more verification+        throwIO AlreadyAtSnapshot+      else return ()++  sandboxDelete+  sandboxInit mSnapshot++getSandboxPrefix :: IO Text+getSandboxPrefix = do+  dirPath <- getSnapshotDirPrefix+  dirPathText <- toText' dirPath+  let viaString f = T.pack . f . T.unpack+  return $ viaString addTrailingPathSeparator dirPathText++oldSandboxNotice :: IO ()+oldSandboxNotice = do+  db <- getPackageDb+  sandboxPrefix <- getSandboxPrefix+  case T.stripPrefix sandboxPrefix db of+    Nothing -> do+      putStrLn "Notice: Your old sandbox remains intact:"+      T.putStrLn db+    Just db' -> case T.takeWhile (not . flip elem "/\\") db' of+      snapshot | not (T.null snapshot) -> do+        T.putStrLn $ "Notice: The " <> snapshot <> " shared sandbox remains intact."+        T.putStrLn $ "You may delete it from your system by calling:"+        T.putStrLn $ "stackage sandbox delete " <> snapshot+      _ -> do+        putStrLn "Notice: Your old sandbox remains untouched:"+        T.putStrLn db+  T.putStrLn ""+++handleSandboxExceptions :: SandboxException -> IO ()+handleSandboxExceptions NoHomeEnvironmentVariable = do+  hPutStrLn stderr "Couldn't find the HOME environment variable"+  exitFailure+handleSandboxExceptions AlreadyAtSnapshot = exitSuccess+handleSandboxExceptions (PackageDbLocMismatch dir db) = do+  hPutStrLn stderr "verify: package db isn't in the expected location:"+  T.hPutStrLn stderr $ "dir: " <> dir+  T.hPutStrLn stderr $ "db: " <> db+  exitFailure+handleSandboxExceptions (MissingConfig cabalConfigExists cabalSandboxConfigExists) = do+  when (not cabalConfigExists) $+    hPutStrLn stderr "verify: cabal.config not present"+  when (not cabalSandboxConfigExists) $+    hPutStrLn stderr "verify: cabal.sandbox.config not present"+  exitFailure+handleSandboxExceptions (SnapshotMismatch s configSnapshot) = do+  T.hPutStrLn stderr+     $ "Warning: given snapshot [" <> s <> "] "+    <> "doesn't match cabal.config snapshot [" <> configSnapshot <> "]"+  hPutStrLn stderr "No action taken"+  exitFailure+handleSandboxExceptions ConfigAlreadyExists = do+  hPutStrLn stderr $ "Warning: cabal.sandbox.config already exists"+  hPutStrLn stderr $ "No action taken"+  exitFailure+handleSandboxExceptions NonStackageCabalConfig = do+  hPutStrLn stderr $ "cabal.config doesn't look like it's from stackage"+  exitFailure+handleSandboxExceptions EmptyCabalConfig = do+  hPutStrLn stderr $ "No contents found in cabal.config"+  exitFailure+handleSandboxExceptions (DecodePathFail e) = do+  hPutStrLn stderr $ "Unexpected failure decoding path:"+  T.hPutStrLn stderr e+  exitFailure+handleSandboxExceptions (InvalidSnapshot snapshot) = do+  T.hPutStrLn stderr $ "Invalid snapshot: " <> snapshot+  exitFailure+handleSandboxExceptions GhcVersionFail = do+  hPutStrLn stderr $ "Couldn't determine ghc version"+  exitFailure+handleSandboxExceptions PackageDbNotFound = do+  hPutStrLn stderr $ "Couldn't find sandbox package-db"+  exitFailure++handlePluginExceptions :: PluginException -> IO ()+handlePluginExceptions (PluginNotFound _ p) = do+  hPutStrLn stderr $ "stackage-sandbox: requires plugin stackage " <> T.unpack p+  exitFailure+handlePluginExceptions (PluginExitFailure _ i) = do+  exitWith (ExitFailure i)++main :: IO ()+main = do+  ((), action) <- simpleOptions+    version+    header+    progDesc+    (pure ())+    subcommands+  let go = case action of+        Init mSnapshot -> sandboxInit mSnapshot+        PackageDb -> printPackageDb+        List mPackage -> ghcPkgList mPackage+        Unregister package -> ghcPkgUnregister package+        Delete mSnapshot -> case mSnapshot of+          Just snapshot -> sandboxDeleteSnapshot snapshot+          Nothing -> sandboxDelete+        Upgrade mSnapshot -> sandboxUpgrade mSnapshot+  go `catch` handleSandboxExceptions+     `catch` handlePluginExceptions
+ main/Upgrade.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Applicative+import Control.Exception (catch)+import Stackage.CLI+import System.Environment (getArgs)+import Data.Monoid+import Data.Text (unpack)+import Options.Applicative (long, short, help, metavar, value, switch, Parser, strArgument)+import System.IO (hPutStrLn, stderr)+import System.Exit (exitFailure, exitWith, ExitCode (..))+import qualified Paths_stackage_cli as CabalInfo++data Opts = Opts+  { purgeArgs :: [String]+  , initArgs :: [String]+  }+++version :: String+version = $(simpleVersion CabalInfo.version)++summary :: String+summary = "Upgrade your cabal.config file"++header :: String+header = summary++progDesc :: String+progDesc = summary++optsParser :: Parser Opts+optsParser = Opts <$> purgeArgsParser <*> initArgsParser++initArgsParser :: Parser [String]+initArgsParser = targetToArgs  <$> initOptsParser where+  targetToArgs t = [t]++-- As seen in Init.hs+initOptsParser :: Parser String+initOptsParser = strArgument mods where+  mods = metavar "SNAPSHOT" <> value "lts"++purgeArgsParser :: Parser [String]+purgeArgsParser = forceToArgs <$> purgeOptsParser where+  forceToArgs force = if force then ["--force"] else []++-- As seen in Purge.hs+purgeOptsParser :: Parser Bool+purgeOptsParser = switch mods where+  mods = long "force"+      <> help "Purge all packages without prompt"++handlePluginException :: PluginException -> IO ()+handlePluginException (PluginNotFound _ p) = do+  hPutStrLn stderr $ "stackage-upgrade: requires plugin stackage " <> unpack p+  exitFailure+handlePluginException (PluginExitFailure _ i) = do+  exitWith (ExitFailure i)++-- TODO: no-op if at desired target already+main = do+  (opts, ()) <- simpleOptions+    version+    header+    progDesc+    optsParser   -- global parser+    empty        -- subcommands++  stackage <- findPlugins "stackage"+  callPlugin stackage "purge" (purgeArgs opts)+    `catch` handlePluginException+  callPlugin stackage "init" (initArgs opts)+    `catch` handlePluginException
+ src/Plugins.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Dynamically look up available executables.+module Plugins+  ( Plugin+  , pluginPrefix+  , pluginName+  , pluginSummary+  , pluginProc++  , Plugins+  , findPlugins+  , listPlugins+  , lookupPlugin+  , callPlugin++  , PluginException (..)+  ) where++import Control.Applicative+import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (StateT, get, put)+import Data.Conduit+import Data.Hashable (Hashable)+import Data.HashSet (HashSet)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Conduit.List as CL+import Data.Conduit.Lift (evalStateC)+import qualified Data.List as L+import Data.List.Split (splitOn)+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Monoid+import System.Directory+import System.Process (CreateProcess, proc, readProcess, readProcessWithExitCode, createProcess, waitForProcess)+import System.FilePath ((</>), getSearchPath, splitExtension)+import System.Environment (getEnv)+import System.Exit (ExitCode (..))++-- | Represents a runnable plugin.+-- Plugins must be discovered via `findPlugins`.+data Plugin = Plugin+  { _pluginPrefix :: !Text+  , _pluginName :: !Text+  , _pluginSummary :: !Text+  }+  deriving (Show)++-- | The program being plugged into.+pluginPrefix :: Plugin -> Text+pluginPrefix = _pluginPrefix++-- | The name of this plugin (without the prefix).+pluginName :: Plugin -> Text+pluginName = _pluginName++-- | A summary of what this plugin does+pluginSummary :: Plugin -> Text+pluginSummary = _pluginSummary++-- | Describes how to create a process out of a plugin and arguments.+-- You may use Data.Process and Data.Conduit.Process+-- to manage the process's stdin, stdout, and stderr in various ways.+pluginProc :: Plugin -> [String] -> CreateProcess+pluginProc = proc . pluginProcessName++-- Not exported+pluginProcessName :: Plugin -> String+pluginProcessName p = unpack $ pluginPrefix p <> "-" <> pluginName p+++-- | Represents the plugins available to a given program.+-- See: `findPlugins`.+data Plugins = Plugins+  { _pluginsPrefix :: !Text+  , _pluginsMap :: !(HashMap Text Plugin)+  }+  deriving (Show)+++-- | Find the plugins for a given program by inspecting everything on the PATH.+-- Any program that is prefixed with the given name and responds+-- to the `--summary` flag by writing one line to stdout+-- is considered a plugin.+findPlugins :: Text -> IO Plugins+findPlugins t = fmap (Plugins t)+   $ discoverPlugins t+  $$ awaitForever (toPlugin t)+  =$ CL.fold insertPlugin HashMap.empty+  where+    insertPlugin m p = HashMap.insert (pluginName p) p m++toPlugin :: (MonadIO m) => Text -> Text -> Producer m Plugin+toPlugin prefix name = do+  let proc = unpack $ prefix <> "-" <> name+  (exit, out, _err) <- liftIO $ readProcessWithExitCode proc ["--summary"] ""+  case exit of+    ExitSuccess -> case T.lines (pack out) of+      [summary] -> yield $ Plugin+        { _pluginPrefix = prefix+        , _pluginName = name+        , _pluginSummary = summary+        }+      _ -> return ()+    _ -> return ()+++-- | Things that can go wrong when using `callPlugin`.+data PluginException+  = PluginNotFound !Plugins !Text+  | PluginExitFailure !Plugin !Int+  deriving (Show, Typeable)+instance Exception PluginException++-- | Look up a particular plugin by name.+lookupPlugin :: Plugins -> Text -> Maybe Plugin+lookupPlugin ps t = HashMap.lookup t $ _pluginsMap ps++-- | List the available plugins.+listPlugins :: Plugins -> [Plugin]+listPlugins = HashMap.elems . _pluginsMap++-- | A convenience wrapper around lookupPlugin and pluginProc.+-- Handles stdin, stdout, and stderr are all inherited by the plugin.+-- Throws PluginException.+callPlugin :: (MonadIO m, MonadThrow m)+  => Plugins -> Text -> [String] -> m ()+callPlugin ps name args = case lookupPlugin ps name of+  Nothing -> throwM $ PluginNotFound ps name+  Just plugin -> do+    exit <- liftIO $ do+      (_, _, _, process) <- createProcess $ pluginProc plugin args+      waitForProcess process+    case exit of+      ExitFailure i -> throwM $ PluginExitFailure plugin i+      ExitSuccess -> return ()+++discoverPlugins :: MonadIO m => Text -> Producer m Text+discoverPlugins t+  = getPathDirs+ $= clNub -- unique dirs on path+ $= awaitForever (executablesPrefixed $ unpack $ t <> "-")+ $= CL.map pack+ $= clNub -- unique executables++executablesPrefixed :: (MonadIO m) => FilePath -> FilePath -> Producer m FilePath+executablesPrefixed prefix dir+  = pathToContents dir+ $= CL.filter (L.isPrefixOf prefix)+ $= clFilterM (fileExistsIn dir)+ $= clFilterM (isExecutableIn dir)+ $= CL.mapMaybe (L.stripPrefix prefix . dropExeExt)++-- | Drop the .exe extension if present+dropExeExt :: FilePath -> FilePath+dropExeExt fp+    | y == ".exe" = x+    | otherwise   = fp+  where+    (x, y) = splitExtension fp++getPathDirs :: (MonadIO m) => Producer m FilePath+getPathDirs = liftIO getSearchPath >>= mapM_ yield++pathToContents :: (MonadIO m) => FilePath -> Producer m FilePath+pathToContents dir = do+  exists <- liftIO $ doesDirectoryExist dir+  when exists $ do+    contents <- liftIO $ getDirectoryContents dir+    CL.sourceList contents++fileExistsIn :: (MonadIO m) => FilePath -> FilePath -> m Bool+fileExistsIn dir file = liftIO $ doesFileExist $ dir </> file++isExecutableIn :: (MonadIO m) => FilePath -> FilePath -> m Bool+isExecutableIn dir file = liftIO $ do+  perms <- getPermissions $ dir </> file+  return (executable perms)++clFilterM :: Monad m => (a -> m Bool) -> Conduit a m a+clFilterM pred = awaitForever $ \a -> do+  predPassed <- lift $ pred a+  when predPassed $ yield a++clNub :: (Monad m, Eq a, Hashable a)+  => Conduit a m a+clNub = evalStateC HashSet.empty clNubState++clNubState :: (Monad m, Eq a, Hashable a)+  => Conduit a (StateT (HashSet a) m) a+clNubState = awaitForever $ \a -> do+  seen <- lift get+  unless (HashSet.member a seen) $ do+    lift $ put $ HashSet.insert a seen+    yield a
+ src/Plugins/Commands.hs view
@@ -0,0 +1,25 @@+-- | Using Plugins with SimpleOptions+module Plugins.Commands+  ( commandsFromPlugins+  , toCommand+  ) where++import Control.Monad.Trans.Either (EitherT)+import Control.Monad.Trans.Writer (Writer)+import Data.Text (Text, unpack)+import Data.Foldable (foldMap)+import Plugins+import Options.Applicative.Simple++-- | Generate the "commands" argument to simpleOptions+-- based on available plugins.+commandsFromPlugins :: Plugins -> EitherT Text (Writer (Mod CommandFields Text)) ()+commandsFromPlugins plugins = mapM_ toCommand (listPlugins plugins)++-- | Convert a single plugin into a command.+toCommand :: Plugin -> EitherT Text (Writer (Mod CommandFields Text)) ()+toCommand plugin = addCommand+  (unpack $ pluginName plugin)+  (unpack $ pluginSummary plugin)+  id+  (pure $ pluginName plugin)
+ src/SimpleOptions.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RankNTypes #-}++-- | A convenience wrapper around Options.Applicative.+module SimpleOptions+    ( simpleOptions+    , Options.addCommand+    , Options.simpleVersion+    ) where++import           Control.Applicative+import           Control.Monad.Trans.Either (EitherT)+import           Control.Monad.Trans.Writer (Writer)+import           Data.Monoid+import qualified Options.Applicative.Simple as Options++-- | This is a drop-in replacement for simpleOptions from+-- Options.Applicative.Simple, with the added feature of a `--summary` flag+-- that prints out the header. (Should be one line)+simpleOptions+  :: String+  -- ^ version string+  -> String+  -- ^ header+  -> String+  -- ^ program description+  -> Options.Parser a+  -- ^ global settings+  -> EitherT b (Writer (Options.Mod Options.CommandFields b)) ()+  -- ^ commands (use 'addCommand')+  -> IO (a,b)+simpleOptions versionString h pd globalParser mcommands =+    Options.simpleOptions+              versionString h pd globalParser' mcommands+  where+    globalParser' = summaryOption <*> globalParser+    summaryOption = Options.infoOption h+      $ Options.long "summary"+     <> Options.help "Show program summary"
+ src/Stackage/CLI.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Functions for creating and calling Stackage plugins.+module Stackage.CLI+  ( -- * Discovering and calling plugins+    runStackagePlugin+  , Plugins+  , findPlugins+  , callPlugin+  , PluginException (..)++    -- * Creating your own plugin+  , commandsFromPlugins+  , simpleOptions+  , addCommand+  , simpleVersion++    -- * Finer-grained inspection of plugins+  , listPlugins+  , lookupPlugin+  , Plugin+  , pluginPrefix+  , pluginName+  , pluginSummary+  , pluginProc+  ) where++import Data.Text (Text)+import Plugins+import Plugins.Commands+import SimpleOptions++-- | Runs a stackage plugin. Handy for dynamic one-off runs,+-- but if you'll be running multiple plugins, it is recommended+-- that you use @findPlugins "stackage"@ so that the plugin search+-- is performed only once.+runStackagePlugin :: Text -> [String] -> IO ()+runStackagePlugin name args = do+  stackage <- findPlugins "stackage"+  callPlugin stackage name args
+ stackage-cli.cabal view
@@ -0,0 +1,110 @@+name:                stackage-cli+version:             0.0.0+synopsis:+  A CLI library for stackage commands+description:+  A CLI library for stackage commands+license:             MIT+license-file:        LICENSE+author:              Dan Burton+maintainer:          danburton@fpcomplete.com+copyright:           2015 FP Complete Corporation+build-type:          Simple+cabal-version:       >=1.10+category: Development++library+  hs-source-dirs: src/+  exposed-modules:+      Stackage.CLI+  other-modules:+      SimpleOptions+    , Plugins+    , Plugins.Commands+  build-depends:+      base >=4.7 && <5+    , text+    , conduit+    , optparse-applicative+    , process+    , transformers+    , split+    , filepath+    , directory+    , hashable+    , unordered-containers+    , exceptions+    , optparse-simple >= 0.0.2+    , either+  default-language:    Haskell2010++executable stackage+  hs-source-dirs:      main+  main-is:             Main.hs+  build-depends:+      base >=4.7 && <5+    , text+    , stackage-cli+  default-language:    Haskell2010++executable stk+  hs-source-dirs:      main+  main-is:             Main.hs+  build-depends:+      base >=4.7 && <5+    , text+    , stackage-cli+  default-language:    Haskell2010++executable stackage-init+  hs-source-dirs:      main+  main-is:             Init.hs+  build-depends:+      base >=4.7 && <5+    , text+    , stackage-cli+    , system-fileio+    , optparse-applicative+    , http-client+    , http-types+    , bytestring+  default-language:    Haskell2010++executable stackage-purge+  hs-source-dirs:      main+  main-is:             Purge.hs+  build-depends:+      base >=4.7 && <5+    , text+    , stackage-cli+    , system-fileio+    , optparse-applicative+    , process+    , parsec+    , exceptions+  default-language:    Haskell2010++executable stackage-upgrade+  hs-source-dirs:      main+  main-is:             Upgrade.hs+  build-depends:+      base >=4.7 && <5+    , text+    , stackage-cli+    , system-fileio+    , optparse-applicative+  default-language:    Haskell2010++executable stackage-sandbox+  hs-source-dirs:      main+  main-is:             Sandbox.hs+  build-depends:+      base >=4.7 && <5+    , text+    , stackage-cli+    , system-fileio+    , system-filepath+    , optparse-applicative+    , process+    , filepath+  default-language:    Haskell2010