-- | Internal module for retrieving languages to localize to.
-- Also provides decoupling layers between Network.URI.Messages & optional dependencies.
{-# LANGUAGE CPP #-}
module Network.URI.Locale(rfc2616Locale
#ifdef WITH_HTTP_URI
, transHttp
#endif
) where

import System.Environment (lookupEnv)
import Control.Monad (forM)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Char (toLower)

#ifdef WITH_HTTP_URI
import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
import Control.Exception (displayException)
import Network.TLS (TLSException(..), TLSError(..), AlertDescription(..))
import Control.Exception.Base (fromException)
import Network.HTTP.Types (Status(..))

import Network.URI.Messages
import qualified Data.ByteString.Char8 as C8
import qualified Data.Text as Txt
import Text.Read (readMaybe)
#endif

--- This file is based on logic in GNOME's LibSoup & GLib.

-- | Returns the languages to which responses should be localized.
-- Retrieved from Gettext configuration & reformatted for use in the
-- HTTP Accept-Language request header.
rfc2616Locale :: IO ([String], [String])
rfc2616Locale :: IO ([String], [String])
rfc2616Locale = do
    [Maybe String]
locales <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String
"LANGUAGE", String
"LC_ALL", String
"LC_MESSAGES", String
"LANG"] String -> IO (Maybe String)
lookupEnv
    let posix :: [String]
posix = forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> [a] -> [[a]]
split String
":" forall a b. (a -> b) -> a -> b
$ [Maybe String] -> String -> String
firstJust [Maybe String]
locales String
"en_US"
    let ietf :: [String]
ietf = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
toRFC2616Lang [String]
posix
    forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
explode [String]
ietf, [String] -> [String]
explode [String]
posix)

toRFC2616Lang :: String -> Maybe String
toRFC2616Lang String
"C" = forall a. Maybe a
Nothing
toRFC2616Lang (Char
'C':Char
'.':String
_) = forall a. Maybe a
Nothing
toRFC2616Lang (Char
'C':Char
'@':String
_) = forall a. Maybe a
Nothing
toRFC2616Lang String
lang = case String -> String
toRFC2616Lang' String
lang of
    String
"" -> forall a. Maybe a
Nothing
    String
lang' -> forall a. a -> Maybe a
Just String
lang'

toRFC2616Lang' :: String -> String
toRFC2616Lang' (Char
'_':String
cs) = Char
'-' forall a. a -> [a] -> [a]
: String -> String
toRFC2616Lang' String
cs
toRFC2616Lang' (Char
'.':String
_) = []
toRFC2616Lang' (Char
'@':String
_) = []
toRFC2616Lang' (Char
c:String
cs) = Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String -> String
toRFC2616Lang' String
cs
toRFC2616Lang' [] = []

-- Makes sure to include the raw languages, and not just localized variants.
extractLangs :: [String] -> [String]
extractLangs (String
locale:[String]
locales) | (String
lang:[String]
_) <- forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> [a] -> [[a]]
split String
"-_.@" String
locale = String
lang forall a. a -> [a] -> [a]
: [String] -> [String]
extractLangs [String]
locales
extractLangs (String
_:[String]
locales) = [String] -> [String]
extractLangs [String]
locales
extractLangs [] = []

explode :: [String] -> [String]
explode [String]
locales = [String]
locales forall a. [a] -> [a] -> [a]
++ [String
l | String
l <- [String] -> [String]
extractLangs [String]
locales, String
l forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
locales]

firstJust :: [Maybe String] -> String -> String
firstJust (Just String
a:[Maybe String]
_) String
_ | String
a forall a. Eq a => a -> a -> Bool
/= String
"" = String
a
firstJust (Maybe String
_:[Maybe String]
maybes) String
fallback = [Maybe String] -> String -> String
firstJust [Maybe String]
maybes String
fallback
firstJust [] String
fallback = String
fallback

split :: t a -> [a] -> [[a]]
split t a
b (a
a:[a]
as) | a
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
b = [] forall a. a -> [a] -> [a]
: t a -> [a] -> [[a]]
split t a
b [a]
as
        | ([a]
head':[[a]]
tail') <- t a -> [a] -> [[a]]
split t a
b [a]
as = (a
aforall a. a -> [a] -> [a]
:[a]
head') forall a. a -> [a] -> [a]
: [[a]]
tail'
        | Bool
otherwise = [a
aforall a. a -> [a] -> [a]
:[a]
as]
split t a
_ [] = [[]]

--------
---- Decoupling Layer
--------
#ifdef WITH_HTTP_URI
transHttp :: (Errors -> String) -> HttpException -> String
transHttp Errors -> String
trans' (InvalidUrlException String
url String
msg) = Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> String -> Errors
InvalidUrl String
url String
msg
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (TooManyRedirects [Response ByteString]
_)) = Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ Errors
ExcessiveRedirects
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
ResponseTimeout) = Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ Errors
TimeoutResponse
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
ConnectionTimeout) = Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ Errors
TimeoutConnection
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (ConnectionFailure SomeException
err)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
err
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (StatusCodeException Response ()
_ ByteString
code)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ Int -> String -> Errors
HTTPStatus (forall a. a -> Maybe a -> a
fromMaybe Int
500 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
code) String
""
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
OverlongHeaders) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ Int -> String -> Errors
HTTPStatus Int
431 String
"Overlong Headers"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidStatusLine ByteString
why)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
why
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidHeader ByteString
why)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
why
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidRequestHeader ByteString
why)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
InvalidRequest forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
why
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (ProxyConnectException ByteString
a Int
b (Status Int
code ByteString
msg))) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> String -> Errors
ProxyError (ByteString -> String
C8.unpack ByteString
a) Int
b Int
code forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
msg
-- NOTE: Minor details are unlocalized for now... Can always come back to this!
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
NoResponseDataReceived) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"Empty"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
TlsNotSupported) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
HandshakeMisc String
"Unsupported"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (WrongRequestBodyStreamSize Word64
a Word64
b)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
OtherException forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Wrong request bodysize", forall a. Show a => a -> String
show Word64
a, forall a. Show a => a -> String
show Word64
b]
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (ResponseBodyTooShort Word64
a Word64
b)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse (String
"Too short " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
a forall a. [a] -> [a] -> [a]
++ Char
'<' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Word64
b)
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
InvalidChunkHeaders) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"Chunk headers"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
IncompleteHeaders) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"Incomplete headers"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidDestinationHost ByteString
why)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
why
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (HttpZlibException ZlibException
_)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"ZLib compression"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
ConnectionClosed) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect String
"already-closed"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidProxySettings Text
why)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect (String
"proxy (" forall a. [a] -> [a] -> [a]
++ Text -> String
Txt.unpack Text
why forall a. [a] -> [a] -> [a]
++ String
")")
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidProxyEnvironmentVariable Text
key Text
value)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect (String
"proxy (" forall a. [a] -> [a] -> [a]
++ Text -> String
Txt.unpack Text
key forall a. [a] -> [a] -> [a]
++ Char
'=' forall a. a -> [a] -> [a]
: Text -> String
Txt.unpack Text
value forall a. [a] -> [a] -> [a]
++ String
")")
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InternalException SomeException
e)) =
    Errors -> String
trans' forall a b. (a -> b) -> a -> b
$ case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (Terminated Bool
_ String
why TLSError
_) -> String -> Errors
InsecureTerminated String
why
        Just (HandshakeFailed (Error_Misc String
msg)) -> String -> Errors
HandshakeMisc String
msg
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CloseNotify))) -> Errors
HandshakeClosed
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
HandshakeFailure))) -> Errors
HandshakeError
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
BadCertificate))) -> String -> Errors
InsecureCertificate String
""
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
UnsupportedCertificate))) ->
            String -> Errors
InsecureCertificate forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateUnsupported
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CertificateExpired))) ->
            String -> Errors
InsecureCertificate forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateExpired
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CertificateRevoked))) ->
            String -> Errors
InsecureCertificate forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateRevoked
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CertificateUnknown))) ->
            String -> Errors
InsecureCertificate forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateUnknown
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
UnknownCa))) ->
            String -> Errors
InsecureCertificate forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateUnknownCA
        Just (HandshakeFailed (Error_Protocol (String
why, Bool
_, AlertDescription
_))) -> String -> Errors
HandshakeMisc String
why
        Just (HandshakeFailed (Error_Certificate String
why)) -> String -> Errors
InsecureCertificate String
why
        Just (HandshakeFailed (Error_HandshakePolicy String
why)) -> String -> Errors
HandshakePolicy String
why
        Just (HandshakeFailed TLSError
Error_EOF) -> Errors
HandshakeEOF
        Just (HandshakeFailed (Error_Packet String
why)) -> String -> Errors
HandshakePacketInvalid String
why
        Just (HandshakeFailed (Error_Packet_unexpected String
a String
b)) -> String -> String -> Errors
HandshakePacketUnexpected String
a String
b
        Just (HandshakeFailed (Error_Packet_Parsing String
why)) -> String -> Errors
HandshakePacketUnparsed String
why
        Just TLSException
ConnectionNotEstablished -> Errors
InsecureUnestablished
        Maybe TLSException
Nothing -> String -> Errors
OtherException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e
#endif