{-# 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

-- | List the dependencies

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