{-# OPTIONS -Wall -XOverloadedStrings #-}
module TextConversion
    ( soapXmlUtf8, soapXmlToString
    , soapContentType
    , E.DecodingException
    , E.EncodingException
    )
where

import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BsC8

import qualified Data.Encoding as E
import qualified Data.Encoding.UTF8 as E

import Text.Regex
import Text.Parsec
import Text.Parsec.ByteString.Lazy

-- soapXmlUtf8, soapXmlToString, bsToUtf8, bsToString, StringToUtf8Bs may throw DecodingException
-- or EncodingException

-- |Converts a SOAP request to UTF8. If the request contains a XML header,
-- the text encoding is set to UTF8.
soapXmlUtf8 :: String            -- ^The content type as seen in the HTTP header
            -> BS.ByteString
            -> BS.ByteString
soapXmlUtf8 contentType = bsToUtf8 (encoding contentType) . setUtf8EncodingInXmlHeader

-- |Converts a SOAP request to String. If the request contains a XML header,
-- the text encoding is set to UTF8.
soapXmlToString :: String            -- ^The content type as seen in the HTTP header
                -> BS.ByteString
                -> String
soapXmlToString contentType = bsToString (encoding contentType) . setUtf8EncodingInXmlHeader

bsToUtf8 :: String -> BS.ByteString -> BS.ByteString
bsToUtf8 enc = stringToUtf8Bs . bsToString enc

bsToString :: String -> BS.ByteString -> String
bsToString enc bs = E.decodeLazyByteString (E.encodingFromString enc) bs

stringToUtf8Bs :: String -> BS.ByteString
stringToUtf8Bs = E.encodeLazyByteString E.UTF8

-- *** HTTP Header

-- |Produces a HTTP content type header from a charector encoding 
soapContentType :: Maybe String  -- ^ If nothing then it defaults to ISO-8859-1
                -> String
soapContentType = maybe ("application/soap+xml;charset=" ++ httpDefaultEncoding) id

-- |Extracts charector encoding from a HTTP content type header
encoding :: String -> String
encoding httpContentType =
    case matchRegex (mkRegex "charset=([^; ]*)") httpContentType of
      Just (x:_) -> x
      _          -> httpDefaultEncoding

-- Default charset=ISO-8859-1. See:
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.7.1
-- http://www.w3.org/International/O-HTTP-charset
httpDefaultEncoding :: String
httpDefaultEncoding = "ISO-8859-1"

-- *** XML Header

-- http://www.w3.org/TR/REC-xml/#TextEntities

setUtf8EncodingInXmlHeader :: BS.ByteString -> BS.ByteString
setUtf8EncodingInXmlHeader xml =
  let replaceEnc (name, value)
          | name == "encoding"  = (name, "UTF-8")
          | otherwise           = (name, value) 
  in case parse headerParser "" xml of
       Left _ -> xml
       Right (attrs, rest) -> BS.append (mkHeader $ map replaceEnc attrs) rest

mkHeader :: [(String, String)] -> BS.ByteString
mkHeader attrs =
  let mkAttr (name, value) = " " ++ name ++ "=\"" ++ value ++ "\""
  in BsC8.pack ("<?xml" ++ concatMap mkAttr attrs ++ "?>\n")

headerParser :: Parser ([(String, String)], BS.ByteString)
headerParser = do
  _ <- string "<?xml"
  spaces
  attrs <- many attrParser
  _ <- string "?>"
  endPos <- getInput
  return (attrs, endPos)

attrParser :: Parser (String, String)
attrParser = do
  name <- many1 letter
  spaces
  _ <- char '='
  spaces
  _ <- char '"'
  value <- many $ noneOf "\""
  _ <- char '"'
  spaces
  return (name, value)