[ create a new paste ] login | about

Link: http://codepad.org/JG4igvh7    [ raw code | fork ]

johannes - Haskell, pasted on Oct 9:
{-# 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)


Create a new paste based on this one


Comments: