Remove URLSource from Settings
This commit is contained in:
parent
f5a2db6719
commit
8a1bd45ffe
@ -161,7 +161,7 @@ validateTarballs dls = do
|
||||
|
||||
where
|
||||
downloadAll dli = do
|
||||
let settings = Settings True GHCupURL False
|
||||
let settings = Settings True False
|
||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
|
@ -454,9 +454,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} =
|
||||
let cache = optCache
|
||||
urlSource = maybe GHCupURL OwnSource optUrlSource
|
||||
noVerify = optNoVerify
|
||||
let cache = optCache
|
||||
noVerify = optNoVerify
|
||||
in Settings { .. }
|
||||
|
||||
|
||||
@ -592,7 +591,8 @@ main = do
|
||||
( runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[JSONError , DownloadFailed]
|
||||
$ liftE getDownloads
|
||||
$ liftE
|
||||
$ getDownloads (maybe GHCupURL OwnSource optUrlSource)
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
@ -607,7 +607,7 @@ main = do
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBin dls v Nothing
|
||||
liftE $ installGHCBin dls v optPlatform
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
@ -630,7 +630,7 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installCabalBin dls v Nothing
|
||||
liftE $ installCabalBin dls v optPlatform
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
|
15
lib/GHCup.hs
15
lib/GHCup.hs
@ -404,19 +404,18 @@ rmGHCVer ver = do
|
||||
------------------
|
||||
|
||||
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diURLSource <- lift $ getUrlSource
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
|
@ -93,14 +93,13 @@ getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
|
||||
getDownloads = do
|
||||
urlSource <- lift getUrlSource
|
||||
=> URLSource
|
||||
-> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
|
||||
getDownloads urlSource = do
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
@ -122,18 +121,18 @@ getDownloads = do
|
||||
--
|
||||
-- Always save the local file with the mod time of the remote file.
|
||||
smartDl :: forall m1
|
||||
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
smartDl uri' = do
|
||||
let path = view pathL' uri'
|
||||
json_file <- (liftIO $ ghcupCacheDir)
|
||||
@ -204,11 +203,7 @@ getDownloads = do
|
||||
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> GHCupDownloads
|
||||
-> Tool
|
||||
-> Version
|
||||
|
@ -104,21 +104,19 @@ data URLSource = GHCupURL
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
, noVerify :: Bool
|
||||
{ cache :: Bool
|
||||
, noVerify :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diURLSource :: URLSource
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
deriving Show
|
||||
|
||||
@ -141,4 +139,3 @@ data PlatformRequest = PlatformRequest
|
||||
, _rVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
@ -277,9 +277,6 @@ getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
-----------------------
|
||||
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user