{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# 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.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
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.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.Bifunctor
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( CI )
#endif
import Data.List ( find )
import Data.Maybe
import Data.String.Interpolate
import Data.Time.Clock
import Data.Time.Clock.POSIX
#if defined(INTERNAL_DOWNLOADER)
import Data.Time.Format
#endif
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO hiding ( hideError )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.IO.Error
import System.Posix.Env.ByteString ( getEnv )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
#if defined(INTERNAL_DOWNLOADER)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> URLSource
-> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
m
GHCupInfo
getDownloadsF :: URLSource
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
getDownloadsF URLSource
urlSource = do
case URLSource
urlSource of
URLSource
GHCupURL -> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall (m :: * -> *).
(MonadFail m, MonadIO m, MonadCatch m, MonadLogger m,
MonadReader AppState m) =>
Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
getBase
(OwnSource URI
url) -> do
ByteString
bs <- (V '[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
-> DownloadFailed)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m ByteString
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll V '[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
-> DownloadFailed
forall x (xs :: [*]).
(Show x, Show (V xs), Pretty x, Pretty (V xs)) =>
V (x : xs) -> DownloadFailed
DownloadFailed (Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m ByteString
forall a b. (a -> b) -> a -> b
$ URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m :: * -> *).
(MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m) =>
URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
downloadBS URI
url
(String -> JSONError)
-> Either String GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall e' e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
(e' -> e) -> Either e' a -> Excepts es m a
lE' String -> JSONError
JSONDecodeError (Either String GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo)
-> Either String GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall a b. (a -> b) -> a -> b
$ (ParseException -> String)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException GHCupInfo -> Either String GHCupInfo)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ParseException GHCupInfo
forall a. FromJSON a => ByteString -> Either ParseException a
Y.decodeEither' (ByteString -> ByteString
L.toStrict ByteString
bs)
(OwnSpec GHCupInfo
av) -> GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure GHCupInfo
av
(AddSource (Left GHCupInfo
ext)) -> do
GHCupInfo
base <- Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall (m :: * -> *).
(MonadFail m, MonadIO m, MonadCatch m, MonadLogger m,
MonadReader AppState m) =>
Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
getBase
GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupInfo -> GHCupInfo -> GHCupInfo
mergeGhcupInfo GHCupInfo
base GHCupInfo
ext)
(AddSource (Right URI
uri)) -> do
GHCupInfo
base <- Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall (m :: * -> *).
(MonadFail m, MonadIO m, MonadCatch m, MonadLogger m,
MonadReader AppState m) =>
Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
getBase
ByteString
bsExt <- (V '[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
-> DownloadFailed)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m ByteString
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll V '[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
-> DownloadFailed
forall x (xs :: [*]).
(Show x, Show (V xs), Pretty x, Pretty (V xs)) =>
V (x : xs) -> DownloadFailed
DownloadFailed (Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m ByteString
forall a b. (a -> b) -> a -> b
$ URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m :: * -> *).
(MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m) =>
URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
downloadBS URI
uri
GHCupInfo
ext <- (String -> JSONError)
-> Either String GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall e' e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
(e' -> e) -> Either e' a -> Excepts es m a
lE' String -> JSONError
JSONDecodeError (Either String GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo)
-> Either String GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall a b. (a -> b) -> a -> b
$ (ParseException -> String)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException GHCupInfo -> Either String GHCupInfo)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ParseException GHCupInfo
forall a. FromJSON a => ByteString -> Either ParseException a
Y.decodeEither' (ByteString -> ByteString
L.toStrict ByteString
bsExt)
GHCupInfo
-> Excepts
'[JSONError, DownloadFailed, FileDoesNotExistError] m GHCupInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupInfo -> GHCupInfo -> GHCupInfo
mergeGhcupInfo GHCupInfo
base GHCupInfo
ext)
where
mergeGhcupInfo :: GHCupInfo
-> GHCupInfo
-> GHCupInfo
mergeGhcupInfo :: GHCupInfo -> GHCupInfo -> GHCupInfo
mergeGhcupInfo (GHCupInfo ToolRequirements
tr GHCupDownloads
base) (GHCupInfo ToolRequirements
_ GHCupDownloads
ext) =
let new :: GHCupDownloads
new = (Tool -> Map Version VersionInfo -> Map Version VersionInfo)
-> GHCupDownloads -> GHCupDownloads
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (\Tool
k Map Version VersionInfo
a -> case Tool -> GHCupDownloads -> Maybe (Map Version VersionInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Tool
k GHCupDownloads
ext of
Just Map Version VersionInfo
a' -> Map Version VersionInfo
-> Map Version VersionInfo -> Map Version VersionInfo
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Version VersionInfo
a' Map Version VersionInfo
a
Maybe (Map Version VersionInfo)
Nothing -> Map Version VersionInfo
a
) GHCupDownloads
base
in ToolRequirements -> GHCupDownloads -> GHCupInfo
GHCupInfo ToolRequirements
tr GHCupDownloads
new
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache :: Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
..}} <- m AppState
-> Excepts '[JSONError, FileDoesNotExistError] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
m () -> Excepts '[JSONError, FileDoesNotExistError] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[JSONError, FileDoesNotExistError] m ())
-> m () -> Excepts '[JSONError, FileDoesNotExistError] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path :: ByteString
path = Optic' A_Lens '[] URI ByteString -> URI -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] URI ByteString
forall a. Lens' (URIRef a) ByteString
pathL' URI
ghcupURL
Path Abs
yaml_file <- (Path Abs
cacheDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</>) (Path Rel -> Path Abs)
-> Excepts '[JSONError, FileDoesNotExistError] m (Path Rel)
-> Excepts '[JSONError, FileDoesNotExistError] m (Path Abs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
urlBaseName ByteString
path
ByteString
bs <-
IOErrorType
-> (IOException
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString)
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing
(\IOException
_ -> FileDoesNotExistError
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (FileDoesNotExistError
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString)
-> FileDoesNotExistError
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> FileDoesNotExistError
FileDoesNotExistError (Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
yaml_file))
(Excepts '[JSONError, FileDoesNotExistError] m ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString)
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString)
-> IO ByteString
-> Excepts '[JSONError, FileDoesNotExistError] m ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ByteString
forall b. Path b -> IO ByteString
readFile Path Abs
yaml_file
(String -> JSONError)
-> Either String GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall e' e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
(e' -> e) -> Either e' a -> Excepts es m a
lE' String -> JSONError
JSONDecodeError (Either String GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo)
-> Either String GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall a b. (a -> b) -> a -> b
$ (ParseException -> String)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException GHCupInfo -> Either String GHCupInfo)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ParseException GHCupInfo
forall a. FromJSON a => ByteString -> Either ParseException a
Y.decodeEither' (ByteString -> ByteString
L.toStrict ByteString
bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase :: Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
getBase =
(IOException
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo)
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) =>
Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache)
(Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo)
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall a b. (a -> b) -> a -> b
$ (DownloadFailed
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo)
-> Excepts '[JSONError, DownloadFailed] m GHCupInfo
-> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
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 @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed V (x : xs)
_) -> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) =>
Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache)
((V '[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
-> DownloadFailed)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
-> Excepts '[JSONError, DownloadFailed] m ByteString
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es') =>
(V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll @_ @_ @'[JSONError, DownloadFailed] V '[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
-> DownloadFailed
forall x (xs :: [*]).
(Show x, Show (V xs), Pretty x, Pretty (V xs)) =>
V (x : xs) -> DownloadFailed
DownloadFailed (URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m1 :: * -> *).
(MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1,
MonadReader AppState m1) =>
URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
smartDl URI
ghcupURL)
Excepts '[JSONError, DownloadFailed] m ByteString
-> (ByteString -> Excepts '[JSONError, DownloadFailed] m GHCupInfo)
-> Excepts '[JSONError, DownloadFailed] m GHCupInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Excepts '[JSONError] m GHCupInfo
-> Excepts '[JSONError, DownloadFailed] m GHCupInfo
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[JSONError] m GHCupInfo
-> Excepts '[JSONError, DownloadFailed] m GHCupInfo)
-> (ByteString -> Excepts '[JSONError] m GHCupInfo)
-> ByteString
-> Excepts '[JSONError, DownloadFailed] m GHCupInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> JSONError)
-> Either String GHCupInfo -> Excepts '[JSONError] m GHCupInfo
forall e' e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
(e' -> e) -> Either e' a -> Excepts es m a
lE' @_ @_ @'[JSONError] String -> JSONError
JSONDecodeError (Either String GHCupInfo -> Excepts '[JSONError] m GHCupInfo)
-> (ByteString -> Either String GHCupInfo)
-> ByteString
-> Excepts '[JSONError] m GHCupInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseException -> String)
-> Either ParseException GHCupInfo -> Either String GHCupInfo
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException GHCupInfo -> Either String GHCupInfo)
-> (ByteString -> Either ParseException GHCupInfo)
-> ByteString
-> Either String GHCupInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException GHCupInfo
forall a. FromJSON a => ByteString -> Either ParseException a
Y.decodeEither' (ByteString -> Either ParseException GHCupInfo)
-> (ByteString -> ByteString)
-> ByteString
-> Either ParseException GHCupInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict))
where
smartDl :: forall m1
. ( MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, MonadReader AppState m1
)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
, ProcessError
]
m1
L.ByteString
smartDl :: URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
smartDl URI
uri' = do
AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..}} <- m1 AppState
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m1 AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
let path :: ByteString
path = Optic' A_Lens '[] URI ByteString -> URI -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] URI ByteString
forall a. Lens' (URIRef a) ByteString
pathL' URI
uri'
Path Abs
json_file <- (Path Abs
cacheDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</>) (Path Rel -> Path Abs)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Path Rel)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Path Abs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
urlBaseName ByteString
path
Bool
e <- IO Bool
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
Bool)
-> IO Bool
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
Bool
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO Bool
forall b. Path b -> IO Bool
doesFileExist Path Abs
json_file
if Bool
e
then do
POSIXTime
accessTime <-
FileStatus -> POSIXTime
PF.accessTimeHiRes
(FileStatus -> POSIXTime)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
FileStatus
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FileStatus
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ByteString -> IO FileStatus
PF.getFileStatus (Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
json_file))
POSIXTime
currentTime <- IO POSIXTime
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
if (POSIXTime
currentTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
accessTime) POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
300
then do
Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe UTCTime)
forall a.
Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe a)
getModTime Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe UTCTime)
-> (Maybe UTCTime
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just UTCTime
modTime -> do
UTCTime
fileMod <- IO UTCTime
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
UTCTime)
-> IO UTCTime
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
UTCTime
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO UTCTime
forall b. Path b -> IO UTCTime
getModificationTime Path Abs
json_file
if UTCTime
modTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
fileMod
then UTCTime
-> Path Abs
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
dlWithMod UTCTime
modTime Path Abs
json_file
else IO ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString)
-> IO ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ByteString
forall b. Path b -> IO ByteString
readFile Path Abs
json_file
Maybe UTCTime
Nothing -> do
m1 ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m1 ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> m1 ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m1 ()
(Text -> m1 ()) -> (Text -> Text) -> Text -> m1 ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|Unable to get/parse Last-Modified header|]
Path Abs
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
dlWithoutMod Path Abs
json_file
else
IO ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString)
-> IO ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ByteString
forall b. Path b -> IO ByteString
readFile Path Abs
json_file
else do
IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
createDirRecursive' Path Abs
cacheDir
Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe UTCTime)
forall a.
Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe a)
getModTime Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe UTCTime)
-> (Maybe UTCTime
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just UTCTime
modTime -> UTCTime
-> Path Abs
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
dlWithMod UTCTime
modTime Path Abs
json_file
Maybe UTCTime
Nothing -> do
m1 ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m1 ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> m1 ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m1 ()
(Text -> m1 ()) -> (Text -> Text) -> Text -> m1 ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|Unable to get/parse Last-Modified header|]
Path Abs
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
dlWithoutMod Path Abs
json_file
where
dlWithMod :: UTCTime
-> Path Abs
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
dlWithMod UTCTime
modTime Path Abs
json_file = do
ByteString
bs <- Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall a b. (a -> b) -> a -> b
$ URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (m :: * -> *).
(MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m) =>
URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
downloadBS URI
uri'
IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ UTCTime -> Path Abs -> ByteString -> IO ()
writeFileWithModTime UTCTime
modTime Path Abs
json_file ByteString
bs
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
dlWithoutMod :: Path Abs
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
dlWithoutMod Path Abs
json_file = do
ByteString
bs <- Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall a b. (a -> b) -> a -> b
$ URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (m :: * -> *).
(MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m) =>
URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
downloadBS URI
uri'
IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
json_file
IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ Path Abs -> Maybe FileMode -> ByteString -> IO ()
forall b. Path b -> Maybe FileMode -> ByteString -> IO ()
writeFileL Path Abs
json_file (FileMode -> Maybe FileMode
forall a. a -> Maybe a
Just FileMode
newFilePerms) ByteString
bs
IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
())
-> IO ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
()
forall a b. (a -> b) -> a -> b
$ Path Abs -> EpochTime -> IO ()
forall b. Path b -> EpochTime -> IO ()
setModificationTime Path Abs
json_file (Int -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int Int
0)
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
getModTime :: Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe a)
getModTime = do
#if !defined(INTERNAL_DOWNLOADER)
Maybe a
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m1
(Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
#else
headers <-
handleIO (\_ -> pure mempty)
$ liftE
$ ( catchAllE
(\_ ->
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
)
$ getHead uri'
)
pure $ parseModifiedHeader headers
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
parseModifiedHeader headers =
(M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
True
defaultTimeLocale
"%a, %d %b %Y %H:%M:%S %Z"
(T.unpack . decUTF8Safe $ h)
#endif
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
writeFileWithModTime :: UTCTime -> Path Abs -> ByteString -> IO ()
writeFileWithModTime UTCTime
utctime Path Abs
path ByteString
content = do
let mod_time :: POSIXTime
mod_time = UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utctime
Path Abs -> Maybe FileMode -> ByteString -> IO ()
forall b. Path b -> Maybe FileMode -> ByteString -> IO ()
writeFileL Path Abs
path (FileMode -> Maybe FileMode
forall a. a -> Maybe a
Just FileMode
newFilePerms) ByteString
content
Path Abs -> POSIXTime -> IO ()
forall b. Path b -> POSIXTime -> IO ()
setModificationTimeHiRes Path Abs
path POSIXTime
mod_time
getDownloadInfo :: Tool
-> Version
-> PlatformRequest
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo :: Tool
-> Version
-> PlatformRequest
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo Tool
t Version
v (PlatformRequest Architecture
a Platform
p Maybe Versioning
mv) GHCupDownloads
dls = Either NoDownload DownloadInfo
-> (DownloadInfo -> Either NoDownload DownloadInfo)
-> Maybe DownloadInfo
-> Either NoDownload DownloadInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(NoDownload -> Either NoDownload DownloadInfo
forall a b. a -> Either a b
Left NoDownload
NoDownload)
DownloadInfo -> Either NoDownload DownloadInfo
forall a b. b -> Either a b
Right
(case Platform
p of
Linux LinuxDistro
Alpine -> Maybe DownloadInfo
with_distro Maybe DownloadInfo -> Maybe DownloadInfo -> Maybe DownloadInfo
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DownloadInfo
without_distro_ver
Platform
_ -> Maybe DownloadInfo
with_distro Maybe DownloadInfo -> Maybe DownloadInfo -> Maybe DownloadInfo
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DownloadInfo
without_distro_ver Maybe DownloadInfo -> Maybe DownloadInfo -> Maybe DownloadInfo
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DownloadInfo
without_distro
)
where
with_distro :: Maybe DownloadInfo
with_distro = (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview Platform -> Platform
forall a. a -> a
id Maybe Versioning -> Maybe Versioning
forall a. a -> a
id
without_distro_ver :: Maybe DownloadInfo
without_distro_ver = (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview Platform -> Platform
forall a. a -> a
id (Maybe Versioning -> Maybe Versioning -> Maybe Versioning
forall a b. a -> b -> a
const Maybe Versioning
forall a. Maybe a
Nothing)
without_distro :: Maybe DownloadInfo
without_distro = (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview (Optic A_Prism '[] Platform Platform LinuxDistro LinuxDistro
-> LinuxDistro -> Platform -> Platform
forall k (is :: [*]) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Prism '[] Platform Platform LinuxDistro LinuxDistro
_Linux LinuxDistro
UnknownLinux) (Maybe Versioning -> Maybe Versioning -> Maybe Versioning
forall a b. a -> b -> a
const Maybe Versioning
forall a. Maybe a
Nothing)
distro_preview :: (Platform -> Platform)
-> (Maybe Versioning -> Maybe Versioning) -> Maybe DownloadInfo
distro_preview Platform -> Platform
f Maybe Versioning -> Maybe Versioning
g =
let platformVersionSpec :: Maybe (Map (Maybe VersionRange) DownloadInfo)
platformVersionSpec =
Optic'
An_AffineTraversal
'[]
GHCupDownloads
(Map (Maybe VersionRange) DownloadInfo)
-> GHCupDownloads -> Maybe (Map (Maybe VersionRange) DownloadInfo)
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index GHCupDownloads
-> Optic'
(IxKind GHCupDownloads) '[] GHCupDownloads (IxValue GHCupDownloads)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index GHCupDownloads
Tool
t Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
(Map Version VersionInfo)
(Map Version VersionInfo)
-> Optic
An_AffineTraversal
'[]
(Map Version VersionInfo)
(Map Version VersionInfo)
VersionInfo
VersionInfo
-> Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
VersionInfo
VersionInfo
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
% Index (Map Version VersionInfo)
-> Optic'
(IxKind (Map Version VersionInfo))
'[]
(Map Version VersionInfo)
(IxValue (Map Version VersionInfo))
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index (Map Version VersionInfo)
Version
v Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
VersionInfo
VersionInfo
-> Optic
A_Lens
'[]
VersionInfo
VersionInfo
ArchitectureSpec
ArchitectureSpec
-> Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
ArchitectureSpec
ArchitectureSpec
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
% Optic
A_Lens
'[]
VersionInfo
VersionInfo
ArchitectureSpec
ArchitectureSpec
viArch Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
ArchitectureSpec
ArchitectureSpec
-> Optic
An_AffineTraversal
'[]
ArchitectureSpec
ArchitectureSpec
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
-> Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
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
% Index ArchitectureSpec
-> Optic'
(IxKind ArchitectureSpec)
'[]
ArchitectureSpec
(IxValue ArchitectureSpec)
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Index ArchitectureSpec
Architecture
a Optic
An_AffineTraversal
'[]
GHCupDownloads
GHCupDownloads
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
-> Optic
An_AffineTraversal
'[]
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
(Map (Maybe VersionRange) DownloadInfo)
(Map (Maybe VersionRange) DownloadInfo)
-> Optic'
An_AffineTraversal
'[]
GHCupDownloads
(Map (Maybe VersionRange) DownloadInfo)
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
% Index (Map Platform (Map (Maybe VersionRange) DownloadInfo))
-> Optic'
(IxKind (Map Platform (Map (Maybe VersionRange) DownloadInfo)))
'[]
(Map Platform (Map (Maybe VersionRange) DownloadInfo))
(IxValue (Map Platform (Map (Maybe VersionRange) DownloadInfo)))
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix (Platform -> Platform
f Platform
p)) GHCupDownloads
dls
mv' :: Maybe Versioning
mv' = Maybe Versioning -> Maybe Versioning
g Maybe Versioning
mv
in ((Maybe VersionRange, DownloadInfo) -> DownloadInfo)
-> Maybe (Maybe VersionRange, DownloadInfo) -> Maybe DownloadInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe VersionRange, DownloadInfo) -> DownloadInfo
forall a b. (a, b) -> b
snd
(Maybe (Maybe VersionRange, DownloadInfo) -> Maybe DownloadInfo)
-> (Map (Maybe VersionRange) DownloadInfo
-> Maybe (Maybe VersionRange, DownloadInfo))
-> Map (Maybe VersionRange) DownloadInfo
-> Maybe DownloadInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe VersionRange, DownloadInfo) -> Bool)
-> [(Maybe VersionRange, DownloadInfo)]
-> Maybe (Maybe VersionRange, DownloadInfo)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
(\(Maybe VersionRange
mverRange, DownloadInfo
_) -> Bool -> (VersionRange -> Bool) -> Maybe VersionRange -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Maybe Versioning -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Versioning
mv')
(\VersionRange
range -> Bool -> (Versioning -> Bool) -> Maybe Versioning -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Versioning -> VersionRange -> Bool
`versionRange` VersionRange
range) Maybe Versioning
mv')
Maybe VersionRange
mverRange
)
([(Maybe VersionRange, DownloadInfo)]
-> Maybe (Maybe VersionRange, DownloadInfo))
-> (Map (Maybe VersionRange) DownloadInfo
-> [(Maybe VersionRange, DownloadInfo)])
-> Map (Maybe VersionRange) DownloadInfo
-> Maybe (Maybe VersionRange, DownloadInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Maybe VersionRange) DownloadInfo
-> [(Maybe VersionRange, DownloadInfo)]
forall k a. Map k a -> [(k, a)]
M.toList
(Map (Maybe VersionRange) DownloadInfo -> Maybe DownloadInfo)
-> Maybe (Map (Maybe VersionRange) DownloadInfo)
-> Maybe DownloadInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Map (Maybe VersionRange) DownloadInfo)
platformVersionSpec
download :: ( MonadMask m
, MonadReader AppState m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> DownloadInfo
-> Path Abs
-> Maybe (Path Rel)
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download :: DownloadInfo
-> Path Abs
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
download DownloadInfo
dli Path Abs
dest Maybe (Path Rel)
mfn
| ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"https" = Excepts '[DigestError, DownloadFailed] m (Path Abs)
dl
| ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"http" = Excepts '[DigestError, DownloadFailed] m (Path Abs)
dl
| ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"file" = Excepts '[DigestError, DownloadFailed] m (Path Abs)
cp
| Bool
otherwise = DownloadFailed
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (DownloadFailed
-> Excepts '[DigestError, DownloadFailed] m (Path Abs))
-> DownloadFailed
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall a b. (a -> b) -> a -> b
$ V '[UnsupportedScheme] -> DownloadFailed
forall x (xs :: [*]).
(Show x, Show (V xs), Pretty x, Pretty (V xs)) =>
V (x : xs) -> DownloadFailed
DownloadFailed (UnsupportedScheme -> V '[UnsupportedScheme]
forall a. a -> V '[a]
variantFromValue UnsupportedScheme
UnsupportedScheme)
where
scheme :: ByteString
scheme = Optic' A_Lens '[] DownloadInfo ByteString
-> DownloadInfo -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' DownloadInfo URI
dlUri Lens' DownloadInfo URI
-> Optic A_Lens '[] URI URI Scheme Scheme
-> Optic A_Lens '[] DownloadInfo DownloadInfo Scheme Scheme
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
% Optic A_Lens '[] URI URI Scheme Scheme
uriSchemeL' Optic A_Lens '[] DownloadInfo DownloadInfo Scheme Scheme
-> Optic A_Lens '[] Scheme Scheme ByteString ByteString
-> Optic' A_Lens '[] DownloadInfo ByteString
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
% Optic A_Lens '[] Scheme Scheme ByteString ByteString
schemeBSL') DownloadInfo
dli
cp :: Excepts '[DigestError, DownloadFailed] m (Path Abs)
cp = do
IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[DigestError, DownloadFailed] m ())
-> IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
createDirRecursive' Path Abs
dest
Path Abs
destFile <- Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (m :: * -> *). MonadThrow m => m (Path Abs)
getDestFile
Path Abs
fromFile <- ByteString -> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
path
IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[DigestError, DownloadFailed] m ())
-> IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> Path Abs -> CopyMode -> IO ()
forall b1 b2. Path b1 -> Path b2 -> CopyMode -> IO ()
copyFile Path Abs
fromFile Path Abs
destFile CopyMode
Strict
Path Abs -> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs
destFile
dl :: Excepts '[DigestError, DownloadFailed] m (Path Abs)
dl = do
let uri' :: Text
uri' = ByteString -> Text
decUTF8Safe (URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (Lens' DownloadInfo URI -> DownloadInfo -> URI
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo URI
dlUri DownloadInfo
dli))
m () -> Excepts '[DigestError, DownloadFailed] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[DigestError, DownloadFailed] m ())
-> m () -> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) [i|downloading: #{uri'}|]
IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[DigestError, DownloadFailed] m ())
-> IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
createDirRecursive' Path Abs
dest
Path Abs
destFile <- Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (m :: * -> *). MonadThrow m => m (Path Abs)
getDestFile
(Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ())
-> Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
onException
(IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[DigestError, DownloadFailed] m ())
-> IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
destFile)
(Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ())
-> Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ (V '[ProcessError, DownloadFailed, UnsupportedScheme]
-> Excepts '[DigestError, DownloadFailed] m ())
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\V '[ProcessError, DownloadFailed, UnsupportedScheme]
e ->
IO () -> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
destFile)
Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (DownloadFailed -> Excepts '[DigestError, DownloadFailed] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (DownloadFailed -> Excepts '[DigestError, DownloadFailed] m ())
-> (V '[ProcessError, DownloadFailed, UnsupportedScheme]
-> DownloadFailed)
-> V '[ProcessError, DownloadFailed, UnsupportedScheme]
-> Excepts '[DigestError, DownloadFailed] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V '[ProcessError, DownloadFailed, UnsupportedScheme]
-> DownloadFailed
forall x (xs :: [*]).
(Show x, Show (V xs), Pretty x, Pretty (V xs)) =>
V (x : xs) -> DownloadFailed
DownloadFailed (V '[ProcessError, DownloadFailed, UnsupportedScheme]
-> Excepts '[DigestError, DownloadFailed] m ())
-> V '[ProcessError, DownloadFailed, UnsupportedScheme]
-> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ V '[ProcessError, DownloadFailed, UnsupportedScheme]
e)
) (Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-> Excepts '[DigestError, DownloadFailed] m ())
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ do
m Downloader
-> Excepts
'[ProcessError, DownloadFailed, UnsupportedScheme] m Downloader
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Downloader
forall (m :: * -> *). MonadReader AppState m => m Downloader
getDownloader Excepts
'[ProcessError, DownloadFailed, UnsupportedScheme] m Downloader
-> (Downloader
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ())
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Downloader
Curl -> do
[ByteString]
o' <- IO [ByteString]
-> Excepts
'[ProcessError, DownloadFailed, UnsupportedScheme] m [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ByteString]
getCurlOpts
Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ())
-> Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
forall a (m :: * -> *).
(Monad m, ProcessError :< '[ProcessError]) =>
m (Either ProcessError a) -> Excepts '[ProcessError] m a
lEM @_ @'[ProcessError] (m (Either ProcessError ()) -> Excepts '[ProcessError] m ())
-> m (Either ProcessError ()) -> Excepts '[ProcessError] m ()
forall a b. (a -> b) -> a -> b
$ IO (Either ProcessError ()) -> m (Either ProcessError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ProcessError ()) -> m (Either ProcessError ()))
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ ByteString
-> Bool
-> [ByteString]
-> Maybe (Path Abs)
-> Maybe [(ByteString, ByteString)]
-> IO (Either ProcessError ())
exec ByteString
"curl" Bool
True
([ByteString]
o' [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"-fL", ByteString
"-o", Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
destFile, URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (URI -> ByteString) -> URI -> ByteString
forall a b. (a -> b) -> a -> b
$ Lens' DownloadInfo URI -> DownloadInfo -> URI
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo URI
dlUri DownloadInfo
dli]) Maybe (Path Abs)
forall a. Maybe a
Nothing Maybe [(ByteString, ByteString)]
forall a. Maybe a
Nothing
Downloader
Wget -> do
[ByteString]
o' <- IO [ByteString]
-> Excepts
'[ProcessError, DownloadFailed, UnsupportedScheme] m [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ByteString]
getWgetOpts
Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ())
-> Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
forall a b. (a -> b) -> a -> b
$ forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
m (Either e a) -> Excepts es m a
forall a (m :: * -> *).
(Monad m, ProcessError :< '[ProcessError]) =>
m (Either ProcessError a) -> Excepts '[ProcessError] m a
lEM @_ @'[ProcessError] (m (Either ProcessError ()) -> Excepts '[ProcessError] m ())
-> m (Either ProcessError ()) -> Excepts '[ProcessError] m ()
forall a b. (a -> b) -> a -> b
$ IO (Either ProcessError ()) -> m (Either ProcessError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ProcessError ()) -> m (Either ProcessError ()))
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ ByteString
-> Bool
-> [ByteString]
-> Maybe (Path Abs)
-> Maybe [(ByteString, ByteString)]
-> IO (Either ProcessError ())
exec ByteString
"wget" Bool
True
([ByteString]
o' [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"-O", Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Abs
destFile , URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (URI -> ByteString) -> URI -> ByteString
forall a b. (a -> b) -> a -> b
$ Lens' DownloadInfo URI -> DownloadInfo -> URI
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' DownloadInfo URI
dlUri DownloadInfo
dli]) Maybe (Path Abs)
forall a. Maybe a
Nothing Maybe [(ByteString, ByteString)]
forall a. Maybe a
Nothing
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
liftE $ downloadToFile https host fullPath port destFile
#endif
Excepts '[DigestError] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[DigestError] m ()
-> Excepts '[DigestError, DownloadFailed] m ())
-> Excepts '[DigestError] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ DownloadInfo -> Path Abs -> Excepts '[DigestError] m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m) =>
DownloadInfo -> Path Abs -> Excepts '[DigestError] m ()
checkDigest DownloadInfo
dli Path Abs
destFile
Path Abs -> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs
destFile
getDestFile :: MonadThrow m => m (Path Abs)
getDestFile :: m (Path Abs)
getDestFile = m (Path Abs)
-> (Path Rel -> m (Path Abs)) -> Maybe (Path Rel) -> m (Path Abs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
urlBaseName ByteString
path m (Path Rel) -> (Path Rel -> Path Abs) -> m (Path Abs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs
dest Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</>)) (Path Abs -> m (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs -> m (Path Abs))
-> (Path Rel -> Path Abs) -> Path Rel -> m (Path Abs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs
dest Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</>)) Maybe (Path Rel)
mfn
path :: ByteString
path = Optic' A_Lens '[] DownloadInfo ByteString
-> DownloadInfo -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' DownloadInfo URI
dlUri Lens' DownloadInfo URI
-> Optic' A_Lens '[] URI ByteString
-> Optic' A_Lens '[] DownloadInfo ByteString
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
% Optic' A_Lens '[] URI ByteString
forall a. Lens' (URIRef a) ByteString
pathL') DownloadInfo
dli
downloadCached :: ( MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadReader AppState m
)
=> DownloadInfo
-> Maybe (Path Rel)
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached :: DownloadInfo
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
downloadCached DownloadInfo
dli Maybe (Path Rel)
mfn = do
Bool
cache <- m Bool -> Excepts '[DigestError, DownloadFailed] m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
forall (m :: * -> *). MonadReader AppState m => m Bool
getCache
case Bool
cache of
Bool
True -> do
AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..}} <- m AppState -> Excepts '[DigestError, DownloadFailed] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
Path Rel
fn <- Excepts '[DigestError, DownloadFailed] m (Path Rel)
-> (Path Rel
-> Excepts '[DigestError, DownloadFailed] m (Path Rel))
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Rel)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Excepts '[DigestError, DownloadFailed] m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
urlBaseName (ByteString -> Excepts '[DigestError, DownloadFailed] m (Path Rel))
-> ByteString
-> Excepts '[DigestError, DownloadFailed] m (Path Rel)
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens '[] DownloadInfo ByteString
-> DownloadInfo -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' DownloadInfo URI
dlUri Lens' DownloadInfo URI
-> Optic' A_Lens '[] URI ByteString
-> Optic' A_Lens '[] DownloadInfo ByteString
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
% Optic' A_Lens '[] URI ByteString
forall a. Lens' (URIRef a) ByteString
pathL') DownloadInfo
dli) Path Rel -> Excepts '[DigestError, DownloadFailed] m (Path Rel)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Rel)
mfn
let cachfile :: Path Abs
cachfile = Path Abs
cacheDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
fn
Bool
fileExists <- IO Bool -> Excepts '[DigestError, DownloadFailed] m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[DigestError, DownloadFailed] m Bool)
-> IO Bool -> Excepts '[DigestError, DownloadFailed] m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO Bool
forall b. Path b -> IO Bool
doesFileExist Path Abs
cachfile
if
| Bool
fileExists -> do
Excepts '[DigestError] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[DigestError] m ()
-> Excepts '[DigestError, DownloadFailed] m ())
-> Excepts '[DigestError] m ()
-> Excepts '[DigestError, DownloadFailed] m ()
forall a b. (a -> b) -> a -> b
$ DownloadInfo -> Path Abs -> Excepts '[DigestError] m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m) =>
DownloadInfo -> Path Abs -> Excepts '[DigestError] m ()
checkDigest DownloadInfo
dli Path Abs
cachfile
Path Abs -> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs
cachfile
| Bool
otherwise -> Excepts '[DigestError, DownloadFailed] m (Path Abs)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[DigestError, DownloadFailed] m (Path Abs)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs))
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall a b. (a -> b) -> a -> b
$ DownloadInfo
-> Path Abs
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (m :: * -> *).
(MonadMask m, MonadReader AppState m, MonadThrow m, MonadLogger m,
MonadIO m) =>
DownloadInfo
-> Path Abs
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
download DownloadInfo
dli Path Abs
cacheDir Maybe (Path Rel)
mfn
Bool
False -> do
Path Abs
tmp <- m (Path Abs) -> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Path Abs)
forall (m :: * -> *).
(MonadResource m, MonadThrow m, MonadIO m) =>
m (Path Abs)
withGHCupTmpDir
Excepts '[DigestError, DownloadFailed] m (Path Abs)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[DigestError, DownloadFailed] m (Path Abs)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs))
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall a b. (a -> b) -> a -> b
$ DownloadInfo
-> Path Abs
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
forall (m :: * -> *).
(MonadMask m, MonadReader AppState m, MonadThrow m, MonadLogger m,
MonadIO m) =>
DownloadInfo
-> Path Abs
-> Maybe (Path Rel)
-> Excepts '[DigestError, DownloadFailed] m (Path Abs)
download DownloadInfo
dli Path Abs
tmp Maybe (Path Rel)
mfn
downloadBS :: (MonadReader AppState m, MonadCatch m, MonadIO m, MonadLogger m)
=> URI
-> Excepts
'[ FileDoesNotExistError
, HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
, ProcessError
]
m
L.ByteString
downloadBS :: URI
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
downloadBS URI
uri'
| ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"https"
= Bool
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
dl Bool
True
| ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"http"
= Bool
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
dl Bool
False
| ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"file"
= IOErrorType
-> FileDoesNotExistError
-> m ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m :: * -> *) e (es' :: [*]) a.
(MonadCatch m, MonadIO m, Monad m, e :< es') =>
IOErrorType -> e -> m a -> Excepts es' m a
liftIOException IOErrorType
doesNotExistErrorType (ByteString -> FileDoesNotExistError
FileDoesNotExistError ByteString
path)
(IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
RD.readFile ByteString
path)
| Bool
otherwise
= UnsupportedScheme
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE UnsupportedScheme
UnsupportedScheme
where
scheme :: ByteString
scheme = Optic' A_Lens '[] URI ByteString -> URI -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic A_Lens '[] URI URI Scheme Scheme
uriSchemeL' Optic A_Lens '[] URI URI Scheme Scheme
-> Optic A_Lens '[] Scheme Scheme ByteString ByteString
-> Optic' A_Lens '[] URI ByteString
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
% Optic A_Lens '[] Scheme Scheme ByteString ByteString
schemeBSL') URI
uri'
path :: ByteString
path = Optic' A_Lens '[] URI ByteString -> URI -> ByteString
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] URI ByteString
forall a. Lens' (URIRef a) ByteString
pathL' URI
uri'
#if defined(INTERNAL_DOWNLOADER)
dl https = do
#else
dl :: Bool
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
dl Bool
_ = do
#endif
m ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
())
-> m ()
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug) [i|downloading: #{serializeURIRef' uri'}|]
m Downloader
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
Downloader
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Downloader
forall (m :: * -> *). MonadReader AppState m => m Downloader
getDownloader Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
Downloader
-> (Downloader
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Downloader
Curl -> do
[ByteString]
o' <- IO [ByteString]
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
[ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ByteString]
getCurlOpts
let exe :: Path Rel
exe = [rel|curl|]
args :: [ByteString]
args = [ByteString]
o' [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"-sSfL", URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' URI
uri']
IO CapturedProcess
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
CapturedProcess
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Rel -> [ByteString] -> Maybe (Path Abs) -> IO CapturedProcess
forall b.
Path b -> [ByteString] -> Maybe (Path Abs) -> IO CapturedProcess
executeOut Path Rel
exe [ByteString]
args Maybe (Path Abs)
forall a. Maybe a
Nothing) Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
CapturedProcess
-> (CapturedProcess
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CapturedProcess ExitCode
ExitSuccess ByteString
stdout ByteString
_ -> do
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
stdout
CapturedProcess (ExitFailure Int
i') ByteString
_ ByteString
_ -> ProcessError
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (ProcessError
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> ProcessError
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> [ByteString] -> ProcessError
NonZeroExit Int
i' (Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel
exe) [ByteString]
args
Downloader
Wget -> do
[ByteString]
o' <- IO [ByteString]
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
[ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ByteString]
getWgetOpts
let exe :: Path Rel
exe = [rel|wget|]
args :: [ByteString]
args = [ByteString]
o' [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"-qO-", URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' URI
uri']
IO CapturedProcess
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
CapturedProcess
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Rel -> [ByteString] -> Maybe (Path Abs) -> IO CapturedProcess
forall b.
Path b -> [ByteString] -> Maybe (Path Abs) -> IO CapturedProcess
executeOut Path Rel
exe [ByteString]
args Maybe (Path Abs)
forall a. Maybe a
Nothing) Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
CapturedProcess
-> (CapturedProcess
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CapturedProcess ExitCode
ExitSuccess ByteString
stdout ByteString
_ -> do
ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> ByteString
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.fromStrict ByteString
stdout
CapturedProcess (ExitFailure Int
i') ByteString
_ ByteString
_ -> ProcessError
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (ProcessError
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString)
-> ProcessError
-> Excepts
'[FileDoesNotExistError, HTTPStatusError, URIParseError,
UnsupportedScheme, NoLocationHeader, TooManyRedirs, ProcessError]
m
ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> [ByteString] -> ProcessError
NonZeroExit Int
i' (Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel
exe) [ByteString]
args
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
liftE $ downloadBS' https host' fullPath' port'
#endif
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo
-> Path Abs
-> Excepts '[DigestError] m ()
checkDigest :: DownloadInfo -> Path Abs -> Excepts '[DigestError] m ()
checkDigest DownloadInfo
dli Path Abs
file = do
Bool
verify <- m AppState -> Excepts '[DigestError] m AppState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask Excepts '[DigestError] m AppState
-> (AppState -> Bool) -> Excepts '[DigestError] m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Bool -> Bool
not (Bool -> Bool) -> (AppState -> Bool) -> AppState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Bool
noVerify (Settings -> Bool) -> (AppState -> Settings) -> AppState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppState -> Settings
settings)
Bool -> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verify (Excepts '[DigestError] m () -> Excepts '[DigestError] m ())
-> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
p' <- Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath (Path Rel -> ByteString)
-> Excepts '[DigestError] m (Path Rel)
-> Excepts '[DigestError] m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs -> Excepts '[DigestError] m (Path Rel)
forall (m :: * -> *) b. MonadThrow m => Path b -> m (Path Rel)
basename Path Abs
file
m () -> Excepts '[DigestError] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[DigestError] m ())
-> m () -> Excepts '[DigestError] m ()
forall a b. (a -> b) -> a -> b
$ $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) [i|verifying digest of: #{p'}|]
ByteString
c <- IO ByteString -> Excepts '[DigestError] m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Excepts '[DigestError] m ByteString)
-> IO ByteString -> Excepts '[DigestError] m ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ByteString
forall b. Path b -> IO ByteString
readFile Path Abs
file
Text
cDigest <- Either UnicodeException Text -> Excepts '[DigestError] m Text
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either UnicodeException Text -> Excepts '[DigestError] m Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Excepts '[DigestError] m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
E.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA256.hashlazy (ByteString -> Excepts '[DigestError] m Text)
-> ByteString -> Excepts '[DigestError] m Text
forall a b. (a -> b) -> a -> b
$ ByteString
c
let eDigest :: Text
eDigest = Optic' A_Lens '[] DownloadInfo Text -> DownloadInfo -> Text
forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] DownloadInfo Text
dlHash DownloadInfo
dli
Bool -> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Text
cDigest Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
eDigest) Bool -> Bool -> Bool
&& Bool
verify) (Excepts '[DigestError] m () -> Excepts '[DigestError] m ())
-> Excepts '[DigestError] m () -> Excepts '[DigestError] m ()
forall a b. (a -> b) -> a -> b
$ DigestError -> Excepts '[DigestError] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (Text -> Text -> DigestError
DigestError Text
cDigest Text
eDigest)
getCurlOpts :: IO [ByteString]
getCurlOpts :: IO [ByteString]
getCurlOpts =
ByteString -> IO (Maybe ByteString)
getEnv ByteString
"GHCUP_CURL_OPTS" IO (Maybe ByteString)
-> (Maybe ByteString -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ByteString
r -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
BS.split Word8
_space ByteString
r
Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
getWgetOpts :: IO [ByteString]
getWgetOpts :: IO [ByteString]
getWgetOpts =
ByteString -> IO (Maybe ByteString)
getEnv ByteString
"GHCUP_WGET_OPTS" IO (Maybe ByteString)
-> (Maybe ByteString -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ByteString
r -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
BS.split Word8
_space ByteString
r
Maybe ByteString
Nothing -> [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []