packages feed

web-encodings (empty) → 0.0.0

raw patch · 7 files changed

+542/−0 lines, 7 filesdep +basedep +bytestringdep +bytestring-classsetup-changed

Dependencies added: base, bytestring, bytestring-class

Files

+ Data/ByteString/Lazy/Util.hs view
@@ -0,0 +1,89 @@+---------------------------------------------------------+-- |+-- Module        : Data.ByteString.Lazy.Util+-- Copyright     : Michael Snoyman+-- License       : BSD3+--+-- Maintainer    : Michael Snoyman <michael@snoyman.com>+-- 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')
+ Data/Mime/Header.hs view
@@ -0,0 +1,69 @@+---------------------------------------------------------+-- |+-- Module        : Data.Mime.Header+-- Copyright     : Michael Snoyman+-- License       : BSD3+--+-- Maintainer    : Michael Snoyman <michael@snoyman.com>+-- 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
+ Data/String/Util.hs view
@@ -0,0 +1,55 @@+---------------------------------------------------------+-- |+-- Module        : Data.String.Util+-- Copyright     : Michael Snoyman+-- License       : BSD3+--+-- Maintainer    : Michael Snoyman <michael@snoyman.com>+-- 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"
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Web/Encodings.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE TypeSynonymInstances #-}+---------------------------------------------------------+-- |+-- Module        : Web.Encodings+-- Copyright     : Michael Snoyman+-- License       : BSD3+--+-- Maintainer    : Michael Snoyman <michael@snoyman.com>+-- 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 '<' = "&lt;"+encodeHtmlChar '>' = "&gt;"+encodeHtmlChar '&' = "&amp;"+encodeHtmlChar '"' = "&quot;"+encodeHtmlChar '\'' = "&#39;"+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')
+ web-encodings.cabal view
@@ -0,0 +1,21 @@+name:            web-encodings+version:         0.0.0+license:         BSD3+license-file:    LICENSE+author:          Michael Snoyman <michael@snoyman.com>+maintainer:      Michael Snoyman <michael@snoyman.com>+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