{-# LANGUAGE CPP, OverloadedStrings #-}
{- |
Module      :  ./Common/Http.hs
Description :  wrapper for simple http
Copyright   :  (c) Christian Maeder 2013
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  non-portable (uses package HTTP)

-}

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