module Yesod.WebRoutes
( encodePathInfo
, Site (..)
) where
import Codec.Binary.UTF8.String (encodeString)
import Data.List (intercalate)
import Network.URI
encodePathInfo :: [String] -> [(String, String)] -> String
encodePathInfo pieces qs =
let x = map encodeString `o`
map (escapeURIString (\c -> isUnreserved c || c `elem` ":@&=+$,")) `o`
map (\str -> case str of "." -> "%2E" ; ".." -> "%2E%2E" ; _ -> str) `o`
intercalate "/"
y = showParams qs
in x pieces ++ y
where
o :: (a -> b) -> (b -> c) -> a -> c
o = flip (.)
data Site url a
= Site {
handleSite :: (url -> [(String, String)] -> String) -> url -> a
, formatPathSegments :: url -> ([String], [(String, String)])
, parsePathSegments :: [String] -> Either String url
}
showParams :: [(String, String)] -> String
showParams [] = ""
showParams z =
'?' : intercalate "&" (map go z)
where
go (x, "") = go' x
go (x, y) = go' x ++ '=' : go' y
go' = concatMap encodeUrlChar
encodeUrlChar :: Char -> String
encodeUrlChar c
| 'A' <= c && c <= 'Z' = [c]
| 'a' <= c && c <= 'z' = [c]
| '0' <= c && c <= '9' = [c]
encodeUrlChar c@'-' = [c]
encodeUrlChar c@'_' = [c]
encodeUrlChar c@'.' = [c]
encodeUrlChar c@'~' = [c]
encodeUrlChar ' ' = "+"
encodeUrlChar y =
let (a, c) = fromEnum y `divMod` 16
b = a `mod` 16
showHex' x
| x < 10 = toEnum $ x + (fromEnum '0')
| x < 16 = toEnum $ x 10 + (fromEnum 'A')
| otherwise = error $ "Invalid argument to showHex: " ++ show x
in ['%', showHex' b, showHex' c]