mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
550db69caa
The package network-2.4.1.1 thoughlessly introduced a backward incompatible
change to the function Network.URI.unEscapeString, see
f2168b1f89
This also affects the function Network.Shed.Httpd.queryToArguments, which is
used in GFServer.hs.
To remain compatible with older and newer versions of the network package,
we need to stay clear of queryToArguments and unEscapeString. A replacement
function has been added to server/URLEncoding.hs.
62 lines
1.9 KiB
Haskell
62 lines
1.9 KiB
Haskell
module URLEncoding(urlDecodeUnicode,decodeQuery) where
|
|
|
|
import Data.Bits (shiftL, (.|.))
|
|
import Data.Char (chr,digitToInt,isHexDigit)
|
|
|
|
-- | Decode hexadecimal escapes
|
|
urlDecodeUnicode :: String -> String
|
|
urlDecodeUnicode [] = ""
|
|
urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s)
|
|
| all isHexDigit [x1,x2,x3,x4] =
|
|
chr ( digitToInt x1 `shiftL` 12
|
|
.|. digitToInt x2 `shiftL` 8
|
|
.|. digitToInt x3 `shiftL` 4
|
|
.|. digitToInt x4) : urlDecodeUnicode s
|
|
urlDecodeUnicode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 =
|
|
chr ( digitToInt x1 `shiftL` 4
|
|
.|. digitToInt x2) : urlDecodeUnicode s
|
|
urlDecodeUnicode (c:s) = c : urlDecodeUnicode s
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
type Query = [(String,String)]
|
|
|
|
-- | Decode application/x-www-form-urlencoded
|
|
decodeQuery :: String -> Query
|
|
decodeQuery = map (aboth decode . breakAt '=') . chopList (breakAt '&')
|
|
|
|
aboth f (x,y) = (f x,f y)
|
|
|
|
-- | Decode "+" and hexadecimal escapes
|
|
decode [] = []
|
|
decode ('%':'u':d1:d2:d3:d4:cs)
|
|
| all isHexDigit [d1,d2,d3,d4] = chr(fromhex4 d1 d2 d3 d4):decode cs
|
|
decode ('%':d1:d2:cs)
|
|
| all isHexDigit [d1,d2] = chr(fromhex2 d1 d2):decode cs
|
|
decode ('+':cs) = ' ':decode cs
|
|
decode (c:cs) = c:decode cs
|
|
|
|
fromhex4 d1 d2 d3 d4 = 256*fromhex2 d1 d2+fromhex2 d3 d4
|
|
fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2
|
|
|
|
|
|
-- From hbc-library ListUtil ---------------------------------------------------
|
|
|
|
-- Repeatedly extract (and transform) values until a predicate hold. Return the list of values.
|
|
unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
|
|
unfoldr f p x | p x = []
|
|
| otherwise = y:unfoldr f p x'
|
|
where (y, x') = f x
|
|
|
|
chopList :: ([a] -> (b, [a])) -> [a] -> [b]
|
|
chopList f l = unfoldr f null l
|
|
|
|
breakAt :: (Eq a) => a -> [a] -> ([a], [a])
|
|
breakAt _ [] = ([], [])
|
|
breakAt x (x':xs) =
|
|
if x == x' then
|
|
([], xs)
|
|
else
|
|
let (ys, zs) = breakAt x xs
|
|
in (x':ys, zs)
|