{-# LANGUAGE CPP, OverloadedStrings #-}
module Common.Http where
import Driver.Options
#ifdef NO_WGET
import Control.Exception (try)
import qualified Data.ByteString.Lazy.Char8 as LChar8
import qualified Data.ByteString.Char8 as Char8
import qualified Data.CaseInsensitive as CI (mk)
import Data.Char (isSpace)
import Network.Connection (TLSSettings(..))
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Network.HTTP.Types (statusCode)
#else
import Common.Utils
import System.Exit
#endif
loadFromUri :: HetcatsOpts -> String -> IO (Either String String)
#ifdef NO_WGET
loadFromUri :: HetcatsOpts -> String -> IO (Either String String)
loadFromUri opts :: HetcatsOpts
opts uri :: String
uri = do
Manager
manager <-
if HetcatsOpts -> Bool
disableCertificateVerification HetcatsOpts
opts
then ManagerSettings -> IO Manager
newManager ManagerSettings
noVerifyTlsManagerSettings
else ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
Request
initialRequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
uri
let additionalHeaders :: [(CI ByteString, ByteString)]
additionalHeaders =
(String -> (CI ByteString, ByteString))
-> [String] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((\ (header :: String
header, value :: String
value) ->
(ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
Char8.pack String
header,
String -> ByteString
Char8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
value)) ((String, String) -> (CI ByteString, ByteString))
-> (String -> (String, String))
-> String
-> (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':')) ([String] -> [(CI ByteString, ByteString)])
-> [String] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> [String]
httpRequestHeaders HetcatsOpts
opts
let request :: Request
request = Request
initialRequest
{ requestHeaders :: [(CI ByteString, ByteString)]
requestHeaders = ("Accept", "*/*; q=0.1, text/plain")
(CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(CI ByteString, ByteString)]
additionalHeaders }
Either HttpException (Response ByteString)
eResponse <- IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
-> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
case Either HttpException (Response ByteString)
eResponse of
Left err :: HttpException
err ->
case HttpException
err :: HttpException of
HttpExceptionRequest _ exceptionContent :: HttpExceptionContent
exceptionContent ->
Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left
("Failed to load " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
exceptionContent)
InvalidUrlException invalidUrl :: String
invalidUrl reason :: String
reason ->
Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left ("Failed to load " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
invalidUrl String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason)
Right response :: Response ByteString
response ->
let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response in
Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ if 400 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
status
then String -> Either String String
forall a b. a -> Either a b
Left ("Failed to load " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": HTTP status code "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
status)
else String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
LChar8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response
noVerifyTlsManagerSettings :: ManagerSettings
noVerifyTlsManagerSettings :: ManagerSettings
noVerifyTlsManagerSettings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
noVerifyTlsSettings Maybe SockSettings
forall a. Maybe a
Nothing
noVerifyTlsSettings :: TLSSettings
noVerifyTlsSettings :: TLSSettings
noVerifyTlsSettings =
TLSSettingsSimple :: Bool -> Bool -> Bool -> TLSSettings
TLSSettingsSimple { settingDisableCertificateValidation :: Bool
settingDisableCertificateValidation = Bool
True
, settingDisableSession :: Bool
settingDisableSession = Bool
True
, settingUseServerName :: Bool
settingUseServerName = Bool
False
}
#else
loadFromUri opts str = do
let args = if disableCertificateVerification opts
then ["--no-check-certificate"]
else []
(code, out, err) <- executeProcess "wget"
(args ++ ["--header=Accept: */*; q=0.1, text/plain", "-O", "-", str]) ""
return $ case code of
ExitSuccess -> Right out
_ -> Left err
#endif