{-# 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
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' [] = []
(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
_ [] = [[]]
#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
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