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