Introduce new sub command ls

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

package.yaml

@@ -182,6 +182,7 @@ library:
   - Stack.IDE
   - Stack.Image
   - Stack.Init
+  - Stack.Ls
   - Stack.New
   - Stack.Nix
   - Stack.Options.BenchParser

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"))

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

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