diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Josh Hoyt. +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. + + * The names of the contributors may not 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 +HOLDER 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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Data/URLEncoded.hs b/src/Data/URLEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Data/URLEncoded.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- |Implements a data type for constructing and destructing +-- x-www-urlencoded strings. See +-- + +module Data.URLEncoded + ( -- * Representation of a URL-encoded string + URLEncoded + + -- * Generate + , empty + , importString + , importList + , (%=) + , (%=?) + + -- * Query + , null + , keys + , lookup + , lookup1 + , pairs + + -- * Export + , addToURI + , export + ) +where + +import qualified Prelude +import Prelude hiding ( null, lookup ) +import Data.List.Split ( splitOn ) +import Control.Monad ( liftM ) +import Control.Arrow ( (>>>) ) +import Control.Monad.Error ( MonadError ) +import Network.URI ( unEscapeString, escapeURIString, isUnreserved, URI(uriQuery) ) +import Data.Monoid ( Monoid ) +import Data.List ( intercalate ) + +-- | A container for URLEncoded data +newtype URLEncoded = URLEncoded { pairs :: [(String, String)] } + deriving (Monoid, Eq) + +-- | Is this URLEncoded data empty? +null :: URLEncoded -> Bool +null = Prelude.null . pairs + +-- | URLEncoded data with no pairs +empty :: URLEncoded +empty = URLEncoded [] + +-- |Import this list of pairs as URLEncoded data +importList :: [(String, String)] -> URLEncoded +importList = URLEncoded + +-- |All of the keys from the URLEncoded value, in order, preserving duplicates +keys :: URLEncoded -> [String] +keys = map fst . pairs + +-- |Create singleton URLEncoded data containing the supplied key and value +(%=) :: String -> String -> URLEncoded +k %= v = URLEncoded [(k, v)] + +-- |If the second value is Nothing, return empty URLEncoded +-- data. Otherwise return singleton URLEncoded data that contains the +-- given key and value. +(%=?) :: String {-^key-} -> Maybe String {-^value-} -> URLEncoded +k %=? v = maybe empty (k %=) v + +-- |Add this URL-encoded data to the query part of a URI, after any +-- existing query arguments. +addToURI :: URLEncoded -> URI -> URI +addToURI q u = + let initialChar = if Prelude.null (uriQuery u) then '?' else '&' + in u { uriQuery = uriQuery u ++ (initialChar:export q) } + +-- |Convert this URLEncoded object into an x-www-urlencoded String +-- (The resulting string is 7-bit clean ASCII, containing only +-- unreserved URI characters and %-encoded values) +export :: URLEncoded -> String +export q = + let esc = escapeURIString isUnreserved + encodePair (k, v) = esc k ++ "=" ++ esc v + in intercalate "&" $ map encodePair $ pairs q + +instance Show URLEncoded where + showsPrec _ q = (export q ++) + +-- |Parse this string as x-www-urlencoded +importString :: MonadError e m => String -> m URLEncoded +importString = splitOn "&" >>> mapM parsePair >>> liftM URLEncoded + where parsePair p = + case break (== '=') p of + (_, []) -> fail $ "Missing value in query string: " ++ show p + (k, '=':v) -> return ( unEscapeString k + , unEscapeString v + ) + unknown -> error $ "impossible: " ++ show unknown + +-- |Return the /first/ value for the given key, or throw an error if the +-- key is not present in the URLEncoded data. +lookup1 :: MonadError e m => String -> URLEncoded -> m String +lookup1 k = pairs >>> Prelude.lookup k >>> maybe missing return + where missing = fail $ "Key not found: " ++ show k + +-- |Return all values whose keys match the supplied key, in the order +-- they appear in the query. Will return an empty list if no keys +-- match. +lookup :: String -> URLEncoded -> [String] +lookup k urlenc = [ v | (k', v) <- pairs urlenc, k' == k ] diff --git a/urlencoded.cabal b/urlencoded.cabal new file mode 100644 --- /dev/null +++ b/urlencoded.cabal @@ -0,0 +1,21 @@ +name: urlencoded +Cabal-Version: >= 1.6 +version: 0.0 +synopsis: Generate or process x-www-urlencoded data + +description: Generate or process x-www-urlencoded data as it + appears in HTTP or HTTPS URIs and HTTP POSTs. See + + +category: Web +homepage: http://patch-tag.com/repo/urlencoded +stability: alpha +license: BSD3 +license-file: LICENSE +author: Josh Hoyt +maintainer: joshhoyt@gmail.com +build-depends: base == 4.*, network == 2.2.*, mtl, split == 0.1.* +build-type: Simple +ghc-options: -Wall +hs-source-dirs: src +exposed-modules: Data.URLEncoded