diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2012-2013 Stevens Institute of Technology + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Stevens Institute of Technology nor the + names of the authors and other contributors may be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Encoding.hs b/Network/HTTP/Encoding.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Encoding.hs @@ -0,0 +1,133 @@ +-- | Encoding and decoding of bodies and complete HTTP messages. See +-- package 'jespresso' for an example of usage. +module Network.HTTP.Encoding (-- * Operations on HTTP messages + decode + ,encode + -- * Operations on the bodies of HTTP messages + ,withDecodedBody + ,withDecodedBodyM + ,decodeBody + ,encodeBody + -- * Types + ,HasBody(..) + ,EncodingError + ,DecodingResult(..)) where + +import Network.HTTP.Encoding.Content +import Network.HTTP.Encoding.Character +import Network.HTTP.Encoding.Error +import Network.HTTP +import Data.ByteString.Lazy +import Codec.Text.IConv +import Control.Applicative +import Data.ByteString.Lazy.UTF8 (fromString, toString) + +targetEncoding = "UTF-8" + +class HasBody a where + getBody :: a b -> b + setBody :: c -> a b -> a c + +instance HasBody Request where + getBody = rqBody + setBody body rq = rq {rqBody = body} + +instance HasBody Response where + getBody = rspBody + setBody body rsp = rsp {rspBody = body} + +-- | The result of decoding a message body +data DecodingResult = DecodingResult {decodedBody :: String + ,originalEncoding :: EncodingName + } + +-- | Decodes and decompresses the response or request body using the +-- information in the headers and content and possibly returns the +-- body in UTF8 +decodeBody :: (HasHeaders (r ByteString), HasBody r) + => r ByteString + -> Either EncodingError DecodingResult +decodeBody r = + let headers = getHeaders r + body = getBody r + contentEnc = getContentEncoding headers + decodeBody2 :: String -> Either EncodingError DecodingResult + decodeBody2 enc = + do dbody <- decompress contentEnc body + x <- either (Right) (Left . IConvError) + (convertStrictly enc targetEncoding dbody) + + return $ DecodingResult {decodedBody = toString x + ,originalEncoding = enc} + in case snd $ getContentTypeAndCharacterEncoding headers of + Nothing -> decodeBody2 "utf-8" + Just charEnc -> decodeBody2 charEnc + +flipEither :: Either a b -> Either b a +flipEither (Left x) = Right x +flipEither (Right x) = Left x + +-- | Decode the body of an HTTP message and return the original +-- encoding name and the same message with decoded body (as +-- UTF8-encoded string) and updated character and content encoding +-- headers. +decode :: (HasHeaders (m ByteString), HasHeaders (m String), HasBody m) + => m ByteString + -> Either EncodingError (String, m String) +decode r = do res <- decodeBody r + let hdrs = updateContentEncoding IdentityCompression (getHeaders r) + hdrs2= setCharacterEncoding (originalEncoding res) hdrs + return (originalEncoding res + ,flip setHeaders hdrs $ setBody (decodedBody res) r) + +-- |Takes a haskell UTF8-encoded string and produces a stream, encoded +-- and compressed +encodeBody :: EncodingName + -> ContentEncoding + -> String + -> Either EncodingError ByteString +encodeBody source_enc ce str = + do body <- either Right + (Left . IConvError) + (convertStrictly targetEncoding source_enc (fromString str)) + compress ce body + +-- | Encode the UTF8-encoded body of an HTTP message with the provided +-- encoding. +encode :: (HasHeaders (m String), HasBody m) + => EncodingName -> m String -> Either EncodingError (m ByteString) +encode ch_enc r = + let headers = getHeaders r + body = getBody r + in let ce = getContentEncoding headers in + do ebody <- encodeBody ch_enc ce body + return $ setBody ebody r + +either2Maybe (Left x) = Just x +either2Maybe (Right _) = Nothing + +-- | Allows to lift a transformation function operating on decoded +-- (UTF-8) bodies to bodies of requests with encoded (and compressed) +-- bodies. +withDecodedBody :: (HasHeaders (r String), HasHeaders (r ByteString), HasBody r) + => (String -> String) + -> r ByteString + -> Either EncodingError (r ByteString) +withDecodedBody f r = + do (enc, dr) <- decode r + let mdr = setBody (f $ getBody dr) dr + encode enc mdr + +-- | A monadic version of 'withDecodeBody' +withDecodedBodyM :: (Monad m, HasHeaders (r String), HasHeaders (r ByteString), + HasBody r) + => (String -> m String) + -> r ByteString + -> m (Either EncodingError (r ByteString)) +withDecodedBodyM f r = + case decode r of + Left err -> return $ Left err + Right (enc, dr) -> f (getBody dr) >>= \mbody -> + case encode enc $ setBody mbody dr of + Left err -> return $ Left err + Right mr -> return $ Right mr diff --git a/Network/HTTP/Encoding/Character.hs b/Network/HTTP/Encoding/Character.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Encoding/Character.hs @@ -0,0 +1,61 @@ +-- | Detection and of character encodings of HTTP message bodies +module Network.HTTP.Encoding.Character + (getContentTypeAndCharacterEncoding + ,setCharacterEncoding + ,tryAsUTF8) where + +import Network.HTTP +import Codec.Text.IConv +import Codec.MIME.Parse +import Codec.MIME.Type +import Control.Applicative hiding (many, (<|>)) +import Data.Char (toLower, ord) +import Data.ByteString.Lazy.UTF8 (uncons) +import Data.ByteString.Lazy (ByteString) +import Control.Monad + +-- | Looks for and parses the ContentType header. Returns the +-- (optional) content-type and (optional) the character encoding name. +getContentTypeAndCharacterEncoding :: [Header] -> + (Maybe Type, Maybe EncodingName) +getContentTypeAndCharacterEncoding [] = (Nothing, Nothing) +getContentTypeAndCharacterEncoding (Header HdrContentType str:_) = + parseContentTypeHdr str +getContentTypeAndCharacterEncoding (_:hs) = getContentTypeAndCharacterEncoding hs + +-- | Sets the given character encoding name in the given header. If +-- there is no content type header in the header list, it defaults to +-- the text/plain content type +setCharacterEncoding :: EncodingName -> [Header] -> [Header] +setCharacterEncoding enc [] = [plainText enc] +setCharacterEncoding enc ((Header HdrContentType str):rest) = + let (mtype, _) = parseContentTypeHdr str + newhdr = case mtype of + Nothing -> plainText enc + Just ty -> Header HdrContentType $ showType $ setMIMEEncoding ty enc + in newhdr:rest + +plainText :: EncodingName -> Header +plainText enc = Header HdrContentType $ showType $ + Type {mimeType = (Text "plain") + ,mimeParams = [("charset", enc)]} + +setMIMEEncoding :: Type -> EncodingName -> Type +setMIMEEncoding ty enc = ty {mimeParams = map replaceEnc $ mimeParams ty} + where replaceEnc (pname, _) | pname == "charset" = (pname, enc) + replaceEnc x = x + +parseContentTypeHdr :: String -> (Maybe Type, Maybe EncodingName) +parseContentTypeHdr str = + case parseContentType str of + Nothing -> (Nothing, Nothing) + Just ctype -> (Just ctype, + (map toLower) <$> lookup "charset" (mimeParams ctype)) + +-- | Tries to decode a bytestring as UTF-8. Returns nothing if any +-- illegal characters are encountered +tryAsUTF8 :: ByteString -> Maybe String +tryAsUTF8 bs = uncons bs >>= \(c, bs') -> + if (ord c == 0xFFFD) then mzero + else tryAsUTF8 bs' >>= \s -> return (c:s) + diff --git a/Network/HTTP/Encoding/Content.hs b/Network/HTTP/Encoding/Content.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Encoding/Content.hs @@ -0,0 +1,63 @@ +-- | Deals with content encoding (compression) of message bodies: +-- detection, update and compression/decompression +module Network.HTTP.Encoding.Content(ContentEncoding(..) + ,getContentEncoding + ,updateContentEncoding + ,decompress + ,compress + ) where + +import Network.HTTP +import Network.HTTP.Encoding.Error +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.Zlib as Zlib +import Data.ByteString.Lazy +import Data.Maybe + +-- | Represents the content encoding, per the HTTP/1.1 standard. +data ContentEncoding = GZip | Compress | Deflate | IdentityCompression + +instance Show ContentEncoding where + show GZip = "gzip" + show Compress = "compress" + show Deflate = "deflate" + show IdentityCompression = "" + +-- | Determines the content encoding from a list of headers. Defaults +-- to 'IdentityCompression' +getContentEncoding :: [Header] -> ContentEncoding +getContentEncoding [] = IdentityCompression +getContentEncoding (Header HdrContentEncoding "gzip":hs) = GZip +getContentEncoding (Header HdrContentEncoding "x-gzip":hs) = GZip +getContentEncoding (Header HdrContentEncoding "compress":hs) = Compress +getContentEncoding (Header HdrContentEncoding "x-compress":hs) = Compress +getContentEncoding (Header HdrContentEncoding "deflate":hs) = Deflate +getContentEncoding (h:hs) = getContentEncoding hs + +-- | Given the list of headers, updates content encoding to the +-- specified. +updateContentEncoding :: ContentEncoding -> [Header] -> [Header] +updateContentEncoding ce [] = maybeToList $ contentEncodingHeader ce +updateContentEncoding ce (Header HdrContentEncoding _:hs) = + hs ++ maybeToList (contentEncodingHeader ce) +updateContentEncoding ce (h:hs) = h:updateContentEncoding ce hs + +contentEncodingHeader :: ContentEncoding -> Maybe Header +contentEncodingHeader IdentityCompression = Nothing +contentEncodingHeader ce = Just $ Header HdrContentEncoding (show ce) + +-- | Decompresses a 'Bytestring' assuming a given content encoding. The +-- Compress encoding (LZW algorithm) is not supported at this time. +decompress :: ContentEncoding -> ByteString -> Either EncodingError ByteString +decompress GZip bs = Right $ GZip.decompress bs +decompress Compress body = Left UnsupportedCompressionAlgorithm +decompress Deflate bs = Right $ Zlib.decompress bs +decompress IdentityCompression bs = Right bs + +-- | Compresses a 'Bytestring' assuming a given content encoding. The +-- Compress encoding (LZW algorithm) is not supported at this time. +compress :: ContentEncoding -> ByteString -> Either EncodingError ByteString +compress GZip body = Right $ GZip.compress body +compress Compress body = Left UnsupportedCompressionAlgorithm +compress Deflate body = Right $ Zlib.compress body +compress IdentityCompression rsp = Right rsp diff --git a/Network/HTTP/Encoding/Error.hs b/Network/HTTP/Encoding/Error.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Encoding/Error.hs @@ -0,0 +1,30 @@ +-- | Errors that may occur during decoding/encoding of HTTP message bodies +module Network.HTTP.Encoding.Error (EncodingError (..) + ,ConversionError (..)) where + +import Codec.Text.IConv (ConversionError + ,reportConversionError) + +-- | Encoding/Decoding error message +data EncodingError = CannotDetermineCharacterEncoding + -- ^ Character decoding is not specified and + -- cannot be guessed + | UnsupportedCompressionAlgorithm + -- ^ A compression algorithm is not supported (LZW) + | IConvError ConversionError + -- ^ IConv conversion error + | GenericError String + -- ^ Other error + +instance Show EncodingError where + show err = case err of + CannotDetermineCharacterEncoding -> + "No character encoding was specified in message headers \ + \and the body character encoding cannot be determined" + UnsupportedCompressionAlgorithm -> + "Sorry, the 'compress' algorithm is not supported at this time" + IConvError conv_err -> + "Charset conversion error in iconv: " ++ + show (reportConversionError conv_err) + GenericError err -> "Generic error: " ++ err + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/http-encodings.cabal b/http-encodings.cabal new file mode 100644 --- /dev/null +++ b/http-encodings.cabal @@ -0,0 +1,41 @@ +Name: http-encodings +Version: 0.9 +Synopsis: A library for encoding and decoding bodies of HTTP messages +Description: A library for encoding and decoding bodies of HTTP messages, designed to work with the HTTP and http-server libraries. No heuristic encoding detection at this time. WANTED: a library implementing the Unix "compress" command encoding/decoding (or the LZW algorithm). + +License: BSD3 +License-file: LICENSE +Author: Andrey Chudnov +Maintainer: Andrey Chudnov +Homepage: http://github.com/achudnov/http-encodings +Bug-reports: http://github.com/achudnov/http-encodings/issues +Copyright: (c) 2012-2013 Stevens Institute of Technology +Category: Web +Build-type: Simple +Stability: Experimental +Cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/achudnov/http-encodings.git + +source-repository this + type: git + location: git://github.com/achudnov/http-encodings.git + tag: 0.9 + +Library + Exposed-modules: Network.HTTP.Encoding, + Network.HTTP.Encoding.Character, + Network.HTTP.Encoding.Content, + Network.HTTP.Encoding.Error + Build-depends: base == 4.* + , HTTP == 4000.* + , bytestring >= 0.9 && < 0.10 + , parsec == 3.* + , utf8-string == 0.3.* + , iconv == 0.4.* + , zlib == 0.5.* + , mtl == 2.* + , mime == 0.3.* + Default-language: Haskell2010