codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
{-# LANGUAGE OverloadedStrings #-} module Url ( Login , Url(..) , UrlScheme , http , https , ftp , makeUrl , defaultUrl , username , password , userOnly , userPass ) where import Control.Monad ( join, mzero ) import Control.Monad.Instances import Data.List ( foldl' ) import Data.Monoid ( mempty ) import Text.Regex.PCRE import qualified Data.Text as T data UrlScheme = Http | Https | Ftp newtype Login = Login (T.Text, Maybe T.Text) deriving (Show) instance Show UrlScheme where show Http = "http" show Https = "https" show Ftp = "ftp" data Url = Url { scheme :: !(Maybe UrlScheme) , host :: !T.Text , port :: !(Maybe Int) , login :: !(Maybe Login) , path :: !(Maybe T.Text) , query :: ![(T.Text, T.Text)] , fragment :: !(Maybe T.Text) } instance Show Url where show (Url scheme host port login path query fragment) = concat $ [ mon (flip (++) "://" . show) scheme , mon userPw login , T.unpack host , mon ((++) ":" . show) port , T.unpack $ (maybe "") id path , T.unpack $ foldl' queryStr "" query , T.unpack $ (maybe "") (T.append "#") fragment ] where mon = maybe mempty -- | A default url value defaultUrl :: Url defaultUrl = Url { scheme = Nothing , host = T.pack "0.0.0.0" , port = Nothing , login = Nothing , path = Nothing , query = [] , fragment = Nothing } http, https, ftp :: Maybe UrlScheme http = Just Http https = Just Https ftp = Just Ftp userOnly :: T.Text -> Login userOnly uname = Login (uname, Nothing) userPass :: T.Text -> T.Text -> Login userPass uname pass = Login (uname, Just pass) username :: Url -> Maybe T.Text username url = login url >>= \(Login (user, _)) -> Just user password :: Url -> Maybe T.Text password url = login url >>= \(Login (_, pass)) -> pass queryStr :: T.Text -> (T.Text, T.Text) -> T.Text queryStr z (x, y) = T.concat [z, delim z, x, "=", y] where delim z | T.null z = "?" | otherwise = "&" userPw (Login (u, p)) = T.unpack $ T.concat $ case p of Nothing -> [u] Just pw -> [u, ":", pw] ++ ["@"] -- | Split an url into a list of tokens tokenize :: String -> [String] tokenize str = let (_, _, _, x) = str =~ regex :: (String, String, String, [String]) in x where regex = ("((https?|ftp)://)?(([^:]*):?" ++ "([^@]*)@)?([^:^/^\\?]*)?(:\\d*)?" ++ "(/[^#^\\?]*)?(\\?[^#]*)?(#.*)?") :: String stripChars :: String -> T.Text -> T.Text stripChars cs = T.filter (not . flip elem cs) -- | Translate url string parameters to key-value pair list segments :: T.Text -> [(T.Text, T.Text)] segments str = f (stripChars "?" str) [] where f str xs = let (a, b) = T.break (=='&') str in case T.null b of False -> let (k, v) = T.break (=='=') a in f (T.tail b) $ (k, stripChars "=" v):xs _ -> xs (!!!) xs = T.pack . (xs !!) -- | Translate string to Url type makeUrl :: String -> Url makeUrl str = let xs = tokenize str in Url { scheme = case xs !! 1 of "http" -> http "https" -> https "ftp" -> ftp _ -> Nothing , host = xs !!! 5 , port = f (stripChars ":@" $ xs !!! 6) $ read . T.unpack , login = setPass (f (xs !!! 3) userOnly) $ xs !!! 4 , path = flip f id $ xs !!! 7 , query = segments $ xs !!! 8 , fragment = flip f id $ stripChars "#" $ xs !!! 9 } where f x fn = case T.null x of False -> Just $ fn x _ -> Nothing setPass m pass = do Login login <- m let p = if T.null pass then Nothing else Just pass return $ Login (fst login, p)
Private
[
?
]
Run code
Submit