{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Ls
( lsCmd
, lsParser
, listDependenciesCmd
) where
import Control.Exception (Exception, throw)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader)
import Control.Monad (when)
import Data.Aeson
import Stack.Prelude
import Stack.Types.Runner
import qualified Data.Aeson.Types as A
import qualified Data.List as L
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.StackClient (httpJSON, getGlobalManager, addRequestHeader, getResponseBody, parseRequest,
setRequestManager, hAccept)
import qualified Options.Applicative as OA
import Options.Applicative ((<|>))
import Path
import Stack.Runners (withBuildConfig, withBuildConfigDot)
import Stack.Types.Config
import Stack.Dot
import Stack.Options.DotParser (listDepsOptsParser)
import System.Process.PagerEditor (pageText)
import System.Directory (listDirectory)
import System.IO (stderr, hPutStrLn)
data LsView
= Local
| Remote
deriving (Show, Eq, Ord)
data SnapshotType
= Lts
| Nightly
deriving (Show, Eq, Ord)
data LsCmds
= LsSnapshot SnapshotOpts
| LsDependencies ListDepsOpts
data SnapshotOpts = SnapshotOpts
{ soptViewType :: LsView
, soptLtsSnapView :: Bool
, soptNightlySnapView :: Bool
} deriving (Eq, Show, Ord)
newtype LsCmdOpts = LsCmdOpts
{ lsView :: LsCmds
}
lsParser :: OA.Parser LsCmdOpts
lsParser = LsCmdOpts <$> OA.hsubparser (lsSnapCmd <> lsDepsCmd)
lsCmdOptsParser :: OA.Parser LsCmds
lsCmdOptsParser = LsSnapshot <$> lsViewSnapCmd
lsDepOptsParser :: OA.Parser LsCmds
lsDepOptsParser = LsDependencies <$> listDepsOptsParser
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)"))
lsDepsCmd :: OA.Mod OA.CommandFields LsCmds
lsDepsCmd =
OA.command
"dependencies"
(OA.info lsDepOptsParser (OA.progDesc "View the dependencies"))
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
LsDependencies _ -> return ()
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
LsDependencies _ -> return ()
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)
LsDependencies depOpts -> listDependenciesCmd False depOpts go
listDependenciesCmd :: Bool -> ListDepsOpts -> GlobalOpts -> IO ()
listDependenciesCmd deprecated opts go = do
when
deprecated
(hPutStrLn
stderr
"DEPRECATED: Use ls dependencies instead. Will be removed in next major version.")
withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts
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"))