diff --git a/ChangeLog.md b/ChangeLog.md index d1eb9ec1e0..3224a2927f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -10,6 +10,10 @@ Behaviour changes: Other enhancements: +* A new sub command `ls` has been introduced to stack to view + local and remote snapshots present in the system. Use `stack ls + snapshots --help` to get more details about it. + Bug fixes: * For versions of Cabal before 1.24, ensure that the dependencies of diff --git a/package.yaml b/package.yaml index 4cf1285a17..ebcad27cdf 100644 --- a/package.yaml +++ b/package.yaml @@ -182,6 +182,7 @@ library: - Stack.IDE - Stack.Image - Stack.Init + - Stack.Ls - Stack.New - Stack.Nix - Stack.Options.BenchParser diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs new file mode 100644 index 0000000000..024f0ae06a --- /dev/null +++ b/src/Stack/Ls.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Stack.Ls + ( lsCmd + , lsParser + ) where + +import Control.Exception (Exception, throw) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader) +import Data.Aeson +import Stack.Types.Runner +import qualified Data.Aeson.Types as A +import qualified Data.List as L +import Data.Monoid +import Data.Text hiding (pack, intercalate) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import Network.HTTP.Simple + (addRequestHeader, getResponseBody, httpJSON, parseRequest, + setRequestManager) +import Network.HTTP.Types.Header (hAccept) +import qualified Options.Applicative as OA +import Options.Applicative ((<|>)) +import Path +import Stack.Runners (withBuildConfig) +import Stack.Types.Config +import System.Process.PagerEditor (pageText) +import System.Directory (listDirectory) +import Network.HTTP.Client.TLS (getGlobalManager) + +data LsView + = Local + | Remote + deriving (Show, Eq, Ord) + +data SnapshotType + = Lts + | Nightly + deriving (Show, Eq, Ord) + +newtype LsCmds = + LsSnapshot SnapshotOpts + deriving (Eq, Show, Ord) + +data SnapshotOpts = SnapshotOpts + { soptViewType :: LsView + , soptLtsSnapView :: Bool + , soptNightlySnapView :: Bool + } deriving (Eq, Show, Ord) + +newtype LsCmdOpts = LsCmdOpts + { lsView :: LsCmds + } deriving (Eq, Show, Ord) + +lsParser :: OA.Parser LsCmdOpts +lsParser = LsCmdOpts <$> OA.hsubparser lsSnapCmd + +lsCmdOptsParser :: OA.Parser LsCmds +lsCmdOptsParser = fmap LsSnapshot lsViewSnapCmd + +lsViewSnapCmd :: OA.Parser SnapshotOpts +lsViewSnapCmd = + SnapshotOpts <$> + (OA.hsubparser (lsViewRemoteCmd <> lsViewLocalCmd) <|> pure Local) <*> + OA.switch + (OA.long "lts" <> OA.short 'l' <> OA.help "Only show lts snapshots") <*> + OA.switch + (OA.long "nightly" <> OA.short 'n' <> + OA.help "Only show nightly snapshots") + +lsSnapCmd :: OA.Mod OA.CommandFields LsCmds +lsSnapCmd = + OA.command + "snapshots" + (OA.info + lsCmdOptsParser + (OA.progDesc "View local snapshot (default option)")) + +data Snapshot = Snapshot + { snapId :: Text + , snapTitle :: Text + , snapTime :: Text + } deriving (Show, Eq, Ord) + +data SnapshotData = SnapshotData + { _snapTotalCounts :: Integer + , snaps :: [[Snapshot]] + } deriving (Show, Eq, Ord) + +instance FromJSON Snapshot where + parseJSON o@(Array _) = parseSnapshot o + parseJSON _ = mempty + +instance FromJSON SnapshotData where + parseJSON (Object s) = + SnapshotData <$> s .: "totalCount" <*> s .: "snapshots" + parseJSON _ = mempty + +toSnapshot :: [Value] -> Snapshot +toSnapshot [String sid, String stitle, String stime] = + Snapshot + { snapId = sid + , snapTitle = stitle + , snapTime = stime + } +toSnapshot val = throw $ ParseFailure val + +newtype LsException = + ParseFailure [Value] + deriving (Show, Typeable) + +instance Exception LsException + +parseSnapshot :: Value -> A.Parser Snapshot +parseSnapshot = A.withArray "array of snapshot" (return . toSnapshot . V.toList) + +displayTime :: Snapshot -> [Text] +displayTime Snapshot {..} = [snapTime] + +displaySnap :: Snapshot -> [Text] +displaySnap Snapshot {..} = + ["Resolver name: " <> snapId, "\n" <> snapTitle <> "\n\n"] + +displaySingleSnap :: [Snapshot] -> Text +displaySingleSnap snapshots = + case snapshots of + [] -> mempty + (x:xs) -> + let snaps = + displayTime x <> ["\n\n"] <> displaySnap x <> + L.concatMap displaySnap xs + in T.concat snaps + +renderData :: Bool -> Text -> IO () +renderData True content = pageText content +renderData False content = T.putStr content + +displaySnapshotData :: Bool -> SnapshotData -> IO () +displaySnapshotData term sdata = + case L.reverse $ snaps sdata of + [] -> return () + xs -> + let snaps = T.concat $ L.map displaySingleSnap xs + in renderData term snaps + +filterSnapshotData :: SnapshotData -> SnapshotType -> SnapshotData +filterSnapshotData sdata stype = + sdata + { snaps = filterSnapData + } + where + snapdata = snaps sdata + filterSnapData = + case stype of + Lts -> L.map (L.filter (\x -> "lts" `isPrefixOf` snapId x)) snapdata + Nightly -> + L.map (L.filter (\x -> "nightly" `isPrefixOf` snapId x)) snapdata + +displayLocalSnapshot :: Bool -> [String] -> IO () +displayLocalSnapshot term xs = renderData term (localSnaptoText xs) + +localSnaptoText :: [String] -> Text +localSnaptoText xs = T.intercalate "\n" $ L.map T.pack xs + +handleLocal + :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) + => LsCmdOpts -> m () +handleLocal lsOpts = do + (instRoot :: Path Abs Dir) <- installationRootDeps + isStdoutTerminal <- view terminalL + let snapRootDir = parent $ parent instRoot + snapData' <- liftIO $ listDirectory $ toFilePath snapRootDir + let snapData = L.sort snapData' + case lsView lsOpts of + LsSnapshot SnapshotOpts {..} -> + case (soptLtsSnapView, soptNightlySnapView) of + (True, False) -> + liftIO $ + displayLocalSnapshot isStdoutTerminal $ + L.filter (L.isPrefixOf "lts") snapData + (False, True) -> + liftIO $ + displayLocalSnapshot isStdoutTerminal $ + L.filter (L.isPrefixOf "night") snapData + _ -> liftIO $ displayLocalSnapshot isStdoutTerminal snapData + +handleRemote + :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) + => LsCmdOpts -> m () +handleRemote lsOpts = do + req <- liftIO $ parseRequest urlInfo + mgr <- liftIO getGlobalManager + isStdoutTerminal <- view terminalL + let req' = + setRequestManager mgr $ + addRequestHeader hAccept "application/json" req + result <- httpJSON req' + let snapData = getResponseBody result + case lsView lsOpts of + LsSnapshot SnapshotOpts {..} -> + case (soptLtsSnapView, soptNightlySnapView) of + (True, False) -> + liftIO $ + displaySnapshotData isStdoutTerminal $ + filterSnapshotData snapData Lts + (False, True) -> + liftIO $ + displaySnapshotData isStdoutTerminal $ + filterSnapshotData snapData Nightly + _ -> liftIO $ displaySnapshotData isStdoutTerminal snapData + where + urlInfo = "https://www.stackage.org/snapshots" + +lsCmd :: LsCmdOpts -> GlobalOpts -> IO () +lsCmd lsOpts go = + case lsView lsOpts of + LsSnapshot SnapshotOpts {..} -> + case soptViewType of + Local -> withBuildConfig go (handleLocal lsOpts) + Remote -> withBuildConfig go (handleRemote lsOpts) + +lsViewLocalCmd :: OA.Mod OA.CommandFields LsView +lsViewLocalCmd = + OA.command + "local" + (OA.info (pure Local) (OA.progDesc "View local snapshot")) + +lsViewRemoteCmd :: OA.Mod OA.CommandFields LsView +lsViewRemoteCmd = + OA.command + "remote" + (OA.info (pure Remote) (OA.progDesc "View remote snapshot")) diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs index 37f2bb515e..f3031bd068 100644 --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -7,6 +7,7 @@ module System.Process.PagerEditor (-- * Pager pageWriter ,pageByteString + ,pageText ,pageBuilder ,pageFile ,pageString @@ -29,6 +30,7 @@ import System.FilePath (()) import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe) ,CreateProcess(std_in, close_fds, delegate_ctlc)) import System.IO (hClose,hPutStr,readFile,stdout) +import qualified Data.Text.IO as T -- | Run pager, providing a function that writes to the pager's input. pageWriter :: (Handle -> IO ()) -> IO () @@ -55,6 +57,10 @@ pageWriter writer = pageByteString :: ByteString -> IO () pageByteString = pageWriter . flip hPut +-- | Run pager to display a 'Text' +pageText :: Text -> IO () +pageText = pageWriter . flip T.hPutStr + -- | Run pager to display a ByteString-Builder. pageBuilder :: Builder -> IO () pageBuilder = pageWriter . flip hPutBuilder diff --git a/src/main/Main.hs b/src/main/Main.hs index fd845982fb..dc2210daf8 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -66,6 +66,7 @@ import Stack.Fetch import Stack.FileWatch import Stack.Ghci import Stack.Hoogle +import Stack.Ls import qualified Stack.IDE as IDE import qualified Stack.Image as Image import Stack.Init @@ -299,6 +300,10 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions "Print out handy path information" pathCmd Stack.Path.pathParser + addCommand' "ls" + "List command. (Supports snapshots)" + lsCmd + lsParser addCommand' "unpack" "Unpack one or more packages locally" unpackCmd