{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Download.Utils where
import GHCup.Errors
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Prelude
import Control.Applicative
import Control.Monad
import Data.ByteString ( ByteString )
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import URI.ByteString
import qualified Data.Binary.Builder as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
uriToQuadruple :: Monad m
=> URI
-> Excepts
'[UnsupportedScheme]
m
(Bool, ByteString, ByteString, Maybe Int)
uriToQuadruple :: forall (m :: * -> *).
Monad m =>
URI
-> Excepts
'[UnsupportedScheme] m (Bool, ByteString, ByteString, Maybe Int)
uriToQuadruple URI {Maybe ByteString
Maybe Authority
ByteString
Scheme
Query
uriScheme :: URI -> Scheme
uriAuthority :: URI -> Maybe Authority
uriPath :: URI -> ByteString
uriQuery :: URI -> Query
uriFragment :: URI -> Maybe ByteString
uriFragment :: Maybe ByteString
uriQuery :: Query
uriPath :: ByteString
uriAuthority :: Maybe Authority
uriScheme :: Scheme
..} = do
let scheme :: ByteString
scheme = forall k (is :: [*]) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' Scheme ByteString
schemeBSL' Scheme
uriScheme
ByteString
host <-
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall a b. Prism (Maybe a) (Maybe b) a b
_Just 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' Authority Host
authorityHostL' 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' Host ByteString
hostBSL') Maybe Authority
uriAuthority
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? UnsupportedScheme
UnsupportedScheme
Bool
https <- if
| ByteString
scheme forall a. Eq a => a -> a -> Bool
== ByteString
"https" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
| ByteString
scheme forall a. Eq a => a -> a -> Bool
== ByteString
"http" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
| Bool
otherwise -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE UnsupportedScheme
UnsupportedScheme
let queryBS :: ByteString
queryBS =
ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"&"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
x, ByteString
y) -> ByteString -> ByteString
encodeQuery ByteString
x forall a. Semigroup a => a -> a -> a
<> ByteString
"=" forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encodeQuery ByteString
y)
forall a b. (a -> b) -> a -> b
$ Query -> [(ByteString, ByteString)]
queryPairs Query
uriQuery
port :: Maybe Int
port =
forall k (is :: [*]) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall a b. Prism (Maybe a) (Maybe b) a b
_Just 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' Authority (Maybe Port)
authorityPortL' 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 b. Prism (Maybe a) (Maybe b) a b
_Just 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' Port Int
portNumberL') Maybe Authority
uriAuthority
fullpath :: ByteString
fullpath = if ByteString -> Bool
BS.null ByteString
queryBS then ByteString
uriPath else ByteString
uriPath forall a. Semigroup a => a -> a -> a
<> ByteString
"?" forall a. Semigroup a => a -> a -> a
<> ByteString
queryBS
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
https, ByteString
host, ByteString
fullpath, Maybe Int
port)
where encodeQuery :: ByteString -> ByteString
encodeQuery = ByteString -> ByteString
L.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
urlEncodeQuery