diff --git a/Data/ByteString/Lazy/Util.hs b/Data/ByteString/Lazy/Util.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Util.hs @@ -0,0 +1,89 @@ +--------------------------------------------------------- +-- | +-- Module : Data.ByteString.Lazy.Util +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Various utilities to assist in dealing with lazy bytestrings. +-- +--------------------------------------------------------- + +module Data.ByteString.Lazy.Util + ( ord + , stripPrefix + , breakAt + , breakAtString + , takeLine + , chompBS + , takeUntilBlank + ) where + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Char as C +import Data.Word (Word8) + +-- | Get the ASCII value of character. Differers from regular ord in that +-- it returns an Integral, so it is automatically cast to eg a Word8. +ord :: Integral a => Char -> a +ord = fromInteger . toInteger . C.ord + +-- | Strip a prefix from a bytestring if it's there. +stripPrefix :: Word8 -> BS.ByteString -> BS.ByteString +stripPrefix p bs + | BS.null bs = bs + | BS.head bs == p = BS.tail bs + | otherwise = bs + +-- | Break a bytestring into two at the first occurence of the given 'Word8'. +-- That 'Word8' should not appear in either piece. +breakAt :: Word8 -> BS.ByteString -> (BS.ByteString, BS.ByteString) +breakAt p bs = + let (x, y) = BS.span (/= p) bs + y' = stripPrefix p y + in (x, y') + +-- | Same as 'breakAt', but use a bytestring instead of a 'Word8'. +breakAtString :: BS.ByteString + -> BS.ByteString + -> (BS.ByteString, BS.ByteString) +breakAtString p c + | BS.null c = (BS.empty, BS.empty) + | p `BS.isPrefixOf` c = (BS.empty, BS.drop (BS.length p) c) + | otherwise = + let x = BS.head c + xs = BS.tail c + (next, rest) = breakAtString p xs + in (BS.cons' x next, rest) + +-- | Take a single line from a bytestring. +takeLine :: BS.ByteString -> (BS.ByteString, BS.ByteString) +takeLine bs = + let (x, y) = BS.span (/= ord '\n') bs + x' = if not (BS.null x) && BS.last x == ord '\r' then BS.init x else x + y' = if not (BS.null y) && BS.head y == ord '\n' then BS.tail y else y + in (x', y') + +-- | Removes newline characters from the end of a string. +chompBS :: BS.ByteString -> BS.ByteString +chompBS s + | BS.null s = s + | BS.last s == ord '\n' = + if BS.length s == 1 || BS.last (BS.init s) /= ord '\r' + then BS.init s + else BS.init (BS.init s) + | BS.last s == ord '\r' = BS.init s + | otherwise = s + +-- | Take each line until the first blank line and return as first. +-- The rest of the content is returned as second. +takeUntilBlank :: BS.ByteString -> ([BS.ByteString], BS.ByteString) +takeUntilBlank bs = + let (next, rest) = takeLine bs + in if BS.null next + then ([], rest) + else let (nexts, rest') = takeUntilBlank rest + in (next : nexts, rest') diff --git a/Data/Mime/Header.hs b/Data/Mime/Header.hs new file mode 100644 --- /dev/null +++ b/Data/Mime/Header.hs @@ -0,0 +1,69 @@ +--------------------------------------------------------- +-- | +-- Module : Data.Mime.Header +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Functions for parsing MIME headers (Key: value; k1=v1; k2=v2) +-- +--------------------------------------------------------- + +module Data.Mime.Header + ( Header + , parseHeader + , lookupHeader + , lookupHeaderAttr + ) where + +import Data.String.Util +import Data.ByteString.Class +import qualified Data.ByteString.Lazy as BS + +type SMap = [(String, String)] + +-- | A single MIME header. +type Header = (String, String, SMap) + +-- | Parse a header line in the format +-- Name: value; attkey=attval; attkey2=attval2. +parseHeader :: BS.ByteString -> Header +parseHeader bs = + let s = fromLazyByteString bs + (k, rest) = span (/= ':') s + (v, attrs) = parseRest rest + in (k, v, attrs) where + parseRest :: String -> (String, SMap) + parseRest s = + let (v, rest) = span (/= ';') s + attrs = parseAttrs rest + in (dropPrefix ": " v, attrs) + parseAttrs :: String -> SMap + parseAttrs [] = [] + parseAttrs s = + let s' = dropPrefix "; " s + (next, rest) = span (/= ';') s' + (k, v) = span (/= '=') next + v' = dropPrefix "=" v + v'' = dropQuotes v' + in (k, v'') : parseAttrs rest + +lookupHeaderAttr :: Monad m => String -> String -> [Header] -> m String +lookupHeaderAttr k1 k2 [] = + fail $ "Could not find header when looking for attr: " ++ + k1 ++ ":" ++ k2 +lookupHeaderAttr k1 k2 ((key, _, vals):rest) + | k1 == key = case lookup k2 vals of + Nothing -> fail $ "Could not find header attr " + ++ k1 ++ ":" ++ k2 + Just v -> return v + | otherwise = lookupHeaderAttr k1 k2 rest + +lookupHeader :: Monad m => String -> [Header] -> m String +lookupHeader k [] = fail $ "Header " ++ k ++ " not found" +lookupHeader k ((key, val, _):rest) + | k == key = return val + | otherwise = lookupHeader k rest diff --git a/Data/String/Util.hs b/Data/String/Util.hs new file mode 100644 --- /dev/null +++ b/Data/String/Util.hs @@ -0,0 +1,55 @@ +--------------------------------------------------------- +-- | +-- Module : Data.String.Util +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Various utilities to assist in dealing with Strings. +-- +--------------------------------------------------------- + +module Data.String.Util + ( chomp + , dropPrefix + , dropQuotes + , splitList + ) where + +import Data.List (isPrefixOf) + +-- | Removes newline characters from the end of a string. +chomp :: String -> String +chomp s + | null s = s + | last s == '\n' = + if length s == 1 || last (init s) /= '\r' + then init s + else init (init s) + | last s == '\r' = init s + | otherwise = s + +-- | Drop a string from the beginning of another, if present. +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix x y + | x `isPrefixOf` y = drop (length x) y + | otherwise = y + +-- | Drop surrounding quotes, if present. +dropQuotes :: String -> String +dropQuotes s + | length s > 2 && head s == '"' && last s == '"' = tail $ init s + | otherwise = s + +-- | Split up a list into sublists at every occurence of the split +-- element. That element is thrown away. +splitList :: Eq a => a -> [a] -> [[a]] +splitList c s = helper s [[]] where + helper [] res = filter (not . null) $ reverse $ map reverse res + helper (x:xs) (y:ys) + | x == c = helper xs ([]:y:ys) + | otherwise = helper xs ((x:y):ys) + helper _ [] = error "This case should never be" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, Michael Snoyman. 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Web/Encodings.hs b/Web/Encodings.hs new file mode 100644 --- /dev/null +++ b/Web/Encodings.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE TypeSynonymInstances #-} +--------------------------------------------------------- +-- | +-- Module : Web.Encodings +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Various web encodings. +-- +--------------------------------------------------------- +module Web.Encodings + ( + -- * Simple encodings. + -- ** URL (percentage encoding) + encodeUrl + , decodeUrl + -- ** HTML (entity encoding) + , encodeHtml +-- FIXME , decodeHtml + -- ** JSON + , encodeJson + -- * HTTP level encoding. + -- ** Query string- pairs of percentage encoding + , encodeUrlPairs + , decodeUrlPairs + -- ** Post parameters + , FileInfo (..) + , parseMultipart + , parsePost + -- ** Cookies + , decodeCookies + ) where + +import Data.ByteString.Class +import qualified Data.ByteString.Lazy as BS +import Text.Printf (printf) +import Data.Word (Word8) +import Numeric (showHex) +import Data.List (isPrefixOf) +import Data.ByteString.Lazy.Util hiding (ord) +import Data.Mime.Header +import Data.Maybe (fromMaybe) + +-- | Encode all but unreserved characters with percentage encoding. +-- +-- Assumes use of UTF-8 character encoding. +encodeUrl :: (LazyByteString x, LazyByteString y) => x -> y +encodeUrl = fromLazyByteString + . BS.concatMap encodeUrlByte + . toLazyByteString + +ord :: Integral i => Char -> i +ord = fromIntegral . fromEnum + +encodeUrlByte :: Word8 -> BS.ByteString +encodeUrlByte w + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | ord 'A' <= w && w <= ord 'Z' = BS.singleton w + | ord 'a' <= w && w <= ord 'z' = BS.singleton w + | ord '0' <= w && w <= ord '9' = BS.singleton w + | ord '-' == w = BS.singleton w + | ord '_' == w = BS.singleton w + | ord '.' == w = BS.singleton w + | ord '~' == w = BS.singleton w + | otherwise = toLazyByteString $ (printf "%%%02x" w :: String) + +-- | Decode percentage encoding. Assumes use of UTF-8 character encoding. +decodeUrl :: (LazyByteString x, LazyByteString y) => x -> y +decodeUrl = fromLazyByteString . BS.pack . decodeUrlList . BS.unpack . toLazyByteString + +decodeUrlList :: [Word8] -> [Word8] +-- note: percent sign is 37 +decodeUrlList (37:x:y:rest) = (fromHex x) * 16 + (fromHex y) + : decodeUrlList rest +decodeUrlList (x:rest) + | x == 43 = 32 : decodeUrlList rest -- convert plus to space + | otherwise = x : decodeUrlList rest +decodeUrlList [] = [] + +fromHex :: Word8 -> Word8 +fromHex x + | 48 <= x && x <= 57 = x - 48 -- 0 - 9 + | 65 <= x && x <= 70 = x - 65 + 10 -- A - F + | 97 <= x && x <= 102 = x - 97 + 10 -- a - f + | otherwise = 0 -- FIXME + +-- | Escape special HTML characters. +encodeHtml :: String -> String +encodeHtml = concatMap encodeHtmlChar + +encodeHtmlChar :: Char -> String +encodeHtmlChar '<' = "<" +encodeHtmlChar '>' = ">" +encodeHtmlChar '&' = "&" +encodeHtmlChar '"' = """ +encodeHtmlChar '\'' = "'" +encodeHtmlChar c = [c] + +-- | Convert into key-value pairs. Strips the leading ? if necesary. +decodeUrlPairs :: (LazyByteString x, LazyByteString y, LazyByteString z) + => x + -> [(y, z)] +decodeUrlPairs = map decodeUrlPair + . BS.split (ord '&') + . BS.dropWhile (== ord '?') + . toLazyByteString + +decodeUrlPair :: (LazyByteString a, LazyByteString b) + => BS.ByteString + -> (a, b) +decodeUrlPair b = + let (x, y) = BS.break (== ord '=') b + y' = BS.dropWhile (== ord '=') y + in (decodeUrl x, decodeUrl y') + +-- | Convert a list of key-values pairs into a query string. +-- Does not include the question mark at the beginning. +encodeUrlPairs :: (LazyByteString x, LazyByteString y, LazyByteString z) + => [(x, y)] + -> z +encodeUrlPairs = fromLazyByteString + . BS.intercalate (BS.singleton $ ord '&') + . map encodeUrlPair + +encodeUrlPair :: (LazyByteString x, LazyByteString y) + => (x, y) + -> BS.ByteString +encodeUrlPair (x, y) = BS.concat + [ encodeUrl x + , BS.singleton $ ord '=' + , encodeUrl y + ] + +-- | Perform JSON-encoding on a string. Does not wrap in quotation marks. +encodeJson :: LazyByteString x => String -> x +encodeJson = fromLazyByteString . toLazyByteString . encJSString + +-- | Taken from json package by Sigbjorn Finne. +encJSString :: String -> String +encJSString jss = go jss + where + go s1 = + case s1 of + (x :xs) | x < '\x20' -> '\\' : encControl x (go xs) + ('"' :xs) -> '\\' : '"' : go xs + ('\\':xs) -> '\\' : '\\' : go xs + (x :xs) -> x : go xs + "" -> "" + + encControl x xs = case x of + '\b' -> 'b' : xs + '\f' -> 'f' : xs + '\n' -> 'n' : xs + '\r' -> 'r' : xs + '\t' -> 't' : xs + _ | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs + | x < '\x100' -> 'u' : '0' : '0' : hexxs + | x < '\x1000' -> 'u' : '0' : hexxs + | otherwise -> 'u' : hexxs + where hexxs = showHex (fromEnum x) xs + +-- | Information on an uploaded file. +data FileInfo = FileInfo + { fileName :: String + , fileContentType :: String + , fileContent :: BS.ByteString + } + +-- | Parse a multipart form into parameters and files. +parseMultipart :: LazyByteString lbs + => lbs -- ^ boundary + -> BS.ByteString -- ^ content + -> ([(String, String)], [(String, FileInfo)]) +parseMultipart boundary' content = + let boundary :: String + boundary = fromLazyByteString $ toLazyByteString boundary' + pieces = getPieces boundary content + getJusts [] = [] + getJusts (Nothing:rest) = getJusts rest + getJusts ((Just x):rest) = x : getJusts rest + getLefts [] = [] + getLefts (Left x:rest) = x : getLefts rest + getLefts (Right _:rest) = getLefts rest + getRights [] = [] + getRights (Left _:rest) = getRights rest + getRights (Right x:rest) = x : getRights rest + pieces' = getJusts $ map parsePiece pieces + in (getLefts pieces', getRights pieces') + +-- | Parse a single segment of a multipart/form-data POST. +parsePiece :: Monad m + => BS.ByteString + -> m (Either (String, String) (String, FileInfo)) +parsePiece b = do + let (headers', content) = takeUntilBlank b + headers = map parseHeader headers' + name <- lookupHeaderAttr "Content-Disposition" "name" headers + let filename = lookupHeaderAttr "Content-Disposition" "filename" headers + let ctype = fromMaybe "" $ lookupHeader "Content-Type" headers + -- charset = lookupHeaderAttr "Content-Type" "charset" headers + return $ case filename of + Nothing -> Left (name, (fromLazyByteString $ chompBS content)) + Just f -> Right (name, FileInfo f ctype content) + +-- | Split up a bytestring along the given boundary. +getPieces :: String -- ^ boundary + -> BS.ByteString -- ^ content + -> [BS.ByteString] +{- FIXME this would be nice... +getPieces b c = + let fullBound = ord '-' `BS.cons'` (ord '-' `BS.cons'` b) + pieces = fullBound `BS.split` c + in filter (/= toLazyByteString "--") $ + filter (not . BS.null) $ + map chompBS pieces +-} +getPieces b c + | BS.null c = [] + | otherwise = + let fullBound = toLazyByteString ('-':'-':b) + (next, rest) = breakAtString fullBound c + rest' = checkRest rest + rest'' = getPieces b rest' + in if BS.null next then rest'' else chompBS next : rest'' + where + br = ord '\r' + bn = ord '\n' + dash = ord '-' + checkRest bs + | BS.length bs < 2 = BS.empty + | BS.head bs == bn = BS.tail bs + | BS.head bs == br && BS.head (BS.tail bs) == bn = + BS.tail $ BS.tail bs + | BS.head bs == dash && BS.head (BS.tail bs) == dash = BS.empty + | otherwise = BS.empty -- FIXME + +-- | Parse a post request. This function determines the correct decoding +-- function to use. +parsePost :: String -- ^ content type + -> String -- ^ content length + -> BS.ByteString -- ^ body of the post + -> ([(String, String)], [(String, FileInfo)]) +parsePost ctype clength body + | urlenc `isPrefixOf` ctype = (decodeUrlPairs content, []) + | formBound `isPrefixOf` ctype = parseMultipart boundProcessed content + | otherwise = ([], []) + where + len = case reads clength of + ((x, _):_) -> x + [] -> 0 + content = BS.take len body + urlenc = "application/x-www-form-urlencoded" + formBound = "multipart/form-data; boundary=" + boundProcessed = drop (length formBound) ctype + +-- | Decode the value of an HTTP_COOKIE header into key/value pairs. +decodeCookies :: String -> [(String, String)] +decodeCookies [] = [] +decodeCookies s = + let (first, rest) = break (== ';') s + in decodeCookie first : decodeCookies (dropWhile (== ';') rest) + +decodeCookie :: String -> (String, String) +decodeCookie s = + let (key, value) = break (== '=') s + key' = dropWhile (== ' ') key + value' = + case value of + ('=':rest) -> rest + x -> x + in (key', value') diff --git a/web-encodings.cabal b/web-encodings.cabal new file mode 100644 --- /dev/null +++ b/web-encodings.cabal @@ -0,0 +1,21 @@ +name: web-encodings +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Encapsulate multiple web encoding in a single package. +description: The idea is to minimize external dependencies so this is usable in just about any context. +category: Web +stability: stable +cabal-version: >= 1.2 +build-type: Simple +homepage: http://github.com/snoyberg/web-encodings/tree/master + +library + build-depends: base, bytestring, bytestring-class + exposed-modules: Web.Encodings + other-modules: Data.Mime.Header, + Data.ByteString.Lazy.Util, + Data.String.Util + ghc-options: -Wall