url-2.1.3: Network/URL.hs
--------------------------------------------------------------------------------
-- |
-- Module : Network.URL
-- Copyright : (c) Galois, Inc. 2007, 2008
-- License : BSD3
--
-- Maintainer : Iavor S. Diatchki
-- Stability : Provisional
-- Portability : Portable
--
-- Provides a convenient way for working with HTTP URLs.
-- Based on RFC 1738.
-- See also: RFC 3986
module Network.URL
( URL(..), URLType(..), Host(..), Protocol(..)
, secure, secure_prot
, exportURL, importURL, exportHost
, add_param
, decString, encString
, ok_host, ok_url, ok_param, ok_path
, exportParams, importParams
) where
import Data.Char (isAlpha, isAscii, isDigit)
import Data.List (intersperse)
import Data.Word (Word8)
import Numeric (readHex, showHex)
import qualified Codec.Binary.UTF8.String as UTF8
-- | Contains information about the connection to the host.
data Host = Host { protocol :: Protocol
, host :: String
, port :: Maybe Integer
} deriving (Eq,Ord,Show)
-- | The type of known protocols.
data Protocol = HTTP Bool | FTP Bool | RawProt String deriving (Eq,Ord,Show)
-- | Is this a \"secure\" protocol. This works only for known protocols,
-- for 'RawProt' values we return 'False'.
secure_prot :: Protocol -> Bool
secure_prot (HTTP s) = s
secure_prot (FTP s) = s
secure_prot (RawProt _) = False
-- | Does this host use a \"secure\" protocol (e.g., https).
secure :: Host -> Bool
secure = secure_prot . protocol
-- | Different types of URL.
data URLType = Absolute Host -- ^ Has a host
| HostRelative -- ^ Does not have a host
| PathRelative -- ^ Relative to another URL
deriving (Eq, Ord, Show)
-- | A type for working with URL.
-- The parameters are in @application\/x-www-form-urlencoded@ format:
-- <http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1>
data URL = URL
{ url_type :: URLType
, url_path :: String
, url_params :: [(String,String)]
} deriving (Eq,Ord,Show)
-- | Add a (key,value) parameter to a URL.
add_param :: URL -> (String,String) -> URL
add_param url x = url { url_params = x : url_params url }
-- | Convert a list of \"bytes\" to a URL.
importURL :: String -> Maybe URL
importURL cs0 =
do (ho,cs5) <- front cs0
(pa,cs6) <- the_path cs5
as <- the_args cs6
return URL { url_type = ho, url_path = pa, url_params = as }
where
front ('/':cs) = return (HostRelative,cs)
front cs =
case the_prot cs of
Just (pr,cs1) ->
do let (ho,cs2) = the_host cs1
(po,cs3) <- the_port cs2
cs4 <- case cs3 of
[] -> return []
'/':cs5 -> return cs5
_ -> Nothing
return (Absolute Host { protocol = pr
, host = ho
, port = po
}, cs4)
_ -> return (PathRelative,cs)
the_prot :: String -> Maybe (Protocol, String)
the_prot urlStr = case break (':' ==) urlStr of
(as@(_:_), ':' : '/' : '/' : bs) -> Just (prot, bs)
where prot = case as of
"https" -> HTTP True
"http" -> HTTP False
"ftps" -> FTP True
"ftp" -> FTP False
_ -> RawProt as
_ -> Nothing
the_host = span ok_host
the_port (':':cs) = case span isDigit cs of
([],_) -> Nothing
(xs,ds) -> Just (Just (read xs),ds)
the_port cs5 = return (Nothing, cs5)
the_path cs = do let (as,bs) = break end_path cs
s <- decString False as
return (s,bs)
where end_path c = c == '#' || c == '?'
the_args ('?' : cs) = importParams cs
the_args _ = return []
importParams :: String -> Maybe [(String,String)]
importParams [] = return []
importParams ds = mapM a_param (breaks ('&'==) ds)
where
a_param cs = do let (as,bs) = break ('=' ==) cs
k <- decString True as
v <- case bs of
"" -> return ""
_:xs -> decString True xs
return (k,v)
-- | Convert the host part of a URL to a list of \"bytes\".
exportHost :: Host -> String
exportHost absol = the_prot ++ "://" ++ host absol ++ the_port
where the_prot = exportProt (protocol absol)
the_port = maybe "" (\x -> ':' : show x) (port absol)
-- | Convert the host part of a URL to a list of \"bytes\".
-- WARNING: We output \"raw\" protocols as they are.
exportProt :: Protocol -> String
exportProt prot = case prot of
HTTP True -> "https"
HTTP False -> "http"
FTP True -> "ftps"
FTP False -> "ftp"
RawProt s -> s
-- | Convert a URL to a list of \"bytes\".
-- We represent non-ASCII characters using UTF8.
exportURL :: URL -> String
exportURL url = absol ++ the_path ++ the_params
where
absol = case url_type url of
Absolute hst -> exportHost hst ++ "/"
HostRelative -> "/"
PathRelative -> ""
the_path = encString False ok_path (url_path url)
the_params = case url_params url of
[] -> ""
xs -> '?' : exportParams xs
exportParams :: [(String,String)] -> String
exportParams ps = concat (intersperse "&" $ map a_param ps)
where
a_param (k,mv) = encString True ok_param k ++
case mv of
"" -> ""
v -> '=' : encString True ok_param v
-- | Convert a string to bytes by escaping the characters that
-- do not satisfy the input predicate. The first argument specifies
-- if we should replace spaces with +.
encString :: Bool -> (Char -> Bool) -> String -> String
encString pl p ys = foldr enc1 [] ys
where enc1 ' ' xs | pl = '+' : xs
enc1 x xs = if p x then x : xs else encChar x ++ xs
-- | %-encode a character. Uses UTF8 to represent characters as bytes.
encChar :: Char -> String
encChar c = concatMap encByte (UTF8.encode [c])
-- | %-encode a byte.
encByte :: Word8 -> String
encByte b = '%' : case showHex b "" of
d@[_] -> '0' : d
d -> d
-- | Decode a list of \"bytes\" to a string.
-- Performs % and UTF8 decoding.
decString :: Bool -> String -> Maybe String
decString b = fmap UTF8.decode . decStrBytes b
-- Convert a list of \"bytes\" to actual bytes.
-- Performs %-decoding. The boolean specifies if we should turn pluses into
-- spaces.
decStrBytes :: Bool -> String -> Maybe [Word8]
decStrBytes _ [] = Just []
decStrBytes p ('%' : cs) = do (n,cs1) <- decByte cs
fmap (n:) (decStrBytes p cs1)
decStrBytes p (c : cs) = let b = if p && c == '+'
then 32 -- space
else fromIntegral (fromEnum c)
in (b :) `fmap` decStrBytes p cs
-- truncates "large bytes".
-- | Parse a percent-encoded byte.
decByte :: String -> Maybe (Word8,String)
decByte (x : y : cs) = case readHex [x,y] of
[(n,"")] -> Just (n,cs)
_ -> Nothing
decByte _ = Nothing
-- Classification of characters.
-- Note that these only return True for ASCII characters; this is important.
--------------------------------------------------------------------------------
ok_host :: Char -> Bool
ok_host c = isDigit c || isAlphaASCII c || c == '.' || c == '-'
ok_param :: Char -> Bool
ok_param c = ok_host c || c `elem` "~;:@$_!*'(),"
-- | Characters that can appear non % encoded in the path part of the URL
ok_path :: Char -> Bool
ok_path c = ok_param c || c `elem` "/=&"
-- XXX: others? check RFC
-- | Characters that do not need to be encoded in URL
ok_url :: Char -> Bool
ok_url c = isDigit c || isAlphaASCII c || c `elem` ".-;:@$_!*'(),/=&?~+"
-- Misc
--------------------------------------------------------------------------------
isAlphaASCII :: Char -> Bool
isAlphaASCII x = isAscii x && isAlpha x
breaks :: (a -> Bool) -> [a] -> [[a]]
breaks p xs = case break p xs of
(as,[]) -> [as]
(as,_:bs) -> as : breaks p bs