module Extra.URI
( module Network.URI
, relURI
, setURIPort
, parseURIQuery
, modifyURIQuery
, setURIQuery
, setURIQueryAttr
, deleteURIQueryAttr
) where
import Network.URI
import Data.List(intersperse, groupBy, inits)
import Data.Maybe(isJust, isNothing, catMaybes)
import Control.Arrow(second)
relURI :: FilePath -> [(String, String)] -> URI
relURI path pairs = URI {uriScheme = "",
uriAuthority = Nothing,
uriPath = path,
uriQuery = formatURIQuery pairs,
uriFragment = ""}
setURIPort port uri =
uri {uriAuthority = Just auth'}
where
auth' = auth {uriPort = port}
auth = maybe nullAuth id (uriAuthority uri)
nullAuth = URIAuth {uriUserInfo = "", uriRegName = "", uriPort = ""}
parseURIQuery :: URI -> [(String, String)]
parseURIQuery uri =
case uriQuery uri of
"" -> []
'?' : attrs ->
map (second (unEscapeString . tail) . break (== '='))
(filter (/= "&") (groupBy (\ a b -> a /= '&' && b /= '&') attrs))
x -> error $ "Invalid URI query: " ++ x
modifyURIQuery :: ([(String, String)] -> [(String, String)]) -> URI -> URI
modifyURIQuery f uri = uri {uriQuery = formatURIQuery (f (parseURIQuery uri))}
setURIQuery :: [(String, String)] -> URI -> URI
setURIQuery pairs = modifyURIQuery (const pairs)
setURIQueryAttr :: String -> String -> URI -> URI
setURIQueryAttr name value uri =
modifyURIQuery f uri
where f pairs = (name, value) : filter ((/= name) . fst) pairs
deleteURIQueryAttr :: String -> URI -> URI
deleteURIQueryAttr name uri =
modifyURIQuery f uri
where f pairs = filter ((/= name) . fst) pairs
formatURIQuery :: [(String, String)] -> String
formatURIQuery [] = ""
formatURIQuery attrs = '?' : concat (intersperse "&" (map (\ (a, b) -> a ++ "=" ++ escapeURIForQueryValue b) attrs))
escapeURIForQueryValue = escapeURIString isUnreserved
instance Read URI where
readsPrec _ s =
let allURIs = map parseURI (inits s) in
case catMaybes (take 10 allURIs) of
[] -> fail "read URI: no parse"
_ ->
[(longestURI, drop (length badURIs + length goodURIs 1) s)]
where
longestURI = case reverse (catMaybes goodURIs) of
[] -> error $ "Invalid URI: " ++ s
(a : _) -> a
goodURIs = takeWhile isJust moreURIs
(badURIs, moreURIs) = span isNothing allURIs