{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Download where
#if defined(INTERNAL_DOWNLOADER)
import GHCup.Download.IOStreams
import GHCup.Download.Utils
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger.Internal
import GHCup.Prelude.Process
import GHCup.Version
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( mk )
#endif
import Data.Maybe
import Data.List
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Versions
import Data.Word8 hiding ( isSpace )
import Haskus.Utils.Variant.Excepts
#if defined(INTERNAL_DOWNLOADER)
import Network.Http.Client hiding ( URL )
#endif
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.Environment
import System.Exit
import System.FilePath
import System.IO.Error
import System.IO.Temp
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml.Aeson as Y
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF :: forall env (m :: * -> *).
(FromJSONKey Tool, FromJSONKey Version, FromJSON VersionInfo,
MonadReader env m, HasSettings env, HasDirs env, MonadIO m,
MonadCatch m, HasLog env, MonadThrow m, MonadFail m,
MonadMask m) =>
Excepts
'[DigestError, ContentLengthError, GPGError, JSONError,
DownloadFailed, FileDoesNotExistError]
m
GHCupInfo
getDownloadsF = do
Settings { URLSource
$sel:urlSource:Settings :: Settings -> URLSource
urlSource :: URLSource
urlSource } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
case URLSource
urlSource of
URLSource
GHCupURL -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadFail m,
MonadIO m, MonadCatch m, HasLog env, MonadMask m) =>
URI
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError,
JSONError, FileDoesNotExistError]
m
GHCupInfo
getBase URI
ghcupURL
(OwnSource [Either GHCupInfo URI]
exts) -> do
[GHCupInfo]
ext <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadFail m,
MonadIO m, MonadCatch m, HasLog env, MonadMask m) =>
URI
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError,
JSONError, FileDoesNotExistError]
m
GHCupInfo
getBase) [Either GHCupInfo URI]
exts
forall (m :: * -> *). MonadFail m => [GHCupInfo] -> m GHCupInfo
mergeGhcupInfo [GHCupInfo]
ext
(OwnSpec GHCupInfo
av) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupInfo
av
(AddSource [Either GHCupInfo URI]
exts) -> do
GHCupInfo
base <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadFail m,
MonadIO m, MonadCatch m, HasLog env, MonadMask m) =>
URI
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError,
JSONError, FileDoesNotExistError]
m
GHCupInfo
getBase URI
ghcupURL
[GHCupInfo]
ext <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadFail m,
MonadIO m, MonadCatch m, HasLog env, MonadMask m) =>
URI
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError,
JSONError, FileDoesNotExistError]
m
GHCupInfo
getBase) [Either GHCupInfo URI]
exts
forall (m :: * -> *). MonadFail m => [GHCupInfo] -> m GHCupInfo
mergeGhcupInfo (GHCupInfo
baseforall a. a -> [a] -> [a]
:[GHCupInfo]
ext)
where
mergeGhcupInfo :: MonadFail m
=> [GHCupInfo]
-> m GHCupInfo
mergeGhcupInfo :: forall (m :: * -> *). MonadFail m => [GHCupInfo] -> m GHCupInfo
mergeGhcupInfo [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mergeGhcupInfo: internal error: need at least one GHCupInfo"
mergeGhcupInfo xs :: [GHCupInfo]
xs@(GHCupInfo{}: [GHCupInfo]
_) =
let newDownloads :: Map Tool (Map GHCTargetVersion VersionInfo)
newDownloads = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (\VersionInfo
_ VersionInfo
b2 -> VersionInfo
b2)) (GHCupInfo -> Map Tool (Map GHCTargetVersion VersionInfo)
_ghcupDownloads forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GHCupInfo]
xs)
newGlobalTools :: Map GlobalTool DownloadInfo
newGlobalTools = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (\DownloadInfo
_ DownloadInfo
a2 -> DownloadInfo
a2 ) (GHCupInfo -> Map GlobalTool DownloadInfo
_globalTools forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GHCupInfo]
xs)
newToolReqs :: Map Tool (Map (Maybe Version) PlatformReqSpec)
newToolReqs = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (\PlatformReqSpec
_ PlatformReqSpec
b2 -> PlatformReqSpec
b2)) (GHCupInfo -> Map Tool (Map (Maybe Version) PlatformReqSpec)
_toolRequirements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GHCupInfo]
xs)
in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map Tool (Map (Maybe Version) PlatformReqSpec)
-> Map Tool (Map GHCTargetVersion VersionInfo)
-> Map GlobalTool DownloadInfo
-> GHCupInfo
GHCupInfo Map Tool (Map (Maybe Version) PlatformReqSpec)
newToolReqs Map Tool (Map GHCTargetVersion VersionInfo)
newDownloads Map GlobalTool DownloadInfo
newGlobalTools
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
URI -> m String
yamlFromCache URI
uri = do
Dirs{String
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> String
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: String
baseDir :: GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath -> String
fromGHCupPath GHCupPath
cacheDir String -> String -> String
</> (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
urlBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. Lens' (URIRef a) ByteString
pathL' forall a b. (a -> b) -> a -> b
$ URI
uri))
etagsFile :: FilePath -> FilePath
etagsFile :: String -> String
etagsFile = (String -> String -> String
<.> String
"etags")
getBase :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
, MonadIO m
, MonadCatch m
, HasLog env
, MonadMask m
)
=> URI
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
getBase :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadFail m,
MonadIO m, MonadCatch m, HasLog env, MonadMask m) =>
URI
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError,
JSONError, FileDoesNotExistError]
m
GHCupInfo
getBase URI
uri = do
Settings { Bool
$sel:noNetwork:Settings :: Settings -> Bool
noNetwork :: Bool
noNetwork, Downloader
$sel:downloader:Settings :: Settings -> Downloader
downloader :: Downloader
downloader, MetaMode
$sel:metaMode:Settings :: Settings -> MetaMode
metaMode :: MetaMode
metaMode } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
Maybe String
mYaml <- if Bool
noNetwork Bool -> Bool -> Bool
&& forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' URI Scheme
uriSchemeL' forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' Scheme ByteString
schemeBSL') URI
uri forall a. Eq a => a -> a -> Bool
/= ByteString
"file"
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> case MetaMode
metaMode of
MetaMode
Strict -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
MetaMode
Lax -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadMask m, MonadCatch m,
MonadIO m) =>
String -> Downloader -> m ()
warnCache (forall e. Exception e => e -> String
displayException IOException
e) Downloader
downloader) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es' :: [*]) (es'' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es',
LiftVariant es'' es') =>
(e -> Excepts es'' m a) -> Excepts es m a -> Excepts es' m a
catchE @_ @_ @'[DownloadFailed] (\e :: DownloadFailed
e@(DownloadFailed V xs
_) -> case MetaMode
metaMode of
MetaMode
Strict -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE DownloadFailed
e
MetaMode
Lax -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadMask m, MonadCatch m,
MonadIO m) =>
String -> Downloader -> m ()
warnCache (forall e. (Pretty e, HFErrorProject e) => e -> String
prettyHFError DownloadFailed
e) Downloader
downloader) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m1 :: * -> *) env1.
(MonadReader env1 m1, HasDirs env1, HasSettings env1,
MonadCatch m1, MonadIO m1, MonadFail m1, HasLog env1,
MonadMask m1) =>
URI
-> Excepts
'[DownloadFailed, DigestError, ContentLengthError, GPGError]
m1
String
smartDl
forall a b. (a -> b) -> a -> b
$ URI
uri
String
actualYaml <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
URI -> m String
yamlFromCache URI
uri) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
mYaml
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Decoding yaml at: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
actualYaml
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (es :: [*]) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadMask m, MonadCatch m,
MonadIO m) =>
String -> m ()
onError String
actualYaml)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e' e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
(e' -> e) -> m (Either e' a) -> Excepts es m a
lEM' @_ @_ @'[JSONError] (\(forall e. Exception e => e -> String
displayException -> String
e) -> String -> JSONError
JSONDecodeError forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
e, String
"Consider removing " forall a. Semigroup a => a -> a -> a
<> String
actualYaml forall a. Semigroup a => a -> a -> a
<> String
" manually."])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => String -> IO (Either ParseException a)
Y.decodeFileEither
forall a b. (a -> b) -> a -> b
$ String
actualYaml
where
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadMask m, MonadCatch m,
MonadIO m) =>
String -> m ()
onError String
fp = do
let efp :: String
efp = String -> String
etagsFile String
fp
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Couldn't remove file " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
efp forall a. Semigroup a => a -> a -> a
<> Text
", error was: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall e. Exception e => e -> String
displayException IOException
e))
(forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile String
efp)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ String -> UTCTime -> IO ()
setAccessTime String
fp (POSIXTime -> UTCTime
posixSecondsToUTCTime (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int Int
0))
warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
warnCache :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadMask m, MonadCatch m,
MonadIO m) =>
String -> Downloader -> m ()
warnCache String
s Downloader
downloader' = do
let tryDownloder :: Text
tryDownloder = case Downloader
downloader' of
Downloader
Curl -> Text
"Wget"
Downloader
Wget -> Text
"Curl"
#if defined(INTERNAL_DOWNLOADER)
Internal -> "Curl"
#endif
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Could not get download info, trying cached version (this may not be recent!)" forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<>
Text
"If this problem persists, consider switching downloader via: " forall a. Semigroup a => a -> a -> a
<> Text
"\n " forall a. Semigroup a => a -> a -> a
<>
Text
"ghcup config set downloader " forall a. Semigroup a => a -> a -> a
<> Text
tryDownloder
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Error was: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
s
smartDl :: forall m1 env1
. ( MonadReader env1 m1
, HasDirs env1
, HasSettings env1
, MonadCatch m1
, MonadIO m1
, MonadFail m1
, HasLog env1
, MonadMask m1
)
=> URI
-> Excepts
'[ DownloadFailed
, DigestError
, ContentLengthError
, GPGError
]
m1
FilePath
smartDl :: forall (m1 :: * -> *) env1.
(MonadReader env1 m1, HasDirs env1, HasSettings env1,
MonadCatch m1, MonadIO m1, MonadFail m1, HasLog env1,
MonadMask m1) =>
URI
-> Excepts
'[DownloadFailed, DigestError, ContentLengthError, GPGError]
m1
String
smartDl URI
uri' = do
String
json_file <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
URI -> m String
yamlFromCache URI
uri'
let scheme :: ByteString
scheme = forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' URI Scheme
uriSchemeL' forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' Scheme ByteString
schemeBSL') URI
uri'
Bool
e <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
json_file
UTCTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Dirs { GHCupPath
cacheDir :: GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
cacheDir } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
Settings { Integer
$sel:metaCache:Settings :: Settings -> Integer
metaCache :: Integer
metaCache } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
if | ByteString
scheme forall a. Eq a => a -> a -> Bool
== ByteString
"file" -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> String
-> Maybe String
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
download URI
uri' forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (GHCupPath -> String
fromGHCupPath GHCupPath
cacheDir) forall a. Maybe a
Nothing Bool
True
| Bool
e -> do
POSIXTime
accessTime <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> POSIXTime
utcTimeToPOSIXSeconds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getAccessTime String
json_file
let sinceLastAccess :: POSIXTime
sinceLastAccess = UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
currentTime forall a. Num a => a -> a -> a
- POSIXTime
accessTime
let cacheInterval :: POSIXTime
cacheInterval = forall a. Num a => Integer -> a
fromInteger Integer
metaCache
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"last access was " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show POSIXTime
sinceLastAccess) forall a. Semigroup a => a -> a -> a
<> Text
" ago, cache interval is " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show POSIXTime
cacheInterval)
if | Integer
metaCache forall a. Ord a => a -> a -> Bool
<= Integer
0 -> UTCTime
-> String
-> Excepts
'[DownloadFailed, DigestError, ContentLengthError, GPGError]
m1
String
dlWithMod UTCTime
currentTime String
json_file
| (POSIXTime
sinceLastAccess forall a. Ord a => a -> a -> Bool
> POSIXTime
cacheInterval) ->
UTCTime
-> String
-> Excepts
'[DownloadFailed, DigestError, ContentLengthError, GPGError]
m1
String
dlWithMod UTCTime
currentTime String
json_file
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
json_file
| Bool
otherwise -> UTCTime
-> String
-> Excepts
'[DownloadFailed, DigestError, ContentLengthError, GPGError]
m1
String
dlWithMod UTCTime
currentTime String
json_file
where
dlWithMod :: UTCTime
-> String
-> Excepts
'[DownloadFailed, DigestError, ContentLengthError, GPGError]
m1
String
dlWithMod UTCTime
modTime String
json_file = do
let (String
dir, String
fn) = String -> (String, String)
splitFileName String
json_file
String
f <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> String
-> Maybe String
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
download URI
uri' (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k (is :: [*]) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over forall a. Lens' (URIRef a) ByteString
pathL' (forall a. Semigroup a => a -> a -> a
<> ByteString
".sig") URI
uri') forall a. Maybe a
Nothing forall a. Maybe a
Nothing String
dir (forall a. a -> Maybe a
Just String
fn) Bool
True
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"setModificationTime failed with: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall e. Exception e => e -> String
displayException IOException
e)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> UTCTime -> IO ()
setModificationTime String
f UTCTime
modTime
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Text
"setAccessTime failed with: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall e. Exception e => e -> String
displayException IOException
e)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> UTCTime -> IO ()
setAccessTime String
f UTCTime
modTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
f
getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> Version
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo :: forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasGHCupInfo env) =>
Tool -> Version -> Excepts '[NoDownload] m DownloadInfo
getDownloadInfo Tool
t Version
v = forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasGHCupInfo env) =>
Tool -> GHCTargetVersion -> Excepts '[NoDownload] m DownloadInfo
getDownloadInfo' Tool
t (Version -> GHCTargetVersion
mkTVer Version
v)
getDownloadInfo' :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> GHCTargetVersion
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo' :: forall env (m :: * -> *).
(MonadReader env m, HasPlatformReq env, HasGHCupInfo env) =>
Tool -> GHCTargetVersion -> Excepts '[NoDownload] m DownloadInfo
getDownloadInfo' Tool
t GHCTargetVersion
v = do
(PlatformRequest Architecture
a Platform
p Maybe Versioning
mv) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "pfreq" A_Lens env PlatformRequest) =>
m PlatformRequest
getPlatformReq
GHCupInfo { $sel:_ghcupDownloads:GHCupInfo :: GHCupInfo -> Map Tool (Map GHCTargetVersion VersionInfo)
_ghcupDownloads = Map Tool (Map GHCTargetVersion VersionInfo)
dls } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) =>
m GHCupInfo
getGHCupInfo
let distro_preview :: (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview Platform -> Platform
f Maybe Versioning -> Maybe Versioning
g =
let platformVersionSpec :: Maybe PlatformVersionSpec
platformVersionSpec =
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Tool
t forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix GHCTargetVersion
v forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' VersionInfo ArchitectureSpec
viArch forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Architecture
a forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix (Platform -> Platform
f Platform
p)) Map Tool (Map GHCTargetVersion VersionInfo)
dls
mv' :: Maybe Versioning
mv' = Maybe Versioning -> Maybe Versioning
g Maybe Versioning
mv
in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
(\(Maybe VersionRange
mverRange, DownloadInfo
_) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall a. Maybe a -> Bool
isNothing Maybe Versioning
mv')
(\VersionRange
range -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Versioning -> VersionRange -> Bool
`versionRange` VersionRange
range) Maybe Versioning
mv')
Maybe VersionRange
mverRange
)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PlatformVersionSpec
platformVersionSpec
with_distro :: Maybe DownloadInfo
with_distro = (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview forall a. a -> a
id forall a. a -> a
id
without_distro_ver :: Maybe DownloadInfo
without_distro_ver = (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview forall a. a -> a
id (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
without_distro :: Maybe DownloadInfo
without_distro = (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview (forall k (is :: [*]) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Prism' Platform LinuxDistro
_Linux LinuxDistro
UnknownLinux) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE NoDownload
NoDownload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(case Platform
p of
Linux LinuxDistro
Alpine -> Maybe DownloadInfo
with_distro forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DownloadInfo
without_distro_ver
Platform
_ -> Maybe DownloadInfo
with_distro forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DownloadInfo
without_distro_ver forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DownloadInfo
without_distro
)
download :: ( MonadReader env m
, HasSettings env
, HasDirs env
, MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
)
=> URI
-> Maybe URI
-> Maybe T.Text
-> Maybe Integer
-> FilePath
-> Maybe FilePath
-> Bool
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
download :: forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> String
-> Maybe String
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
download URI
rawUri Maybe URI
gpgUri Maybe Text
eDigest Maybe Integer
eCSize String
dest Maybe String
mfn Bool
etags
| ByteString
scheme forall a. Eq a => a -> a -> Bool
== ByteString
"https" = forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
dl
| ByteString
scheme forall a. Eq a => a -> a -> Bool
== ByteString
"http" = forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
dl
| ByteString
scheme forall a. Eq a => a -> a -> Bool
== ByteString
"file" = do
let destFile' :: String
destFile' = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe forall a b. (a -> b) -> a -> b
$ forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. Lens' (URIRef a) ByteString
pathL' URI
rawUri
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"using local file: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
destFile'
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Text
eDigest (forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Text -> String -> Excepts '[DigestError] m ()
checkDigest String
destFile')
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
destFile'
| Bool
otherwise = forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed (forall a. a -> V '[a]
variantFromValue UnsupportedScheme
UnsupportedScheme)
where
scheme :: ByteString
scheme = forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' URI Scheme
uriSchemeL' forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Lens' Scheme ByteString
schemeBSL') URI
rawUri
dl :: Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
dl = do
Settings{ DownloadMirrors
$sel:mirrors:Settings :: Settings -> DownloadMirrors
mirrors :: DownloadMirrors
mirrors } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
let uri :: URI
uri = DownloadMirrors -> URI -> URI
applyMirrors DownloadMirrors
mirrors URI
rawUri
String
baseDestFile <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @_ @'[DownloadFailed] forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
URI -> Maybe String -> Excepts '[NoUrlBase] m String
getDestFile URI
uri Maybe String
mfn
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"downloading: " forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef') URI
uri forall a. Semigroup a => a -> a -> a
<> Text
" as file " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
baseDestFile
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
createDirRecursive' String
dest
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException
(forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
String -> m ()
recycleFile (String -> String
tmpFile String
baseDestFile))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError, ContentLengthError] @'[DigestError, ContentLengthError, DownloadFailed, GPGError]
(\V '[GPGError, ProcessError, DownloadFailed, UnsupportedScheme,
DigestError, ContentLengthError]
e' -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
String -> m ()
recycleFile (String -> String
tmpFile String
baseDestFile)
case V '[GPGError, ProcessError, DownloadFailed, UnsupportedScheme,
DigestError, ContentLengthError]
e' of
V e :: GPGError
e@GPGError {} -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE GPGError
e
V e :: DigestError
e@DigestError {} -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE DigestError
e
V '[GPGError, ProcessError, DownloadFailed, UnsupportedScheme,
DigestError, ContentLengthError]
_ -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed V '[GPGError, ProcessError, DownloadFailed, UnsupportedScheme,
DigestError, ContentLengthError]
e')
) forall a b. (a -> b) -> a -> b
$ do
Settings{ Downloader
downloader :: Downloader
$sel:downloader:Settings :: Settings -> Downloader
downloader, Bool
noNetwork :: Bool
$sel:noNetwork:Settings :: Settings -> Bool
noNetwork, GPGSetting
$sel:gpgSetting:Settings :: Settings -> GPGSetting
gpgSetting :: GPGSetting
gpgSetting } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noNetwork forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed (forall c (cs :: [*]). (c :< cs) => c -> V cs
V NoNetwork
NoNetwork :: V '[NoNetwork]))
String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
downloadAction <- case Downloader
downloader of
Downloader
Curl -> do
[String]
o' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getCurlOpts
if Bool
etags
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadMask m,
MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlEtagsDL [String]
o'
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadCatch m, MonadMask m, MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlDL [String]
o'
Downloader
Wget -> do
[String]
o' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getWgetOpts
if Bool
etags
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadMask m,
MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL [String]
o'
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadCatch m, MonadMask m, MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetDL [String]
o'
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
if etags
then pure (\fp -> liftE . internalEtagsDL fp)
else pure (\fp -> liftE . internalDL fp)
#endif
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
downloadAction String
baseDestFile URI
uri
case (Maybe URI
gpgUri, GPGSetting
gpgSetting) of
(Maybe URI
_, GPGSetting
GPGNone) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just URI
gpgUri', GPGSetting
_) -> do
String
gpgDestFile <- forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @_ @'[DownloadFailed] forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
URI -> Maybe String -> Excepts '[NoUrlBase] m String
getDestFile URI
gpgUri' forall a. Maybe a
Nothing
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException
(forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
String -> m ()
recycleFile (String -> String
tmpFile String
gpgDestFile))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
(\V '[GPGError, ProcessError, UnsupportedScheme, DownloadFailed]
e -> if GPGSetting
gpgSetting forall a. Eq a => a -> a -> Bool
== GPGSetting
GPGStrict then forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (forall (xs :: [*]).
(ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs,
Show (V xs), Pretty (V xs)) =>
V xs -> GPGError
GPGError V '[GPGError, ProcessError, UnsupportedScheme, DownloadFailed]
e) else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (forall e. (Pretty e, HFErrorProject e) => e -> String
prettyHFError (forall (xs :: [*]).
(ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs,
Show (V xs), Pretty (V xs)) =>
V xs -> GPGError
GPGError V '[GPGError, ProcessError, UnsupportedScheme, DownloadFailed]
e))
) forall a b. (a -> b) -> a -> b
$ do
[String]
o' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getGpgOpts
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"downloading: " forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef') URI
gpgUri' forall a. Semigroup a => a -> a -> a
<> Text
" as file " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
gpgDestFile
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
downloadAction String
gpgDestFile URI
gpgUri'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"verifying signature of: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
baseDestFile
let args :: [String]
args = [String]
o' forall a. [a] -> [a] -> [a]
++ [String
"--batch", String
"--verify", String
"--quiet", String
"--no-tty", String
gpgDestFile, String
baseDestFile]
CapturedProcess
cp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Maybe String -> m CapturedProcess
executeOut String
"gpg" [String]
args forall a. Maybe a
Nothing
case CapturedProcess
cp of
CapturedProcess { $sel:_exitCode:CapturedProcess :: CapturedProcess -> ExitCode
_exitCode = ExitFailure Int
i, ByteString
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
_stdErr :: ByteString
_stdErr } -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe' ByteString
_stdErr
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (forall (xs :: [*]).
(ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs,
Show (V xs), Pretty (V xs)) =>
V xs -> GPGError
GPGError @'[ProcessError] (forall c (cs :: [*]). (c :< cs) => c -> V cs
V (Int -> String -> [String] -> ProcessError
NonZeroExit Int
i String
"gpg" [String]
args)))
CapturedProcess { ByteString
_stdErr :: ByteString
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
_stdErr } -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decUTF8Safe' ByteString
_stdErr
(Maybe URI, GPGSetting)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Integer
eCSize (forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Integer -> String -> Excepts '[ContentLengthError] m ()
checkCSize String
baseDestFile)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Text
eDigest (forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Text -> String -> Excepts '[DigestError] m ()
checkDigest String
baseDestFile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
baseDestFile
curlDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlDL :: forall (m :: * -> *).
(MonadCatch m, MonadMask m, MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlDL [String]
o' String
destFile (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef' -> Text
uri') = do
let destFileTemp :: String
destFileTemp = String -> String
tmpFile String
destFile
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile String
destFileTemp) forall a b. (a -> b) -> a -> b
$ do
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> m (Either ProcessError ())
exec String
"curl"
([String]
o' forall a. [a] -> [a] -> [a]
++ [String
"-fL", String
"-o", String
destFileTemp, Text -> String
T.unpack Text
uri']
forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Integer
s -> [String
"--max-filesize", forall a. Show a => a -> String
show Integer
s]) Maybe Integer
eCSize
) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
destFileTemp String
destFile
curlEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlEtagsDL :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadMask m,
MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlEtagsDL [String]
o' String
destFile (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef' -> Text
uri') = do
let destFileTemp :: String
destFileTemp = String -> String
tmpFile String
destFile
String
dh <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
emptySystemTempFile String
"curl-header"
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile String
dh) forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile String
destFileTemp) forall a b. (a -> b) -> a -> b
$ do
Maybe Text
metag <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadIO m) =>
String -> m (Maybe Text)
readETag String
destFile
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> m (Either ProcessError ())
exec String
"curl"
([String]
o' forall a. [a] -> [a] -> [a]
++ (if Bool
etags then [String
"--dump-header", String
dh] else [])
forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
t -> [String
"-H", String
"If-None-Match: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t]) Maybe Text
metag
forall a. [a] -> [a] -> [a]
++ [String
"-fL", String
"-o", String
destFileTemp, Text -> String
T.unpack Text
uri']) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
Text
headers <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
dh
case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Text]
T.words forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
getLastHeader forall a b. (a -> b) -> a -> b
$ Text
headers of
Just (Text
http':Text
sc:[Text]
_)
| Text
sc forall a. Eq a => a -> a -> Bool
== Text
"304"
, String -> Text
T.pack String
"HTTP" Text -> Text -> Bool
`T.isPrefixOf` Text
http' -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Status code was 304, not overwriting"
| String -> Text
T.pack String
"HTTP" Text -> Text -> Bool
`T.isPrefixOf` Text
http' -> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Status code was " forall a. Semigroup a => a -> a -> a
<> Text
sc forall a. Semigroup a => a -> a -> a
<> Text
", overwriting"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
destFileTemp String
destFile
Maybe [Text]
_ -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE @_ @'[DownloadFailed] (forall (xs :: [*]).
(HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs,
PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) =>
V xs -> DownloadFailed
DownloadFailed (forall (n :: Natural) (l :: [*]). KnownNat n => Index n l -> V l
toVariantAt @0 (Text -> MalformedHeaders
MalformedHeaders Text
headers)
:: V '[MalformedHeaders]))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
String -> m (Maybe Text) -> m ()
writeEtags String
destFile (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
Text -> m (Maybe Text)
parseEtags Text
headers)
wgetDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetDL :: forall (m :: * -> *).
(MonadCatch m, MonadMask m, MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetDL [String]
o' String
destFile (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef' -> Text
uri') = do
let destFileTemp :: String
destFileTemp = String -> String
tmpFile String
destFile
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile String
destFileTemp) forall a b. (a -> b) -> a -> b
$ do
let opts :: [String]
opts = [String]
o' forall a. [a] -> [a] -> [a]
++ [String
"-O", String
destFileTemp , Text -> String
T.unpack Text
uri']
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
lEM @_ @'[ProcessError] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> m (Either ProcessError ())
exec String
"wget" [String]
opts forall a. Maybe a
Nothing forall a. Maybe a
Nothing
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
destFileTemp String
destFile
wgetEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadMask m,
MonadIO m) =>
[String]
-> String
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL [String]
o' String
destFile (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef' -> Text
uri') = do
let destFileTemp :: String
destFileTemp = String -> String
tmpFile String
destFile
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile String
destFileTemp) forall a b. (a -> b) -> a -> b
$ do
Maybe Text
metag <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadIO m) =>
String -> m (Maybe Text)
readETag String
destFile
let opts :: [String]
opts = [String]
o' forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
t -> [String
"--header", String
"If-None-Match: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t]) Maybe Text
metag
forall a. [a] -> [a] -> [a]
++ [String
"-q", String
"-S", String
"-O", String
destFileTemp , Text -> String
T.unpack Text
uri']
CapturedProcess {ExitCode
_exitCode :: ExitCode
$sel:_exitCode:CapturedProcess :: CapturedProcess -> ExitCode
_exitCode, ByteString
_stdErr :: ByteString
$sel:_stdErr:CapturedProcess :: CapturedProcess -> ByteString
_stdErr} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> [String] -> Maybe String -> m CapturedProcess
executeOut String
"wget" [String]
opts forall a. Maybe a
Nothing
case ExitCode
_exitCode of
ExitCode
ExitSuccess -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
destFileTemp String
destFile
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
String -> m (Maybe Text) -> m ()
writeEtags String
destFile (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
Text -> m (Maybe Text)
parseEtags (ByteString -> Text
decUTF8Safe' ByteString
_stdErr))
ExitFailure Int
i'
| Int
i' forall a. Eq a => a -> a -> Bool
== Int
8
, Just Text
_ <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> Text
T.pack String
"304 Not Modified" Text -> Text -> Bool
`T.isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe' forall a b. (a -> b) -> a -> b
$ ByteString
_stdErr
-> do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Not modified, skipping download"
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
String -> m (Maybe Text) -> m ()
writeEtags String
destFile (forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
Text -> m (Maybe Text)
parseEtags (ByteString -> Text
decUTF8Safe' ByteString
_stdErr))
| Bool
otherwise -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Int -> String -> [String] -> ProcessError
NonZeroExit Int
i' String
"wget" [String]
opts)
#if defined(INTERNAL_DOWNLOADER)
internalDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
$ downloadToFile https host fullPath port destFileTemp mempty eCSize
liftIO $ renameFile destFileTemp destFile
internalEtagsDL :: ( MonadReader env m
, HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalEtagsDL destFile uri' = do
let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFileTemp addHeaders eCSize
liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
#endif
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile :: forall (m :: * -> *).
Monad m =>
URI -> Maybe String -> Excepts '[NoUrlBase] m String
getDestFile URI
uri' Maybe String
mfn' =
let path :: ByteString
path = forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. Lens' (URIRef a) ByteString
pathL' URI
uri'
in case Maybe String
mfn' of
Just String
fn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
dest String -> String -> String
</> String
fn)
Maybe String
Nothing
| let urlBase :: String
urlBase = Text -> String
T.unpack (ByteString -> Text
decUTF8Safe (ByteString -> ByteString
urlBaseName ByteString
path))
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
urlBase) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
dest String -> String -> String
</> String
urlBase)
| Bool
otherwise -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ Text -> NoUrlBase
NoUrlBase (ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef' forall a b. (a -> b) -> a -> b
$ URI
uri')
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
Text -> m (Maybe Text)
parseEtags Text
stderr = do
let mEtag :: Maybe Text
mEtag = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Text
line -> String -> Text
T.pack String
"etag:" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.toLower Text
line) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
getLastHeader forall a b. (a -> b) -> a -> b
$ Text
stderr
case Text -> [Text]
T.words forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mEtag of
(Just []) -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Couldn't parse etags, no input: "
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
(Just [Text
_, Text
etag']) -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Parsed etag: " forall a. Semigroup a => a -> a -> a
<> Text
etag'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Text
etag')
(Just [Text]
xs) -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"Couldn't parse etags, unexpected input: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
xs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Maybe [Text]
Nothing -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"No etags header found"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadIO m, MonadThrow m) =>
String -> m (Maybe Text) -> m ()
writeEtags String
destFile m (Maybe Text)
getTags = do
m (Maybe Text)
getTags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Text
t -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Writing etagsFile " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
etagsFile String
destFile)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile (String -> String
etagsFile String
destFile) Text
t
Maybe Text
Nothing ->
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"No etags files written"
readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag :: forall env (m :: * -> *).
(MonadReader env m, HasLog env, MonadCatch m, MonadIO m) =>
String -> m (Maybe Text)
readETag String
fp = do
Bool
e <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
fp
if Bool
e
then do
Either SomeException Text
rE <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
stripNewline' forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile (String -> String
etagsFile String
fp)
case Either SomeException Text
rE of
(Right Text
et) -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Read etag: " forall a. Semigroup a => a -> a -> a
<> Text
et
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Text
et)
(Left SomeException
_) -> do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Etag file doesn't exist (yet)"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"Skipping and deleting etags file because destination file " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
fp forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> m ()
rmFile (String -> String
etagsFile String
fp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
downloadCached :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadResource m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> Maybe FilePath
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
downloadCached :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadResource m, MonadThrow m, HasLog env, MonadIO m,
MonadUnliftIO m) =>
DownloadInfo
-> Maybe String
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
downloadCached DownloadInfo
dli Maybe String
mfn = do
Settings{ Bool
$sel:cache:Settings :: Settings -> Bool
cache :: Bool
cache } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
case Bool
cache of
Bool
True -> forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> Maybe String
-> Maybe String
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
downloadCached' DownloadInfo
dli Maybe String
mfn forall a. Maybe a
Nothing
Bool
False -> do
GHCupPath
tmp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> String
-> Maybe String
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
download (DownloadInfo -> URI
_dlUri DownloadInfo
dli) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (DownloadInfo -> Text
_dlHash DownloadInfo
dli)) (DownloadInfo -> Maybe Integer
_dlCSize DownloadInfo
dli) (GHCupPath -> String
fromGHCupPath GHCupPath
tmp) Maybe String
outputFileName Bool
False
where
outputFileName :: Maybe String
outputFileName = Maybe String
mfn forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DownloadInfo -> Maybe String
_dlOutput DownloadInfo
dli
downloadCached' :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
=> DownloadInfo
-> Maybe FilePath
-> Maybe FilePath
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
downloadCached' :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m) =>
DownloadInfo
-> Maybe String
-> Maybe String
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
downloadCached' DownloadInfo
dli Maybe String
mfn Maybe String
mDestDir = do
Dirs { GHCupPath
cacheDir :: GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
cacheDir } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let destDir :: String
destDir = forall a. a -> Maybe a -> a
fromMaybe (GHCupPath -> String
fromGHCupPath GHCupPath
cacheDir) Maybe String
mDestDir
let fn :: String
fn = forall a. a -> Maybe a -> a
fromMaybe ((Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe) forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
urlBaseName forall a b. (a -> b) -> a -> b
$ forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' DownloadInfo URI
dlUri forall k l m (is :: [*]) (js :: [*]) (ks :: [*]) s t u v a b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. Lens' (URIRef a) ByteString
pathL') DownloadInfo
dli) Maybe String
outputFileName
let cachfile :: String
cachfile = String
destDir String -> String -> String
</> String
fn
Bool
fileExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
cachfile
if
| Bool
fileExists -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo (Maybe Integer)
dlCSize DownloadInfo
dli) forall a b. (a -> b) -> a -> b
$ \Integer
s -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Integer -> String -> Excepts '[ContentLengthError] m ()
checkCSize Integer
s String
cachfile
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Text -> String -> Excepts '[DigestError] m ()
checkDigest (forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo Text
dlHash DownloadInfo
dli) String
cachfile
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
cachfile
| Bool
otherwise -> forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasDirs env, MonadMask m,
MonadThrow m, HasLog env, MonadIO m) =>
URI
-> Maybe URI
-> Maybe Text
-> Maybe Integer
-> String
-> Maybe String
-> Bool
-> Excepts
'[DigestError, ContentLengthError, DownloadFailed, GPGError]
m
String
download (DownloadInfo -> URI
_dlUri DownloadInfo
dli) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (DownloadInfo -> Text
_dlHash DownloadInfo
dli)) (DownloadInfo -> Maybe Integer
_dlCSize DownloadInfo
dli) String
destDir Maybe String
outputFileName Bool
False
where
outputFileName :: Maybe String
outputFileName = Maybe String
mfn forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DownloadInfo -> Maybe String
_dlOutput DownloadInfo
dli
checkDigest :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
, HasLog env
)
=> T.Text
-> FilePath
-> Excepts '[DigestError] m ()
checkDigest :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Text -> String -> Excepts '[DigestError] m ()
checkDigest Text
eDigest String
file = do
Settings{ Bool
$sel:noVerify:Settings :: Settings -> Bool
noVerify :: Bool
noVerify } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
let verify :: Bool
verify = Bool -> Bool
not Bool
noVerify
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verify forall a b. (a -> b) -> a -> b
$ do
let p' :: String
p' = String -> String
takeFileName String
file
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"verifying digest of: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p'
ByteString
c <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
L.readFile String
file
Text
cDigest <- forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
E.decodeUtf8' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA256.hashlazy forall a b. (a -> b) -> a -> b
$ ByteString
c
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Text
cDigest forall a. Eq a => a -> a -> Bool
/= Text
eDigest) Bool -> Bool -> Bool
&& Bool
verify) forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (String -> Text -> Text -> DigestError
DigestError String
file Text
cDigest Text
eDigest)
checkCSize :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadThrow m
, HasLog env
)
=> Integer
-> FilePath
-> Excepts '[ContentLengthError] m ()
checkCSize :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasSettings env, MonadIO m,
MonadThrow m, HasLog env) =>
Integer -> String -> Excepts '[ContentLengthError] m ()
checkCSize Integer
eCSize String
file = do
Settings{ Bool
noVerify :: Bool
$sel:noVerify:Settings :: Settings -> Bool
noVerify } <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
let verify :: Bool
verify = Bool -> Bool
not Bool
noVerify
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verify forall a b. (a -> b) -> a -> b
$ do
let p' :: String
p' = String -> String
takeFileName String
file
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"verifying content length of: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p'
Integer
cSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Integer
getFileSize String
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Integer
eCSize forall a. Eq a => a -> a -> Bool
/= Integer
cSize) Bool -> Bool -> Bool
&& Bool
verify) forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Maybe String -> Maybe Integer -> Integer -> ContentLengthError
ContentLengthError (forall a. a -> Maybe a
Just String
file) (forall a. a -> Maybe a
Just Integer
cSize) Integer
eCSize)
getCurlOpts :: IO [String]
getCurlOpts :: IO [String]
getCurlOpts =
String -> IO (Maybe String)
lookupEnv String
"GHCUP_CURL_OPTS" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just String
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
r
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
getWgetOpts :: IO [String]
getWgetOpts :: IO [String]
getWgetOpts =
String -> IO (Maybe String)
lookupEnv String
"GHCUP_WGET_OPTS" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just String
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
r
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
getGpgOpts :: IO [String]
getGpgOpts :: IO [String]
getGpgOpts =
String -> IO (Maybe String)
lookupEnv String
"GHCUP_GPG_OPTS" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just String
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
r
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
urlBaseName :: ByteString
-> ByteString
urlBaseName :: ByteString -> ByteString
urlBaseName = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.breakEnd (forall a. Eq a => a -> a -> Bool
== Word8
_slash) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> ByteString
urlDecode Bool
False
getLastHeader :: T.Text -> T.Text
= [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> a
lastDef [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\[Text]
x -> Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
x)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Text
""] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.stripEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
tmpFile :: FilePath -> FilePath
tmpFile :: String -> String
tmpFile = (String -> String -> String
<.> String
"tmp")
applyMirrors :: DownloadMirrors -> URI -> URI
applyMirrors :: DownloadMirrors -> URI -> URI
applyMirrors (DM Map Text DownloadMirror
ms) uri :: URI
uri@(URI { uriAuthority :: URI -> Maybe Authority
uriAuthority = Just (Authority { authorityHost :: Authority -> Host
authorityHost = Host ByteString
host }) }) =
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ByteString -> Text
decUTF8Safe ByteString
host) Map Text DownloadMirror
ms of
Maybe DownloadMirror
Nothing -> URI
uri
Just (DownloadMirror Authority
auth (Just Text
prefix)) ->
URI
uri { uriAuthority :: Maybe Authority
uriAuthority = forall a. a -> Maybe a
Just Authority
auth
, uriPath :: ByteString
uriPath = Text -> ByteString
E.encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"/" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
prefix forall a. Semigroup a => a -> a -> a
<> (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decUTF8Safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ByteString
uriPath forall a b. (a -> b) -> a -> b
$ URI
uri))
}
Just (DownloadMirror Authority
auth Maybe Text
Nothing) ->
URI
uri { uriAuthority :: Maybe Authority
uriAuthority = forall a. a -> Maybe a
Just Authority
auth }
applyMirrors DownloadMirrors
_ URI
uri = URI
uri