{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE NoFieldSelectors     #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

module Stack.Types.Snapshot
  ( AbstractSnapshot (..)
  , readAbstractSnapshot
  , Snapshots (..)
  ) where

import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.Aeson.Types
                   ( FromJSON, parseJSON, withObject, withText )
import           Data.Aeson.WarningParser ( (.:) )
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Text as T
import           Data.Text.Read ( decimal )
import           Data.Time ( Day )
import           Options.Applicative ( ReadM )
import qualified Options.Applicative.Types as OA
import           Stack.Prelude

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Types.Snapshot" module.

data TypesSnapshotException
  = ParseSnapshotException !Text
  | FilepathInDownloadedSnapshot !Text
  deriving (Int -> TypesSnapshotException -> ShowS
[TypesSnapshotException] -> ShowS
TypesSnapshotException -> String
(Int -> TypesSnapshotException -> ShowS)
-> (TypesSnapshotException -> String)
-> ([TypesSnapshotException] -> ShowS)
-> Show TypesSnapshotException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypesSnapshotException -> ShowS
showsPrec :: Int -> TypesSnapshotException -> ShowS
$cshow :: TypesSnapshotException -> String
show :: TypesSnapshotException -> String
$cshowList :: [TypesSnapshotException] -> ShowS
showList :: [TypesSnapshotException] -> ShowS
Show, Typeable)

instance Exception TypesSnapshotException where
  displayException :: TypesSnapshotException -> String
displayException (ParseSnapshotException Text
t) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-8787]\n"
    , String
"Invalid snapshot value: "
    , Text -> String
T.unpack Text
t
    , String
". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, \
      \ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. See \
      \https://www.stackage.org/snapshots for a complete list."
    ]
  displayException (FilepathInDownloadedSnapshot Text
url) = [String] -> String
unlines
    [ String
"Error: [S-4865]"
    , String
"Downloaded snapshot specified a 'snapshot: { location: filepath }' "
    , String
"field, but filepaths are not allowed in downloaded snapshots.\n"
    , String
"Filepath specified: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
url
    ]

-- | Either an actual snapshot value, or an abstract description of one (e.g.,

-- latest nightly).

data AbstractSnapshot
  = ASLatestNightly
  | ASLatestLTS
  | ASLatestLTSMajor !Int
  | ASSnapshot !RawSnapshotLocation
  | ASGlobal

instance Show AbstractSnapshot where
  show :: AbstractSnapshot -> String
show = Text -> String
T.unpack (Text -> String)
-> (AbstractSnapshot -> Text) -> AbstractSnapshot -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text)
-> (AbstractSnapshot -> Utf8Builder) -> AbstractSnapshot -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbstractSnapshot -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display

instance Display AbstractSnapshot where
  display :: AbstractSnapshot -> Utf8Builder
display AbstractSnapshot
ASLatestNightly = Utf8Builder
"nightly"
  display AbstractSnapshot
ASLatestLTS = Utf8Builder
"lts"
  display (ASLatestLTSMajor Int
x) = Utf8Builder
"lts-" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
x
  display (ASSnapshot RawSnapshotLocation
usl) = RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
usl
  display AbstractSnapshot
ASGlobal = Utf8Builder
"global"

instance FromJSON (Unresolved AbstractSnapshot) where
  parseJSON :: Value -> Parser (Unresolved AbstractSnapshot)
parseJSON = String
-> (Text -> Parser (Unresolved AbstractSnapshot))
-> Value
-> Parser (Unresolved AbstractSnapshot)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Unresolved AbstractSnapshot" ((Text -> Parser (Unresolved AbstractSnapshot))
 -> Value -> Parser (Unresolved AbstractSnapshot))
-> (Text -> Parser (Unresolved AbstractSnapshot))
-> Value
-> Parser (Unresolved AbstractSnapshot)
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    Unresolved AbstractSnapshot -> Parser (Unresolved AbstractSnapshot)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Unresolved AbstractSnapshot
 -> Parser (Unresolved AbstractSnapshot))
-> Unresolved AbstractSnapshot
-> Parser (Unresolved AbstractSnapshot)
forall a b. (a -> b) -> a -> b
$ String -> Unresolved AbstractSnapshot
parseAbstractSnapshot (String -> Unresolved AbstractSnapshot)
-> String -> Unresolved AbstractSnapshot
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t

readAbstractSnapshot :: ReadM (Unresolved AbstractSnapshot)
readAbstractSnapshot :: ReadM (Unresolved AbstractSnapshot)
readAbstractSnapshot = String -> Unresolved AbstractSnapshot
parseAbstractSnapshot (String -> Unresolved AbstractSnapshot)
-> ReadM String -> ReadM (Unresolved AbstractSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String
OA.readerAsk

parseAbstractSnapshot :: String -> Unresolved AbstractSnapshot
parseAbstractSnapshot :: String -> Unresolved AbstractSnapshot
parseAbstractSnapshot String
s = case String
s of
  String
"global" -> AbstractSnapshot -> Unresolved AbstractSnapshot
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractSnapshot
ASGlobal
  String
"nightly" -> AbstractSnapshot -> Unresolved AbstractSnapshot
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractSnapshot
ASLatestNightly
  String
"lts" -> AbstractSnapshot -> Unresolved AbstractSnapshot
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractSnapshot
ASLatestLTS
  Char
'l':Char
't':Char
's':Char
'-':String
x | Right (Int
x', Text
"") <- Reader Int
forall a. Integral a => Reader a
decimal Reader Int -> Reader Int
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
x ->
      AbstractSnapshot -> Unresolved AbstractSnapshot
forall a. a -> Unresolved a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbstractSnapshot -> Unresolved AbstractSnapshot)
-> AbstractSnapshot -> Unresolved AbstractSnapshot
forall a b. (a -> b) -> a -> b
$ Int -> AbstractSnapshot
ASLatestLTSMajor Int
x'
  String
_ ->RawSnapshotLocation -> AbstractSnapshot
ASSnapshot (RawSnapshotLocation -> AbstractSnapshot)
-> Unresolved RawSnapshotLocation -> Unresolved AbstractSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation (String -> Text
T.pack String
s)

-- | Most recent Nightly and newest LTS version per major release.

data Snapshots = Snapshots
  { Snapshots -> Day
nightly :: !Day
  , Snapshots -> IntMap Int
lts     :: !(IntMap Int)
  }
  deriving Int -> Snapshots -> ShowS
[Snapshots] -> ShowS
Snapshots -> String
(Int -> Snapshots -> ShowS)
-> (Snapshots -> String)
-> ([Snapshots] -> ShowS)
-> Show Snapshots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Snapshots -> ShowS
showsPrec :: Int -> Snapshots -> ShowS
$cshow :: Snapshots -> String
show :: Snapshots -> String
$cshowList :: [Snapshots] -> ShowS
showList :: [Snapshots] -> ShowS
Show

instance FromJSON Snapshots where
  parseJSON :: Value -> Parser Snapshots
parseJSON = String -> (Object -> Parser Snapshots) -> Value -> Parser Snapshots
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Snapshots" ((Object -> Parser Snapshots) -> Value -> Parser Snapshots)
-> (Object -> Parser Snapshots) -> Value -> Parser Snapshots
forall a b. (a -> b) -> a -> b
$ \Object
o -> Day -> IntMap Int -> Snapshots
Snapshots
    (Day -> IntMap Int -> Snapshots)
-> Parser Day -> Parser (IntMap Int -> Snapshots)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"nightly" Parser Text -> (Text -> Parser Day) -> Parser Day
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Parser Day
forall {m :: * -> *}. MonadFail m => Text -> m Day
parseNightly)
    Parser (IntMap Int -> Snapshots)
-> Parser (IntMap Int) -> Parser Snapshots
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([IntMap Int] -> IntMap Int)
-> Parser [IntMap Int] -> Parser (IntMap Int)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [IntMap Int] -> IntMap Int
forall (f :: * -> *) a. Foldable f => f (IntMap a) -> IntMap a
IntMap.unions (((Key, Value) -> Parser (IntMap Int))
-> [(Key, Value)] -> Parser [IntMap Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Value -> Parser (IntMap Int)
parseLTS (Value -> Parser (IntMap Int))
-> ((Key, Value) -> Value) -> (Key, Value) -> Parser (IntMap Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Value
forall a b. (a, b) -> b
snd)
          ([(Key, Value)] -> Parser [IntMap Int])
-> [(Key, Value)] -> Parser [IntMap Int]
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Bool) -> [(Key, Value)] -> [(Key, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Bool
isLTS (Text -> Bool) -> ((Key, Value) -> Text) -> (Key, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText (Key -> Text) -> ((Key, Value) -> Key) -> (Key, Value) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Key
forall a b. (a, b) -> a
fst)
          ([(Key, Value)] -> [(Key, Value)])
-> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o)
   where
    parseNightly :: Text -> m Day
parseNightly Text
t =
      case Text -> Either SomeException SnapName
forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t of
        Left SomeException
e -> String -> m Day
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Day) -> String -> m Day
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
        Right (LTS Int
_ Int
_) -> String -> m Day
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected LTS value"
        Right (Nightly Day
d) -> Day -> m Day
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
d

    isLTS :: Text -> Bool
isLTS = (Text
"lts-" `T.isPrefixOf`)

    parseLTS :: Value -> Parser (IntMap Int)
parseLTS = String
-> (Text -> Parser (IntMap Int)) -> Value -> Parser (IntMap Int)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"LTS" ((Text -> Parser (IntMap Int)) -> Value -> Parser (IntMap Int))
-> (Text -> Parser (IntMap Int)) -> Value -> Parser (IntMap Int)
forall a b. (a -> b) -> a -> b
$ \Text
t ->
      case Text -> Either SomeException SnapName
forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t of
        Left SomeException
e -> String -> Parser (IntMap Int)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (IntMap Int)) -> String -> Parser (IntMap Int)
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
        Right (LTS Int
x Int
y) -> IntMap Int -> Parser (IntMap Int)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap Int -> Parser (IntMap Int))
-> IntMap Int -> Parser (IntMap Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IntMap Int
forall a. Int -> a -> IntMap a
IntMap.singleton Int
x Int
y
        Right (Nightly Day
_) -> String -> Parser (IntMap Int)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected nightly value"