-- | 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 <- [String] -> (String -> IO (Maybe String)) -> IO [Maybe String]
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 = String -> String -> [String]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> [a] -> [[a]]
split String
":" (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> String -> String
firstJust [Maybe String]
locales String
"en_US"
    let ietf :: [String]
ietf = (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
toRFC2616Lang [String]
posix
    ([String], [String]) -> IO ([String], [String])
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" = Maybe String
forall a. Maybe a
Nothing
toRFC2616Lang (Char
'C':Char
'.':String
_) = Maybe String
forall a. Maybe a
Nothing
toRFC2616Lang (Char
'C':Char
'@':String
_) = Maybe String
forall a. Maybe a
Nothing
toRFC2616Lang String
lang = case String -> String
toRFC2616Lang' String
lang of
    String
"" -> Maybe String
forall a. Maybe a
Nothing
    String
lang' -> String -> Maybe String
forall a. a -> Maybe a
Just String
lang'

toRFC2616Lang' :: String -> String
toRFC2616Lang' (Char
'_':String
cs) = Char
'-' Char -> String -> String
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 Char -> String -> String
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]
_) <- String -> String -> [String]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> [a] -> [[a]]
split String
"-_.@" String
locale = String
lang String -> [String] -> [String]
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
l | String
l <- [String] -> [String]
extractLangs [String]
locales, String
l String -> [String] -> Bool
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 String -> String -> Bool
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 a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
b = [] [a] -> [[a]] -> [[a]]
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
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
head') [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
tail'
        | Bool
otherwise = [a
aa -> [a] -> [a]
forall 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' (Errors -> String) -> Errors -> String
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Errors
ExcessiveRedirects
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
ResponseTimeout) = Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Errors
TimeoutResponse
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
ConnectionTimeout) = Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Errors
TimeoutConnection
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (ConnectionFailure SomeException
err)) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (StatusCodeException Response ()
_ ByteString
code)) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> Errors
HTTPStatus (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
500 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
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' (Errors -> String) -> Errors -> String
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse (String -> Errors) -> String -> Errors
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse (String -> Errors) -> String -> Errors
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
InvalidRequest (String -> Errors) -> String -> Errors
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> String -> Errors
ProxyError (ByteString -> String
C8.unpack ByteString
a) Int
b Int
code (String -> Errors) -> String -> Errors
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"Empty"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
TlsNotSupported) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
OtherException (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Wrong request bodysize", Word64 -> String
forall a. Show a => a -> String
show Word64
a, Word64 -> String
forall a. Show a => a -> String
show Word64
b]
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (ResponseBodyTooShort Word64
a Word64
b)) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse (String
"Too short " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'<' Char -> String -> String
forall a. a -> [a] -> [a]
: Word64 -> String
forall a. Show a => a -> String
show Word64
b)
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
InvalidChunkHeaders) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"Chunk headers"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
IncompleteHeaders) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
why
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (HttpZlibException ZlibException
_)) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
"ZLib compression"
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ HttpExceptionContent
ConnectionClosed) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
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' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect (String
"proxy (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Txt.unpack Text
why String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InvalidProxyEnvironmentVariable Text
key Text
value)) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
FailedConnect (String
"proxy (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Txt.unpack Text
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> String -> String
forall a. a -> [a] -> [a]
: Text -> String
Txt.unpack Text
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
transHttp Errors -> String
trans' (HttpExceptionRequest Request
_ (InternalException SomeException
e)) =
    Errors -> String
trans' (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe TLSException
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 (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateUnsupported
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CertificateExpired))) ->
            String -> Errors
InsecureCertificate (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateExpired
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CertificateRevoked))) ->
            String -> Errors
InsecureCertificate (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateRevoked
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
CertificateUnknown))) ->
            String -> Errors
InsecureCertificate (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ Errors -> String
trans' Errors
InsecureCertificateUnknown
        Just (HandshakeFailed (Error_Protocol (String
_, Bool
_, AlertDescription
UnknownCa))) ->
            String -> Errors
InsecureCertificate (String -> Errors) -> String -> Errors
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 (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
#endif