0 | module Network.URL.Internal.PercentEncoding
 1 |
 2 | import Data.String
 3 | import Prelude
 4 | import Data.List
 5 |
 6 | ||| 判断字符是否为URL中无需编码的unreserved字符
 7 | ||| 参考RFC 3986: ALPHA / DIGIT / "-" / "." / "_" / "~"
 8 | public export
 9 | isUnreserved : Char -> Bool
10 | isUnreserved c = isAlphaNum c || c == '-' || c == '_' || c == '.' || c == '~'
11 |
12 | -- 将整数转为两位十六进制字符串（大写）
13 | private
14 | toHex : Int -> String
15 | toHex n = let hex = unpack "0123456789ABCDEF"
16 |               hi  = n `div` 16
17 |               lo  = n `mod` 16
18 |           in  singleton (index hex (cast hi)) ++ singleton (index hex (cast lo))
19 |   where
20 |     index : List Char -> Nat -> Char
21 |     index xs i = case drop i xs of
22 |       (x :: _) => x
23 |       _ => '0'
24 |
25 | -- 将两个十六进制字符转为整数
26 | private
27 | fromHex : Char -> Char -> Int
28 | fromHex a b = hexVal a * 16 + hexVal b
29 |   where
30 |     hexVal : Char -> Int
31 |     hexVal c = case c of
32 |       '0' => 0
33 |       '1' => 1
34 |       '2' => 2
35 |       '3' => 3
36 |       '4' => 4
37 |       '5' => 5
38 |       '6' => 6
39 |       '7' => 7
40 |       '8' => 8
41 |       '9' => 9
42 |       'A' => 10
43 |       'B' => 11
44 |       'C' => 12
45 |       'D' => 13
46 |       'E' => 14
47 |       'F' => 15
48 |       'a' => 10
49 |       'b' => 11
50 |       'c' => 12
51 |       'd' => 13
52 |       'e' => 14
53 |       'f' => 15
54 |       _   => 0 -- 非法字符按0处理
55 |
56 | ||| URL编码（百分号编码）实现
57 | ||| 将非unreserved字符转为%XX格式
58 | public export
59 | percentEncode : String -> String
60 | percentEncode s = concatMap encodeChar (unpack s)
61 |   where
62 |     encodeChar : Char -> String
63 |     encodeChar c = if isUnreserved c then singleton c else "%" ++ toHex (ord c)
64 |
65 | ||| URL解码（百分号解码）实现
66 | ||| 将%XX格式还原为原字符
67 | public export
68 | percentDecode : String -> String
69 | percentDecode s = decode (unpack s)
70 |   where
71 |     decode : List Char -> String
72 |     decode [] = ""
73 |     decode ('%' :: a :: b :: xs) =
74 |       let n = fromHex a b in singleton (chr n) ++ decode xs
75 |     decode (x :: xs) = singleton x ++ decode xs