URLEncoded.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |Implements a data type for constructing and destructing
-- x-www-urlencoded strings. See
-- <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4.1>

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 ]