{-# 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.Utils.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


-- | Extracts from a URI type: (https?, host, path+query, port)
uriToQuadruple :: Monad m
               => URI
               -> Excepts
                    '[UnsupportedScheme]
                    m
                    (Bool, ByteString, ByteString, Maybe Int)
uriToQuadruple :: 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 = Optic' A_Lens '[] Scheme ByteString -> Scheme -> ByteString
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] Scheme ByteString
schemeBSL' Scheme
uriScheme

  ByteString
host <-
    Optic' An_AffineTraversal '[] (Maybe Authority) ByteString
-> Maybe Authority -> Maybe ByteString
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Prism (Maybe Authority) (Maybe Authority) Authority Authority
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe Authority) (Maybe Authority) Authority Authority
-> Optic A_Lens '[] Authority Authority Host Host
-> Optic
     An_AffineTraversal
     '[]
     (Maybe Authority)
     (Maybe Authority)
     Host
     Host
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 '[] Authority Authority Host Host
authorityHostL' Optic
  An_AffineTraversal
  '[]
  (Maybe Authority)
  (Maybe Authority)
  Host
  Host
-> Optic A_Lens '[] Host Host ByteString ByteString
-> Optic' An_AffineTraversal '[] (Maybe Authority) ByteString
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 '[] Host Host ByteString ByteString
hostBSL') Maybe Authority
uriAuthority
      Maybe ByteString
-> UnsupportedScheme -> Excepts '[UnsupportedScheme] m ByteString
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? UnsupportedScheme
UnsupportedScheme

  Bool
https <- if
    | ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"https" -> Bool -> Excepts '[UnsupportedScheme] m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    | ByteString
scheme ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"http"  -> Bool -> Excepts '[UnsupportedScheme] m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    | Bool
otherwise         -> UnsupportedScheme -> Excepts '[UnsupportedScheme] m Bool
forall e (es :: IxList) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE UnsupportedScheme
UnsupportedScheme

  let queryBS :: ByteString
queryBS =
        ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"&"
          ([ByteString] -> ByteString)
-> ([(ByteString, ByteString)] -> [ByteString])
-> [(ByteString, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
x, ByteString
y) -> ByteString -> ByteString
encodeQuery ByteString
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encodeQuery ByteString
y)
          ([(ByteString, ByteString)] -> ByteString)
-> [(ByteString, ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$ Query -> [(ByteString, ByteString)]
queryPairs Query
uriQuery
      port :: Maybe Int
port =
        Optic' An_AffineTraversal '[] (Maybe Authority) Int
-> Maybe Authority -> Maybe Int
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Prism (Maybe Authority) (Maybe Authority) Authority Authority
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe Authority) (Maybe Authority) Authority Authority
-> Optic A_Lens '[] Authority Authority (Maybe Port) (Maybe Port)
-> Optic
     An_AffineTraversal
     '[]
     (Maybe Authority)
     (Maybe Authority)
     (Maybe Port)
     (Maybe Port)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 '[] Authority Authority (Maybe Port) (Maybe Port)
authorityPortL' Optic
  An_AffineTraversal
  '[]
  (Maybe Authority)
  (Maybe Authority)
  (Maybe Port)
  (Maybe Port)
-> Optic A_Prism '[] (Maybe Port) (Maybe Port) Port Port
-> Optic
     An_AffineTraversal
     '[]
     (Maybe Authority)
     (Maybe Authority)
     Port
     Port
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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_Prism '[] (Maybe Port) (Maybe Port) Port Port
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Optic
  An_AffineTraversal
  '[]
  (Maybe Authority)
  (Maybe Authority)
  Port
  Port
-> Optic A_Lens '[] Port Port Int Int
-> Optic' An_AffineTraversal '[] (Maybe Authority) Int
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) 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 '[] Port Port Int Int
portNumberL') Maybe Authority
uriAuthority
      fullpath :: ByteString
fullpath = if ByteString -> Bool
BS.null ByteString
queryBS then ByteString
uriPath else ByteString
uriPath ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"?" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
queryBS
  (Bool, ByteString, ByteString, Maybe Int)
-> Excepts
     '[UnsupportedScheme] m (Bool, ByteString, ByteString, Maybe Int)
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 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
urlEncodeQuery