-- | 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 = do
    locales <- forM ["LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG"] lookupEnv
    let posix = split ":" $ firstJust locales "en_US"
    let ietf = mapMaybe toRFC2616Lang posix
    return (explode ietf, explode posix)

toRFC2616Lang "C" = Nothing
toRFC2616Lang ('C':'.':_) = Nothing
toRFC2616Lang ('C':'@':_) = Nothing
toRFC2616Lang lang = case toRFC2616Lang' lang of
    "" -> Nothing
    lang' -> Just lang'

toRFC2616Lang' ('_':cs) = '-' : toRFC2616Lang' cs
toRFC2616Lang' ('.':_) = []
toRFC2616Lang' ('@':_) = []
toRFC2616Lang' (c:cs) = toLower c : toRFC2616Lang' cs
toRFC2616Lang' [] = []

-- Makes sure to include the raw languages, and not just localized variants.
extractLangs (locale:locales) | (lang:_) <- split "-_.@" locale = lang : extractLangs locales
extractLangs (_:locales) = extractLangs locales
extractLangs [] = []

explode locales = locales ++ [l | l <- extractLangs locales, l `notElem` locales]

firstJust (Just a:_) _ | a /= "" = a
firstJust (_:maybes) fallback = firstJust maybes fallback
firstJust [] fallback = fallback

split b (a:as) | a `elem` b = [] : split b as
        | (head':tail') <- split b as = (a:head') : tail'
        | otherwise = [a:as]
split _ [] = [[]]

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