{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Runtime.Cache
  ( Cache,
    Registry (..),
    askCache,
    getRegistry,
    updateRegistry,
    modifyCache,
    loadCache,
    saveCache,
    getVersions,
    Versions,
    VersionMap,
    clearVersions,
    prepareDir,
    getSnapshotGHC,
    Snapshot (..),
  )
where

import qualified Control.Concurrent.STM as STM
import Control.Monad.Except (MonadError (..))
import Data.Aeson (FromJSON, ToJSON, eitherDecode, (.:))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (withObject)
import qualified Data.ByteString.Lazy as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Yaml (decodeEither', prettyPrintParseException)
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Format (..))
import HWM.Core.Has (Has, askEnv)
import HWM.Core.Parsing (genUrl)
import HWM.Core.Pkg (PkgName)
import HWM.Core.Result (Issue, Result (..), ResultT (..))
import HWM.Core.Version (Version, parseGHCVersion)
import HWM.Runtime.Files (select)
import Network.HTTP.Req (GET (..), LbsResponse, NoReqBody (..), Option, Req, Url, defaultHttpConfig, lbsResponse, req, responseBody, runReq, useURI)
import Relude
import System.Directory (createDirectoryIfMissing, doesFileExist)
import Text.URI (mkURI)

askCache :: (MonadReader env m, Has env Cache) => m Cache
askCache :: forall env (m :: * -> *).
(MonadReader env m, Has env Cache) =>
m Cache
askCache = m Cache
forall env (m :: * -> *) a. (MonadReader env m, Has env a) => m a
askEnv

data Registry = Registry
  { Registry -> Name
currentEnv :: Name,
    Registry -> Map PkgName Versions
versions :: Map PkgName Versions
  }
  deriving ((forall x. Registry -> Rep Registry x)
-> (forall x. Rep Registry x -> Registry) -> Generic Registry
forall x. Rep Registry x -> Registry
forall x. Registry -> Rep Registry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Registry -> Rep Registry x
from :: forall x. Registry -> Rep Registry x
$cto :: forall x. Rep Registry x -> Registry
to :: forall x. Rep Registry x -> Registry
Generic, Int -> Registry -> ShowS
[Registry] -> ShowS
Registry -> FilePath
(Int -> Registry -> ShowS)
-> (Registry -> FilePath) -> ([Registry] -> ShowS) -> Show Registry
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Registry -> ShowS
showsPrec :: Int -> Registry -> ShowS
$cshow :: Registry -> FilePath
show :: Registry -> FilePath
$cshowList :: [Registry] -> ShowS
showList :: [Registry] -> ShowS
Show, Maybe Registry
Value -> Parser [Registry]
Value -> Parser Registry
(Value -> Parser Registry)
-> (Value -> Parser [Registry])
-> Maybe Registry
-> FromJSON Registry
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Registry
parseJSON :: Value -> Parser Registry
$cparseJSONList :: Value -> Parser [Registry]
parseJSONList :: Value -> Parser [Registry]
$comittedField :: Maybe Registry
omittedField :: Maybe Registry
FromJSON, [Registry] -> Value
[Registry] -> Encoding
Registry -> Bool
Registry -> Value
Registry -> Encoding
(Registry -> Value)
-> (Registry -> Encoding)
-> ([Registry] -> Value)
-> ([Registry] -> Encoding)
-> (Registry -> Bool)
-> ToJSON Registry
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Registry -> Value
toJSON :: Registry -> Value
$ctoEncoding :: Registry -> Encoding
toEncoding :: Registry -> Encoding
$ctoJSONList :: [Registry] -> Value
toJSONList :: [Registry] -> Value
$ctoEncodingList :: [Registry] -> Encoding
toEncodingList :: [Registry] -> Encoding
$comitField :: Registry -> Bool
omitField :: Registry -> Bool
ToJSON)

newtype Cache = Cache (STM.TVar Registry)

type Versions = NonEmpty Version

type VersionMap = Map PkgName Version

cacheDir :: FilePath
cacheDir :: FilePath
cacheDir = FilePath
".hwm/cache"

path :: FilePath
path :: FilePath
path = FilePath
cacheDir FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/state.json"

initRegistry :: Name -> Registry
initRegistry :: Name -> Registry
initRegistry Name
t = Registry {currentEnv :: Name
currentEnv = Name
t, versions :: Map PkgName Versions
versions = Map PkgName Versions
forall a. Monoid a => a
mempty}

loadCache :: Name -> IO Cache
loadCache :: Name -> IO Cache
loadCache Name
t = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
  Registry
vm <-
    if Bool
exists
      then do
        ByteString
bs <- FilePath -> IO ByteString
BL.readFile FilePath
path
        case ByteString -> Maybe Registry
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
bs of
          Just Registry
vm' -> Registry -> IO Registry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Registry
vm'
          Maybe Registry
Nothing -> Registry -> IO Registry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Registry
initRegistry Name
t)
      else Registry -> IO Registry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Registry
initRegistry Name
t)
  TVar Registry -> Cache
Cache (TVar Registry -> Cache) -> IO (TVar Registry) -> IO Cache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Registry -> IO (TVar Registry)
forall a. a -> IO (TVar a)
STM.newTVarIO Registry
vm

readCache :: Cache -> IO Registry
readCache :: Cache -> IO Registry
readCache (Cache TVar Registry
tvar) = TVar Registry -> IO Registry
forall a. TVar a -> IO a
STM.readTVarIO TVar Registry
tvar

modifyCache :: (MonadIO m) => Cache -> (Registry -> Registry) -> m ()
modifyCache :: forall (m :: * -> *).
MonadIO m =>
Cache -> (Registry -> Registry) -> m ()
modifyCache (Cache TVar Registry
tvar) Registry -> Registry
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Registry -> (Registry -> Registry) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar' TVar Registry
tvar Registry -> Registry
f

saveCache :: Cache -> IO ()
saveCache :: Cache -> IO ()
saveCache Cache
cache = do
  Registry
vm <- Cache -> IO Registry
readCache Cache
cache
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
cacheDir
  FilePath -> ByteString -> IO ()
BL.writeFile FilePath
path (Registry -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Registry
vm)

getRegistry :: (MonadReader env m, Has env Cache, MonadIO m) => m Registry
getRegistry :: forall env (m :: * -> *).
(MonadReader env m, Has env Cache, MonadIO m) =>
m Registry
getRegistry = do
  Cache TVar Registry
tvar <- m Cache
forall env (m :: * -> *).
(MonadReader env m, Has env Cache) =>
m Cache
askCache
  IO Registry -> m Registry
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Registry -> m Registry) -> IO Registry -> m Registry
forall a b. (a -> b) -> a -> b
$ TVar Registry -> IO Registry
forall a. TVar a -> IO a
STM.readTVarIO TVar Registry
tvar

updateRegistry :: (MonadReader env m, Has env Cache, MonadIO m) => (Registry -> Registry) -> m ()
updateRegistry :: forall env (m :: * -> *).
(MonadReader env m, Has env Cache, MonadIO m) =>
(Registry -> Registry) -> m ()
updateRegistry Registry -> Registry
f = do
  Cache
c <- m Cache
forall env (m :: * -> *).
(MonadReader env m, Has env Cache) =>
m Cache
askCache
  Cache -> (Registry -> Registry) -> m ()
forall (m :: * -> *).
MonadIO m =>
Cache -> (Registry -> Registry) -> m ()
modifyCache Cache
c Registry -> Registry
f

clearVersions :: (MonadReader env m, Has env Cache, MonadIO m) => m ()
clearVersions :: forall env (m :: * -> *).
(MonadReader env m, Has env Cache, MonadIO m) =>
m ()
clearVersions = (Registry -> Registry) -> m ()
forall env (m :: * -> *).
(MonadReader env m, Has env Cache, MonadIO m) =>
(Registry -> Registry) -> m ()
updateRegistry (\Registry
reg -> Registry
reg {versions = mempty})

getReq :: (Url s, Option s) -> Req LbsResponse
getReq :: forall (s :: Scheme). (Url s, Option s) -> Req LbsResponse
getReq (Url s
u, Option s
o) = GET
-> Url s
-> NoReqBody
-> Proxy LbsResponse
-> Option s
-> Req LbsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url s
u NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse Option s
o

parse :: (MonadError Issue m) => Text -> m (Req LbsResponse)
parse :: forall (m :: * -> *).
MonadError Issue m =>
Name -> m (Req LbsResponse)
parse Name
url = do
  Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri <- m (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
    -> m (Either
            (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> Maybe
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> m (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Issue
-> m (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue
 -> m (Either
         (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> Issue
-> m (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a b. (a -> b) -> a -> b
$ FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString (FilePath -> Issue) -> FilePath -> Issue
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid Endpoint: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> FilePath
forall a. ToString a => a -> FilePath
toString Name
url FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"!") Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> m (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe URI
forall (m :: * -> *). MonadThrow m => Name -> m URI
mkURI Name
url Maybe URI
-> (URI
    -> Maybe
         (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> Maybe
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= URI
-> Maybe
     (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
     (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
useURI)
  Req LbsResponse -> m (Req LbsResponse)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Url 'Http, Option 'Http) -> Req LbsResponse)
-> ((Url 'Https, Option 'Https) -> Req LbsResponse)
-> Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> Req LbsResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Url 'Http, Option 'Http) -> Req LbsResponse
forall (s :: Scheme). (Url s, Option s) -> Req LbsResponse
getReq (Url 'Https, Option 'Https) -> Req LbsResponse
forall (s :: Scheme). (Url s, Option s) -> Req LbsResponse
getReq Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri)

http :: (MonadError Issue m, MonadIO m) => Text -> [Text] -> m BL.ByteString
http :: forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
Name -> [Name] -> m ByteString
http Name
dom [Name]
p = do
  Req LbsResponse
request <- Name -> m (Req LbsResponse)
forall (m :: * -> *).
MonadError Issue m =>
Name -> m (Req LbsResponse)
parse (Name -> [Name] -> Name
genUrl Name
dom [Name]
p)
  LbsResponse -> ByteString
LbsResponse -> HttpResponseBody LbsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody (LbsResponse -> ByteString) -> m LbsResponse -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LbsResponse -> m LbsResponse
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HttpConfig -> Req LbsResponse -> IO LbsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig Req LbsResponse
request)

hackage :: (MonadIO m, MonadError Issue m) => Text -> m (Map Name (NonEmpty Version))
hackage :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Name -> m (Map Name Versions)
hackage Name
name = Name -> [Name] -> m ByteString
forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
Name -> [Name] -> m ByteString
http Name
"https://hackage.haskell.org/package" [Name -> Name
forall a. Format a => a -> Name
format Name
name, Name
"preferred.json"] m ByteString
-> (ByteString -> m (Map Name Versions)) -> m (Map Name Versions)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> m (Map Name Versions))
-> (Map Name Versions -> m (Map Name Versions))
-> Either FilePath (Map Name Versions)
-> m (Map Name Versions)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Issue -> m (Map Name Versions)
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m (Map Name Versions))
-> (FilePath -> Issue) -> FilePath -> m (Map Name Versions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString) Map Name Versions -> m (Map Name Versions)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath (Map Name Versions) -> m (Map Name Versions))
-> (ByteString -> Either FilePath (Map Name Versions))
-> ByteString
-> m (Map Name Versions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath (Map Name Versions)
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode

getVersions :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> m Versions
getVersions :: forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> m Versions
getVersions PkgName
name = do
  Cache TVar Registry
tvar <- m Cache
forall env (m :: * -> *).
(MonadReader env m, Has env Cache) =>
m Cache
askCache
  Registry
r <- IO Registry -> m Registry
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Registry -> m Registry) -> IO Registry -> m Registry
forall a b. (a -> b) -> a -> b
$ TVar Registry -> IO Registry
forall a. TVar a -> IO a
STM.readTVarIO TVar Registry
tvar
  case PkgName -> Map PkgName Versions -> Maybe Versions
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PkgName
name (Registry -> Map PkgName Versions
versions Registry
r) of
    Just Versions
vs -> Versions -> m Versions
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Versions
vs
    Maybe Versions
Nothing -> do
      Versions
vs <- Name -> m (Map Name Versions)
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Name -> m (Map Name Versions)
hackage (PkgName -> Name
forall a. Format a => a -> Name
format PkgName
name) m (Map Name Versions)
-> (Map Name Versions -> m Versions) -> m Versions
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Name -> Map Name Versions -> m Versions
forall (m :: * -> *) t a.
(MonadError Issue m, Format t, Ord t) =>
Name -> t -> Map t a -> m a
select Name
"Field" Name
"normal-version"
      Cache -> (Registry -> Registry) -> m ()
forall (m :: * -> *).
MonadIO m =>
Cache -> (Registry -> Registry) -> m ()
modifyCache (TVar Registry -> Cache
Cache TVar Registry
tvar) (\Registry
reg -> Registry
reg {versions = Map.singleton name vs <> versions reg})
      Versions -> m Versions
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Versions
vs

prepareDir :: (MonadIO m) => FilePath -> m ()
prepareDir :: forall (m :: * -> *). MonadIO m => FilePath -> m ()
prepareDir FilePath
dir = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir

newtype Snapshot = Snapshot {Snapshot -> Name
snapshotCompiler :: Text}
  deriving (Int -> Snapshot -> ShowS
[Snapshot] -> ShowS
Snapshot -> FilePath
(Int -> Snapshot -> ShowS)
-> (Snapshot -> FilePath) -> ([Snapshot] -> ShowS) -> Show Snapshot
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Snapshot -> ShowS
showsPrec :: Int -> Snapshot -> ShowS
$cshow :: Snapshot -> FilePath
show :: Snapshot -> FilePath
$cshowList :: [Snapshot] -> ShowS
showList :: [Snapshot] -> ShowS
Show)

instance FromJSON Snapshot where
  parseJSON :: Value -> Parser Snapshot
parseJSON = FilePath -> (Object -> Parser Snapshot) -> Value -> Parser Snapshot
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"Snapshot" ((Object -> Parser Snapshot) -> Value -> Parser Snapshot)
-> (Object -> Parser Snapshot) -> Value -> Parser Snapshot
forall a b. (a -> b) -> a -> b
$ \Object
v -> Name -> Snapshot
Snapshot (Name -> Snapshot) -> Parser Name -> Parser Snapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"resolver" Parser Object -> (Object -> Parser Name) -> Parser Name
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"compiler"))

genName :: (MonadError Issue m) => Text -> m [Text]
genName :: forall (m :: * -> *). MonadError Issue m => Name -> m [Name]
genName Name
resolver
  | Just Name
ltsNum <- Name -> Name -> Maybe Name
T.stripPrefix Name
"lts-" Name
resolver = Name -> Name -> Name -> m [Name]
forall {e} {m :: * -> *}.
(MonadError e m, IsString e) =>
Name -> Name -> Name -> m [Name]
buildSegments Name
"lts" Name
"." Name
ltsNum
  | Just Name
nightlyDate <- Name -> Name -> Maybe Name
T.stripPrefix Name
"nightly-" Name
resolver = Name -> Name -> Name -> m [Name]
forall {e} {m :: * -> *}.
(MonadError e m, IsString e) =>
Name -> Name -> Name -> m [Name]
buildSegments Name
"nightly" Name
"-" Name
nightlyDate
  | Bool
otherwise = Issue -> m [Name]
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m [Name]) -> Issue -> m [Name]
forall a b. (a -> b) -> a -> b
$ FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString (FilePath -> Issue) -> FilePath -> Issue
forall a b. (a -> b) -> a -> b
$ FilePath
"Unsupported resolver: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> FilePath
forall a. ToString a => a -> FilePath
toString Name
resolver
  where
    buildSegments :: Name -> Name -> Name -> m [Name]
buildSegments Name
prefix Name
delimiter Name
value =
      case [Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (HasCallStack => Name -> Name -> [Name]
Name -> Name -> [Name]
T.splitOn Name
delimiter Name
value) of
        Maybe (NonEmpty Name)
Nothing -> e -> m [Name]
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m [Name]) -> e -> m [Name]
forall a b. (a -> b) -> a -> b
$ FilePath -> e
forall a. IsString a => FilePath -> a
fromString (FilePath -> e) -> FilePath -> e
forall a b. (a -> b) -> a -> b
$ FilePath
"Malformed resolver: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> FilePath
forall a. ToString a => a -> FilePath
toString Name
resolver
        Just NonEmpty Name
parts ->
          let segments :: [Name]
segments = NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Name
parts
              lastPart :: Name
lastPart = NonEmpty Name -> Name
forall a. NonEmpty a -> a
NE.last NonEmpty Name
parts
           in [Name] -> m [Name]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
prefix Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
segments [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name
lastPart Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
".yaml"])

getSnapshotGHC :: (MonadIO m, MonadError Issue m) => Text -> m Version
getSnapshotGHC :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Name -> m Version
getSnapshotGHC Name
name = do
  [Name]
pathSegments <- Name -> m [Name]
forall (m :: * -> *). MonadError Issue m => Name -> m [Name]
genName Name
name
  Result Issue ByteString
body <- ResultT m ByteString -> m (Result Issue ByteString)
forall (m :: * -> *) a. ResultT m a -> m (Result Issue a)
runResultT (Name -> [Name] -> ResultT m ByteString
forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
Name -> [Name] -> m ByteString
http Name
"https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master" [Name]
pathSegments)
  case Result Issue ByteString
body of
    Failure {NonEmpty Issue
failure :: NonEmpty Issue
failure :: forall er a. Result er a -> NonEmpty er
failure} -> Issue -> m Version
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m Version) -> Issue -> m Version
forall a b. (a -> b) -> a -> b
$ FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString (FilePath -> Issue) -> FilePath -> Issue
forall a b. (a -> b) -> a -> b
$ FilePath
"HTTP Error: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonEmpty Issue -> FilePath
forall b a. (Show a, IsString b) => a -> b
show NonEmpty Issue
failure
    Success {ByteString
result :: ByteString
result :: forall er a. Result er a -> a
result} -> case ByteString -> Either ParseException Snapshot
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' (ByteString -> ByteString
BL.toStrict ByteString
result) of
      Left ParseException
err -> Issue -> m Version
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m Version) -> Issue -> m Version
forall a b. (a -> b) -> a -> b
$ FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString (FilePath -> Issue) -> FilePath -> Issue
forall a b. (a -> b) -> a -> b
$ FilePath
"Snapshot Error: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ParseException -> FilePath
prettyPrintParseException ParseException
err
      Right Snapshot
snapshot -> (FilePath -> m Version)
-> (Version -> m Version) -> Either FilePath Version -> m Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Issue -> m Version
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m Version)
-> (FilePath -> Issue) -> FilePath -> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Issue
forall a. IsString a => FilePath -> a
fromString) Version -> m Version
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Either FilePath Version
forall (m :: * -> *). MonadFail m => Name -> m Version
parseGHCVersion (Snapshot -> Name
snapshotCompiler Snapshot
snapshot))