{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, CPP #-}
-- |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
    , filter
    , URLShow(..)
    , URLEncode(..)

    -- * Generate
    , empty
    , importString
    , importList
    , importURI
    , (%=)
    , (%=?)
    , (%&)
    , AddURLEncoded(..)

    -- * Query
    , null
    , keys
    , lookup
    , lookupAll
    , lookup1
    , lookupDefault
    , pairs
    , (%!)

    -- * Export
    , addToURI
    , export
    )
where

import qualified Prelude
import Prelude hiding ( null, lookup, filter )
import Data.List.Split ( splitOn )
import Control.Monad ( liftM )
import Control.Arrow ( (>>>) )
import Network.URI ( unEscapeString, escapeURIString, isUnreserved, URI(uriQuery) )
import Data.Monoid ( Monoid, mappend )
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup ( Semigroup )
#endif
import Data.List ( intercalate )
import Data.Maybe ( fromMaybe )

-- | A container for URLEncoded data
newtype URLEncoded = URLEncoded { URLEncoded -> [(String, String)]
pairs :: [(String, String)] }
#if MIN_VERSION_base(4,9,0)
    deriving (b -> URLEncoded -> URLEncoded
NonEmpty URLEncoded -> URLEncoded
URLEncoded -> URLEncoded -> URLEncoded
(URLEncoded -> URLEncoded -> URLEncoded)
-> (NonEmpty URLEncoded -> URLEncoded)
-> (forall b. Integral b => b -> URLEncoded -> URLEncoded)
-> Semigroup URLEncoded
forall b. Integral b => b -> URLEncoded -> URLEncoded
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> URLEncoded -> URLEncoded
$cstimes :: forall b. Integral b => b -> URLEncoded -> URLEncoded
sconcat :: NonEmpty URLEncoded -> URLEncoded
$csconcat :: NonEmpty URLEncoded -> URLEncoded
<> :: URLEncoded -> URLEncoded -> URLEncoded
$c<> :: URLEncoded -> URLEncoded -> URLEncoded
Semigroup, Semigroup URLEncoded
URLEncoded
Semigroup URLEncoded
-> URLEncoded
-> (URLEncoded -> URLEncoded -> URLEncoded)
-> ([URLEncoded] -> URLEncoded)
-> Monoid URLEncoded
[URLEncoded] -> URLEncoded
URLEncoded -> URLEncoded -> URLEncoded
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [URLEncoded] -> URLEncoded
$cmconcat :: [URLEncoded] -> URLEncoded
mappend :: URLEncoded -> URLEncoded -> URLEncoded
$cmappend :: URLEncoded -> URLEncoded -> URLEncoded
mempty :: URLEncoded
$cmempty :: URLEncoded
$cp1Monoid :: Semigroup URLEncoded
Monoid, URLEncoded -> URLEncoded -> Bool
(URLEncoded -> URLEncoded -> Bool)
-> (URLEncoded -> URLEncoded -> Bool) -> Eq URLEncoded
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URLEncoded -> URLEncoded -> Bool
$c/= :: URLEncoded -> URLEncoded -> Bool
== :: URLEncoded -> URLEncoded -> Bool
$c== :: URLEncoded -> URLEncoded -> Bool
Eq)
#else
    deriving (Monoid, Eq)
#endif

class AddURLEncoded a where
    (%?) :: URLEncode args => a -> args -> a
infixr 6 %?

instance AddURLEncoded [Char] where
    String
str %? :: String -> args -> String
%? args
q = let (String
u, String
frag) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') String
str
                   joiner :: String
joiner = if String -> Char
forall a. [a] -> a
last String
u Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'
                            then String
""
                            else if Char
'?' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
u
                                 then String
"&"
                                 else String
"?"
               in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
u, String
joiner, URLEncoded -> String
export (URLEncoded -> String) -> URLEncoded -> String
forall a b. (a -> b) -> a -> b
$ args -> URLEncoded
forall a. URLEncode a => a -> URLEncoded
urlEncode args
q, String
frag]

instance AddURLEncoded URI where
    URI
u %? :: URI -> args -> URI
%? args
q = URLEncoded -> URI -> URI
addToURI (args -> URLEncoded
forall a. URLEncode a => a -> URLEncoded
urlEncode args
q) URI
u

instance AddURLEncoded URLEncoded where
    URLEncoded
q1 %? :: URLEncoded -> args -> URLEncoded
%? args
q2 = URLEncoded
q1 URLEncoded -> URLEncoded -> URLEncoded
forall a. Monoid a => a -> a -> a
`mappend` args -> URLEncoded
forall a. URLEncode a => a -> URLEncoded
urlEncode args
q2

(%&) :: (URLEncode q1, URLEncode q2) => q1 -> q2 -> URLEncoded
q1
q1 %& :: q1 -> q2 -> URLEncoded
%& q2
q2 = q1 -> URLEncoded
forall a. URLEncode a => a -> URLEncoded
urlEncode q1
q1 URLEncoded -> URLEncoded -> URLEncoded
forall a. Monoid a => a -> a -> a
`mappend` q2 -> URLEncoded
forall a. URLEncode a => a -> URLEncoded
urlEncode q2
q2
infixr 7 %&

-- | Is this URLEncoded data empty?
null :: URLEncoded -> Bool
null :: URLEncoded -> Bool
null = [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null ([(String, String)] -> Bool)
-> (URLEncoded -> [(String, String)]) -> URLEncoded -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URLEncoded -> [(String, String)]
pairs

-- | URLEncoded data with no pairs
empty :: URLEncoded
empty :: URLEncoded
empty = [(String, String)] -> URLEncoded
URLEncoded []

-- |Import this list of pairs as URLEncoded data
importList :: [(String, String)] -> URLEncoded
importList :: [(String, String)] -> URLEncoded
importList = [(String, String)] -> URLEncoded
URLEncoded

-- |All of the keys from the URLEncoded value, in order, preserving duplicates
keys :: URLEncoded -> [String]
keys :: URLEncoded -> [String]
keys = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst ([(String, String)] -> [String])
-> (URLEncoded -> [(String, String)]) -> URLEncoded -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URLEncoded -> [(String, String)]
pairs

-- |Create singleton URLEncoded data containing the supplied key and value
(%=) :: (URLShow a, URLShow b) => a -> b -> URLEncoded
a
k %= :: a -> b -> URLEncoded
%= b
v = [(String, String)] -> URLEncoded
URLEncoded [(a -> String
forall a. URLShow a => a -> String
urlShow a
k, b -> String
forall a. URLShow a => a -> String
urlShow b
v)]
infixl 8 %=

-- |Encode a value as x-www-urlencoded
class URLEncode a where
    urlEncode :: a -> URLEncoded

instance (URLShow a, URLShow b) => URLEncode (a, b) where
    urlEncode :: (a, b) -> URLEncoded
urlEncode (a
x, b
y) = [(String, String)] -> URLEncoded
importList [(a -> String
forall a. URLShow a => a -> String
urlShow a
x, b -> String
forall a. URLShow a => a -> String
urlShow b
y)]

instance URLEncode a => URLEncode (Maybe a) where
    urlEncode :: Maybe a -> URLEncoded
urlEncode = URLEncoded -> (a -> URLEncoded) -> Maybe a -> URLEncoded
forall b a. b -> (a -> b) -> Maybe a -> b
maybe URLEncoded
empty a -> URLEncoded
forall a. URLEncode a => a -> URLEncoded
urlEncode

instance URLEncode URLEncoded where
    urlEncode :: URLEncoded -> URLEncoded
urlEncode = URLEncoded -> URLEncoded
forall a. a -> a
id

-- |Serialize a value into a String for encoding as part of an
-- x-www-urlencoded value
class URLShow a where
    urlShow :: a -> String

instance URLShow Char where
    urlShow :: Char -> String
urlShow = Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return

instance URLShow URI where
    urlShow :: URI -> String
urlShow = URI -> String
forall a. Show a => a -> String
show

instance URLShow URLEncoded where
    urlShow :: URLEncoded -> String
urlShow = URLEncoded -> String
export

instance URLShow [Char] where
    urlShow :: String -> String
urlShow = String -> String
forall a. a -> a
id

instance URLShow Int where
    urlShow :: Int -> String
urlShow = Int -> String
forall a. Show a => a -> String
show

instance URLShow Integer where
    urlShow :: Integer -> String
urlShow = Integer -> String
forall a. Show a => a -> String
show

instance URLShow Bool where
    urlShow :: Bool -> String
urlShow Bool
True = String
"true"
    urlShow Bool
False = String
"false"

-- |If the second value is Nothing, return empty URLEncoded
-- data. Otherwise return singleton URLEncoded data that contains the
-- given key and value.
(%=?) :: (URLShow a, URLShow b) =>
         a {-^key-} -> Maybe b {-^value-} -> URLEncoded
a
k %=? :: a -> Maybe b -> URLEncoded
%=? Maybe b
v = URLEncoded -> (b -> URLEncoded) -> Maybe b -> URLEncoded
forall b a. b -> (a -> b) -> Maybe a -> b
maybe URLEncoded
empty (a
k a -> b -> URLEncoded
forall a b. (URLShow a, URLShow b) => a -> b -> URLEncoded
%=) Maybe b
v
infixl 8 %=?

-- |Add this URL-encoded data to the query part of a URI, after any
-- existing query arguments.
addToURI :: URLEncoded -> URI -> URI
addToURI :: URLEncoded -> URI -> URI
addToURI URLEncoded
q URI
u =
    let uq :: String
uq = URI -> String
uriQuery URI
u
        initial :: String
initial = if String
uq String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"?"
                  then String
""
                  else if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null (URI -> String
uriQuery URI
u) then String
"?" else String
"&"
    in URI
u { uriQuery :: String
uriQuery = URI -> String
uriQuery URI
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
initial String -> String -> String
forall a. [a] -> [a] -> [a]
++ URLEncoded -> String
export URLEncoded
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 :: URLEncoded -> String
export URLEncoded
q =
    let esc :: String -> String
esc = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnreserved
        encodePair :: (String, String) -> String
encodePair (String
k, String
v) = String -> String
esc String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
esc String
v
    in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"&" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
encodePair ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ URLEncoded -> [(String, String)]
pairs URLEncoded
q

instance Show URLEncoded where
    showsPrec :: Int -> URLEncoded -> String -> String
showsPrec Int
_ URLEncoded
q = (URLEncoded -> String
export URLEncoded
q String -> String -> String
forall a. [a] -> [a] -> [a]
++)

-- |Parse this string as x-www-urlencoded
-- @since 0.5.0.0
importString :: MonadFail m => String -> m URLEncoded
importString :: String -> m URLEncoded
importString String
"" = URLEncoded -> m URLEncoded
forall (m :: * -> *) a. Monad m => a -> m a
return URLEncoded
empty
importString String
s = ([(String, String)] -> URLEncoded)
-> m [(String, String)] -> m URLEncoded
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(String, String)] -> URLEncoded
importList (m [(String, String)] -> m URLEncoded)
-> m [(String, String)] -> m URLEncoded
forall a b. (a -> b) -> a -> b
$ (String -> m (String, String)) -> [String] -> m [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m (String, String)
forall (m :: * -> *). MonadFail m => String -> m (String, String)
parsePair ([String] -> m [(String, String)])
-> [String] -> m [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"&" String
s
    where parsePair :: String -> m (String, String)
parsePair String
p =
              case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') String
p of
                (String
_, []) -> String -> m (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (String, String)) -> String -> m (String, String)
forall a b. (a -> b) -> a -> b
$ String
"Missing value in query string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p
                (String
k, Char
'=':String
v) -> (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ( String -> String
unesc String
k
                                     , String -> String
unesc String
v
                                     )
                (String, String)
unknown -> String -> m (String, String)
forall a. HasCallStack => String -> a
error (String -> m (String, String)) -> String -> m (String, String)
forall a b. (a -> b) -> a -> b
$ String
"impossible: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (String, String)
unknown
          unesc :: String -> String
unesc = String -> String
unEscapeString (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"%20" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"+"

-- | @since 0.5.0.0
importURI :: MonadFail m => URI -> m URLEncoded
importURI :: URI -> m URLEncoded
importURI URI
u = case URI -> String
uriQuery URI
u of
                (Char
'?':String
s) -> String -> m URLEncoded
forall (m :: * -> *). MonadFail m => String -> m URLEncoded
importString String
s
                [] -> URLEncoded -> m URLEncoded
forall (m :: * -> *) a. Monad m => a -> m a
return URLEncoded
empty
                String
q -> String -> m URLEncoded
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m URLEncoded) -> String -> m URLEncoded
forall a b. (a -> b) -> a -> b
$ String
"Unexpected query for URI: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
q

-- |Return the /first/ value for the given key, or throw an error if the
-- key is not present in the URLEncoded data.
-- @since 0.5.0.0
lookup1 :: (URLShow a, MonadFail m) => a -> URLEncoded -> m String
lookup1 :: a -> URLEncoded -> m String
lookup1 a
k = a -> URLEncoded -> Maybe String
forall a. URLShow a => a -> URLEncoded -> Maybe String
lookup a
k (URLEncoded -> Maybe String)
-> (Maybe String -> m String) -> URLEncoded -> m String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m String -> (String -> m String) -> Maybe String -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m String
forall a. m a
missing String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return
    where missing :: m a
missing = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Key not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. URLShow a => a -> String
urlShow a
k

lookup :: URLShow a => a -> URLEncoded -> Maybe String
lookup :: a -> URLEncoded -> Maybe String
lookup a
k = URLEncoded -> [(String, String)]
pairs (URLEncoded -> [(String, String)])
-> ([(String, String)] -> Maybe String)
-> URLEncoded
-> Maybe String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup (a -> String
forall a. URLShow a => a -> String
urlShow a
k)

lookupDefault :: URLShow a => String -> a -> URLEncoded -> String
lookupDefault :: String -> a -> URLEncoded -> String
lookupDefault String
dflt a
k URLEncoded
q = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
dflt (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ URLEncoded
q URLEncoded -> a -> Maybe String
forall a. URLShow a => URLEncoded -> a -> Maybe String
%! a
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.
lookupAll :: URLShow a => a -> URLEncoded -> [String]
lookupAll :: a -> URLEncoded -> [String]
lookupAll a
k URLEncoded
urlenc = [ String
v | (String
k', String
v) <- URLEncoded -> [(String, String)]
pairs URLEncoded
urlenc, String
k' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== a -> String
forall a. URLShow a => a -> String
urlShow a
k ]

-- |Create a URLEncoded object that represents all pairs from the
-- input that match the supplied predicate
filter :: ((String, String) -> Bool) -> URLEncoded -> URLEncoded
filter :: ((String, String) -> Bool) -> URLEncoded -> URLEncoded
filter (String, String) -> Bool
p = URLEncoded -> [(String, String)]
pairs (URLEncoded -> [(String, String)])
-> ([(String, String)] -> URLEncoded) -> URLEncoded -> URLEncoded
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (String, String) -> Bool
p ([(String, String)] -> [(String, String)])
-> ([(String, String)] -> URLEncoded)
-> [(String, String)]
-> URLEncoded
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [(String, String)] -> URLEncoded
URLEncoded

-- |Look up a key in a URLEncoded value and return the first matching
-- value, or Nothing if there is no value that matches
(%!) :: URLShow a => URLEncoded -> a -> Maybe String
%! :: URLEncoded -> a -> Maybe String
(%!) = (a -> URLEncoded -> Maybe String)
-> URLEncoded -> a -> Maybe String
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> URLEncoded -> Maybe String
forall a. URLShow a => a -> URLEncoded -> Maybe String
lookup
infixr 1 %!