salvia-protocol (empty) → 1.0.0

raw patch · 20 files changed

+2548/−0 lines, 20 filesdep +basedep +bimapdep +bytestringsetup-changed

Dependencies added: base, bimap, bytestring, containers, fclabels, parsec, safe, split, utf8-string

Files

LICENSE +28/−0
Setup.lhs +6/−0
salvia-protocol.cabal +44/−0
src/Network/Protocol/Cookie.hs +249/−0
src/Network/Protocol/Http.hs +98/−0
src/Network/Protocol/Http/Data.hs +156/−0
src/Network/Protocol/Http/Headers.hs +114/−0
src/Network/Protocol/Http/Parser.hs +137/−0
src/Network/Protocol/Http/Printer.hs +48/−0
src/Network/Protocol/Http/Status.hs +164/−0
src/Network/Protocol/Mime.hs +664/−0
src/Network/Protocol/Uri.hs +93/−0
src/Network/Protocol/Uri/Chars.hs +19/−0
src/Network/Protocol/Uri/Data.hs +185/−0
src/Network/Protocol/Uri/Encode.hs +37/−0
src/Network/Protocol/Uri/Parser.hs +288/−0
src/Network/Protocol/Uri/Path.hs +73/−0
src/Network/Protocol/Uri/Printer.hs +47/−0
src/Network/Protocol/Uri/Query.hs +53/−0
src/Network/Protocol/Uri/Remap.hs +45/−0

+ LICENSE view

@@ -0,0 +1,28 @@+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.+

+ Setup.lhs view

@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+

+ salvia-protocol.cabal view

@@ -0,0 +1,44 @@+Name:               salvia-protocol+Version:            1.0.0+Description:        Protocol suite for the Salvia webserver, including functionality for URI, HTTP, Cookie and MIME.+Synopsis:           Protocol suite for the Salvia webserver, including functionality for URI, HTTP, Cookie and MIME.+Cabal-version:      >= 1.6+Category:           Network, Web, Protocol+License:            BSD3+License-file:       LICENSE+Author:             Sebastiaan Visser+Maintainer:         sfvisser@cs.uu.nl+Build-Type:         Simple++Library+  GHC-Options:      -Wall -fno-warn-orphans+  HS-Source-Dirs:   src++  Build-Depends:    base ==4.*,+                    containers >= 0.2 && < 0.4,+                    safe ==0.2.*,+                    fclabels >=0.4.2 && < 0.5,+                    split ==0.1.*,+                    bimap ==0.2.*,+                    bytestring ==0.9.*,+                    parsec ==2.1.*,+                    utf8-string ==0.3.*++  Exposed-modules:  Network.Protocol.Cookie+                    Network.Protocol.Http+                    Network.Protocol.Http.Data+                    Network.Protocol.Http.Headers+                    Network.Protocol.Http.Parser+                    Network.Protocol.Http.Printer+                    Network.Protocol.Http.Status+                    Network.Protocol.Mime+                    Network.Protocol.Uri+                    Network.Protocol.Uri.Chars+                    Network.Protocol.Uri.Data+                    Network.Protocol.Uri.Encode+                    Network.Protocol.Uri.Parser+                    Network.Protocol.Uri.Path+                    Network.Protocol.Uri.Printer+                    Network.Protocol.Uri.Remap+                    Network.Protocol.Uri.Query+

@@ -0,0 +1,249 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+-- | For more information: http://www.ietf.org/rfc/rfc2109.txt+module Network.Protocol.Cookie {- todo: test please -}+(++-- * Cookie datatype.+  Cookie (Cookie)+, empty+, cookie+, setCookie++-- * Accessing cookies.+, name+, value+, comment+, commentURL+, discard+, domain+, maxAge+, expires+, path+, port+, secure+, version++-- * Collection of cookies.+, Cookies+, unCookies+, cookies+, setCookies++, pickCookie+, fromList+, toList+)+where++import Prelude hiding ((.), id)+import Control.Category+import Control.Monad (join)+import Data.Record.Label+import Data.Maybe+import Data.Char+import Safe+import Data.List+import Network.Protocol.Uri.Query+import qualified Data.Map as M++-- | The `Cookie` data type containg one key/value pair with all the+-- (potentially optional) meta-data.++data Cookie =+  Cookie+    { _name       :: String+    , _value      :: String+    , _comment    :: Maybe String+    , _commentURL :: Maybe String+    , _discard    :: Bool+    , _domain     :: Maybe String+    , _maxAge     :: Maybe Int+    , _expires    :: Maybe String+    , _path       :: Maybe String+    , _port       :: [Int]+    , _secure     :: Bool+    , _version    :: Int+    } deriving Eq++$(mkLabels [''Cookie])++-- | Access name/key of a cookie.++name :: Cookie :-> String++-- | Access value of a cookie.++value :: Cookie :-> String++-- | Access comment of a cookie.++comment :: Cookie :-> Maybe String++-- | Access comment-URL of a cookie.++commentURL :: Cookie :-> Maybe String++-- | Access discard flag of a cookie.++discard :: Cookie :-> Bool++-- | Access domain of a cookie.++domain :: Cookie :-> Maybe String++-- | Access max-age of a cookie.++maxAge :: Cookie :-> Maybe Int++-- | Access expiration of a cookie.++expires :: Cookie :-> Maybe String++-- | Access path of a cookie.++path :: Cookie :-> Maybe String++-- | Access port of a cookie.++port :: Cookie :-> [Int]++-- | Access secure flag of a cookie.++secure :: Cookie :-> Bool++-- | Access version of a cookie.++version :: Cookie :-> Int++-- | Create an empty cookie.++empty :: Cookie+empty = Cookie "" "" Nothing Nothing False Nothing Nothing Nothing Nothing [] False 0++-- Cookie show instance.++instance Show Cookie where+  showsPrec _ = showsSetCookie++-- Show a semicolon separated list of attribute/value pairs. Only meta pairs+-- with significant values will be pretty printed.++showsSetCookie :: Cookie -> ShowS+showsSetCookie c =+    pair (get name c) (get value c)+  . opt  "comment"    (get comment c)+  . opt  "commentURL" (get commentURL c)+  . bool "discard"    (get discard c)+  . opt  "domain"     (get domain c)+  . opt  "maxAge"     (fmap show $ get maxAge c)+  . opt  "expires"    (get expires c)+  . opt  "path"       (get path c)+  . lst  "port"       (map show $ get port c)+  . bool "secure"     (get secure c)+  . opt  "version"    (optval $ get version c)+  where+    attr a       = showString a+    val v        = showString ("=" ++ v)+    end          = showString "; "+    single a     = attr a . end+    pair a v     = attr a . val v . end+    opt a        = maybe id (pair a)+    lst _ []     = id+    lst a xs     = pair a $ intercalate "," xs+    bool _ False = id+    bool a True  = single a+    optval 0     = Nothing+    optval i     = Just (show i)++showCookie :: Cookie -> String+showCookie c = _name c ++ "=" ++ _value c++parseSetCookie :: String -> Cookie+parseSetCookie s = +  let p = fw (keyValues ";" "=") s+  in Cookie+    { _name       = (fromMaybe "" .        fmap fst . headMay)              p+    , _value      = (fromMaybe "" . join . fmap snd . headMay)              p+    , _comment    = (                           join . lookup "comment")    p+    , _commentURL = (                           join . lookup "commentURL") p+    , _discard    = (maybe False (const True) . join . lookup "discard")    p+    , _domain     = (                           join . lookup "commentURL") p+    , _maxAge     = (join . fmap readMay .      join . lookup "commentURL") p+    , _expires    = (                           join . lookup "expires")    p+    , _path       = (                           join . lookup "path")       p+    , _port       = (maybe [] (readDef [-1]) .  join . lookup "port")       p+    , _secure     = (maybe False (const True) . join . lookup "secure")     p+    , _version    = (maybe 1 (readDef 1) .      join . lookup "version")    p+    }++parseCookie :: String -> Cookie+parseCookie s =+  let p = fw (values "=") s+  in empty+       { _name  = atDef "" p 0+       , _value = atDef "" p 1+       }++-- | Cookie parser and pretty printer as a lens. To be used in combination with+-- the /Set-Cookie/ header field.++setCookie :: String :<->: Cookie+setCookie = parseSetCookie <-> show++-- | Cookie parser and pretty printer as a lens. To be used in combination with+-- the /Cookie/ header field.++cookie :: String :<->: Cookie+cookie = parseCookie <-> showCookie++-- | A collection of multiple cookies. These can all be set in one single HTTP+-- /Set-Cookie/ header field.++data Cookies = Cookies { _unCookies :: M.Map String Cookie }+  deriving Eq++$(mkLabels [''Cookies])++-- | Access raw cookie mapping from collection.++unCookies :: Cookies :-> M.Map String Cookie++instance Show Cookies where+  showsPrec _ = showsSetCookies++showsSetCookies :: Cookies -> ShowS+showsSetCookies =+      is (showString ", ")+    . map (shows . snd)+    . M.toList+    . get unCookies+  where+  is _ []     = id+  is s (x:xs) = foldl (\a b -> a.s.b) x xs++-- | Cookies parser and pretty printer as a lens.++setCookies :: String :<->: Cookies+setCookies = (fromList <-> toList) . (map parseSetCookie <-> map show) . values ","++-- | Label for printing and parsing collections of cookies.++cookies :: String :<->: Cookies+cookies = (fromList <-> toList) . (map parseCookie <-> map showCookie) . values ";"++-- | Case-insensitive way of getting a cookie out of a collection by name.++pickCookie :: String -> Cookies :-> Maybe Cookie+pickCookie n = lookupL (map toLower n) . unCookies+  where lookupL k = label (M.lookup k) (flip M.alter k . const)++-- | Convert a list to a cookies collection.++fromList :: [Cookie] -> Cookies+fromList = Cookies . M.fromList . map (\a -> (map toLower $ get name a, a))++-- | Get the cookies as a list.++toList :: Cookies -> [Cookie]+toList = map snd . M.toList . get unCookies+

+ src/Network/Protocol/Http.hs view

@@ -0,0 +1,98 @@+module Network.Protocol.Http+  (++  -- * HTTP message data types.++    Method (..)+  , Version+  , Key+  , Value+  , Headers (..)+  , Request (Request)+  , Response (Response)+  , Http (Http)++  -- * Creating (parts of) messages.++  , http10+  , http11+  , emptyHeaders+  , emptyRequest+  , emptyResponse++  -- * Accessing fields.++  , methods+  , major+  , minor+  , headers+  , version+  , headline+  , method+  , uri+  , asUri+  , status+  , normalizeHeader+  , header++  -- * Accessing specific header fields.++  , contentLength+  , connection+  , accept+  , acceptEncoding+  , acceptLanguage+  , cacheControl+  , keepAlive+  , cookie+  , setCookie+  , location+  , contentType+  , date+  , hostname+  , server+  , userAgent+  , upgrade+  , lastModified+  , acceptRanges+  , eTag++  -- * Parsing HTTP messages.++  , parseRequest+  , parseResponse+  , parseHeaders++  -- * Exposure of internal parsec parsers.++  , pRequest+  , pResponse+  , pHeaders+  , pVersion+  , pMethod++  -- * Parser helper methods.++  , versionFromString+  , methodFromString++  -- * Printer helper methods.++  , showRequestLine+  , showResponseLine++  -- * Handling HTTP status codes.++  , Status (..)+  , statusFailure+  , statusFromCode+  , codeFromStatus++  ) where++import Network.Protocol.Http.Data+import Network.Protocol.Http.Parser+import Network.Protocol.Http.Printer+import Network.Protocol.Http.Headers+import Network.Protocol.Http.Status+

+ src/Network/Protocol/Http/Data.hs view

@@ -0,0 +1,156 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Network.Protocol.Http.Data where++import Control.Category+import Data.Char+import Data.List+import Data.List.Split+import Data.Record.Label+import Network.Protocol.Http.Status+import Network.Protocol.Uri+import Prelude hiding ((.), id, lookup, mod)++-- | List of HTTP request methods.++data Method =+    OPTIONS+  | GET+  | HEAD+  | POST+  | PUT+  | DELETE+  | TRACE+  | CONNECT+  | OTHER String+  deriving (Show, Eq)++-- | HTTP protocol version.++data Version = Version {_major :: Int, _minor :: Int}+  deriving (Eq, Ord)++type Key   = String+type Value = String++-- | HTTP headers as mapping from keys to values.++newtype Headers = Headers { unHeaders :: [(Key, Value)] } -- order seems to matter+  deriving Eq++-- | Request specific part of HTTP messages.++data Request = Request  { __method :: Method, __uri :: String }+  deriving Eq++-- | Response specific part of HTTP messages.++data Response = Response { __status :: Status }+  deriving Eq++-- | An HTTP message. The message body is *not* included.++data Http a = Http+  { _headline :: a+  , _version  :: Version+  , _headers  :: Headers+  } deriving Eq++-- | All recognized method constructors as a list.++methods :: [Method]+methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]++-- | Create HTTP 1.0 version.++http10 :: Version+http10 = Version 1 0++-- | Create HTTP 1.1 version.++http11 :: Version+http11 = Version 1 1++-- | Create an empty set of headers.++emptyHeaders :: Headers+emptyHeaders = Headers []++-- | Create an empty HTTP request message.++emptyRequest :: Http Request+emptyRequest = Http (Request GET "") http11 emptyHeaders++-- | Create an empty HTTP response message.++emptyResponse :: Http Response+emptyResponse = Http (Response OK) http11 emptyHeaders++$(mkLabels [''Version, ''Request, ''Response, ''Http])++-- | Label to access the major part of the version.++major :: Version :-> Int++-- | Label to access the minor part of the version.++minor :: Version :-> Int++-- Internal helper labels.++_uri    :: Request :-> String+_method :: Request :-> Method+_status :: Response :-> Status++-- | Label to access the header of an HTTP message.++headers :: Http a :-> Headers++-- | Label to access the version part of an HTTP message.++version :: Http a :-> Version++-- | Label to access the header line part of an HTTP message.++headline :: Http a :-> a++-- | Label to access the method part of an HTTP request message.++method :: Http Request :-> Method+method = _method . headline++-- | Label to access the URI part of an HTTP request message.++uri :: Http Request :-> String+uri = _uri . headline++-- | Label to access the URI part of an HTTP request message and access it as a+-- true URI data type.++asUri :: Http Request :-> Uri+asUri = (toUri <-> show) `iso` uri++-- | Label to access the status part of an HTTP response message.++status :: Http Response :-> Status+status = _status . headline++-- | Normalize the capitalization of an HTTP header key.++normalizeHeader :: Key -> Key+normalizeHeader = intercalate "-" . map casing . splitOn "-"+  where+  casing ""     = ""+  casing (x:xs) = toUpper x : map toLower xs++-- | Generic label to access an HTTP header field by key.++header :: Key -> Http a :-> Maybe Value+header key = label+  (lookup (normalizeHeader key) . unHeaders . get headers)+  (\x -> mod headers (Headers . alter (normalizeHeader key) x . unHeaders))+  where+  alter :: Eq a => a -> Maybe b -> [(a, b)] -> [(a, b)]+  alter k v []                      = maybe [] (\w -> (k, w):[]) v+  alter k v ((x, y):xs) | k == x    = maybe xs (\w -> (k, w):xs) v+                        | otherwise = (x, y) : alter k v xs+

+ src/Network/Protocol/Http/Headers.hs view

@@ -0,0 +1,114 @@+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Http.Headers where {- doc ok -}++import Control.Category+import Control.Monad+import Data.Record.Label+import Network.Protocol.Http.Data+import Network.Protocol.Uri.Query+import Prelude hiding ((.), id)+import Safe++-- | Access the /Content-Length/ header field.++contentLength :: (Read i, Integral i) => Http a :-> Maybe i+contentLength = (join . fmap readMay <-> fmap show) `iso` header "Content-Length"++-- | Access the /Connection/ header field.++connection :: Http a :-> Maybe String+connection = header "Connection"++-- | Access the /Accept/ header field.++accept :: Http a :-> Maybe Parameters+accept = lmap (keyValues "," ";") `iso` header "Accept"++-- | Access the /Accept-Encoding/ header field.++acceptEncoding :: Http a :-> Maybe [String]+acceptEncoding = lmap (values ",") `iso` header "Accept-Encoding"++-- | Access the /Accept-Language/ header field.++acceptLanguage :: Http a :-> Maybe [String]+acceptLanguage = lmap (values ",") `iso` header "Accept-Language"++-- | Access the /Connection/ header field.++cacheControl :: Http a :-> Maybe String+cacheControl = header "Cache-Control"++-- | Access the /Keep-Alive/ header field.++keepAlive :: (Read i, Integral i) => Http a :-> Maybe i+keepAlive = (join . fmap readMay <-> fmap show) `iso` header "Keep-Alive"++-- | Access the /Cookie/ header field.++cookie :: Http Request :-> Maybe String+cookie = header "Cookie"++-- | Access the /Set-Cookie/ header field.++setCookie :: Http Response :-> Maybe String+setCookie = header "Set-Cookie"++-- | Access the /Location/ header field.++location :: Http a :-> Maybe String+location = header "Location"++-- | Access the /Content-Type/ header field. The content-type will be parsed+-- into a mimetype and optional charset.++contentType :: Http a :-> Maybe (String, Maybe String)+contentType = +        (parser <-> fmap printer)+  `iso` lmap (keyValues ";" "=")+  `iso` header "Content-Type"+  where +    printer (x, y) = (x, Nothing) : maybe [] (\z -> [("charset", Just z)]) y+    parser (Just ((m, Nothing):("charset", c):_)) = Just (m, c)+    parser _                                      = Nothing++-- | Access the /Date/ header field.++date :: Http a :-> Maybe String+date = header "Date"++-- | Access the /Host/ header field.++hostname :: Http a :-> Maybe String+hostname = header "Host"++-- | Access the /Server/ header field.++server :: Http a :-> Maybe String+server = header "Server"++-- | Access the /User-Agent/ header field.++userAgent :: Http a :-> Maybe String+userAgent = header "User-Agent"++-- | Access the /Upgrade/ header field.++upgrade :: Http a :-> Maybe String+upgrade = header "Upgrade"++-- | Access the /Last-Modified/ header field.++lastModified :: Http a :-> Maybe Value+lastModified = header "Last-Modified"++-- | Access the /Accept-Ranges/ header field.++acceptRanges :: Http a :-> Maybe Value+acceptRanges = header "Accept-Ranges"++-- | Access the /ETag/ header field.++eTag :: Http a :-> Maybe Value+eTag = header "ETag"+

+ src/Network/Protocol/Http/Parser.hs view

@@ -0,0 +1,137 @@+{-# LANGUAGE TypeOperators, FlexibleContexts #-}+module Network.Protocol.Http.Parser+(++-- * Top level message parsers.++  parseRequest+, parseResponse+, parseHeaders++-- * Exposure of internal parsec parsers.++, pRequest+, pResponse+, pHeaders+, pVersion+, pMethod++-- * Helper methods.++, versionFromString+, methodFromString++)+where++import Control.Applicative hiding (empty)+import Data.Char+import Data.List hiding (insert)+import Network.Protocol.Http.Data+import Network.Protocol.Http.Status+import Text.ParserCombinators.Parsec hiding (many, (<|>))++-- | Parse a string as an HTTP request message. This parser is very forgiving.++parseRequest :: String -> Either String (Http Request)+parseRequest = either (Left . show) (Right . id) . parse pRequest ""++-- | Parse a string as an HTTP request message. This parser is very forgiving.++parseResponse :: String -> Either String (Http Response)+parseResponse = either (Left . show) (Right . id) . parse pResponse ""++-- | Parse a string as a list of HTTP headers.++parseHeaders :: String -> Either String Headers+parseHeaders = either (Left . show) (Right . id) . parse pHeaders ""++-- | Parsec parser to parse the header part of an HTTP request.++pRequest :: GenParser Char st (Http Request)+pRequest =+      (\m u v h -> Http (Request m u) v h)+  <$> (pMethod <* many1 (oneOf ls))+  <*> (many1 (noneOf ws) <* many1 (oneOf ls))+  <*> (pVersion <* eol)+  <*> (pHeaders <* eol)++-- | Parsec parser to parse the header part of an HTTP response.++pResponse :: GenParser Char st (Http Response)+pResponse =+      (\v s h -> Http (Response (statusFromCode $ read s)) v h)+  <$> (pVersion <* many1 (oneOf ls))+  <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* eol)+  <*> (pHeaders <* eol)++-- | Parsec parser to parse one or more, possibly multiline, HTTP header lines.++pHeaders :: GenParser Char st Headers+pHeaders = Headers <$> p+  where+    p = (\k v -> ((k, v):))+        <$> many1 (noneOf (':':ws)) <* string ":"+        <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* eol))+        <*> option [] p++-- | Parsec parser to parse HTTP versions. Recognizes X.X versions only.++pVersion :: GenParser Char st Version+pVersion = +      (\h l -> Version (ord h - ord '0') (ord l  - ord '0'))+  <$> (istring "HTTP/" *> digit)+  <*> (char '.'       *> digit)++-- | Parsec parser to parse an HTTP method. Parses arbitrary method but+-- actually recognizes the ones listed as a constructor for `Method'.++pMethod :: GenParser Char st Method+pMethod =+     choice+   $ map (\a -> a <$ (try . istring . show $ a)) methods+  ++ [OTHER <$> many (noneOf ws)]++-- | Recognizes HTTP protocol version 1.0 and 1.1, all other string will+-- produce version 1.1.++versionFromString :: String -> Version+versionFromString "HTTP/1.1" = http11+versionFromString "HTTP/1.0" = http10+versionFromString _          = http11++-- | Helper to turn fully capitalized string into request method.++methodFromString :: String -> Method+methodFromString "OPTIONS" = OPTIONS+methodFromString "GET"     = GET +methodFromString "HEAD"    = HEAD+methodFromString "POST"    = POST+methodFromString "PUT"     = PUT +methodFromString "DELETE"  = DELETE+methodFromString "TRACE"   = TRACE+methodFromString "CONNECT" = CONNECT+methodFromString xs        = OTHER xs++-- Helpers.++lf, ws, ls :: String+lf = "\r\n"+ws = " \t\r\n"+ls = " \t"++-- Optional parser with maybe result.++pMaybe :: GenParser tok st a -> GenParser tok st (Maybe a)+pMaybe a = option Nothing (Just <$> a)++-- Parse end of line, \r, \n or \r\n.++eol :: GenParser Char st ()+eol = () <$ ((char '\r' <* pMaybe (char '\n')) <|> char '\n')++-- Case insensitive string parser.++istring :: String -> GenParser Char st String+istring s = sequence (map (\c -> satisfy (\d -> toUpper c == toUpper d)) s)+

+ src/Network/Protocol/Http/Printer.hs view

@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances #-}+module Network.Protocol.Http.Printer+( showRequestLine+, showResponseLine+)+where {- doc ok -}++import Network.Protocol.Http.Data+import Network.Protocol.Http.Status++instance Show (Http Request) where+  showsPrec _ r@(Http Request {} _ hs) =+    showRequestLine r . shows hs . eol++instance Show (Http Response) where+  showsPrec _ r@(Http Response {} _ hs) =+    showResponseLine r . shows hs . eol++-- | Show HTTP request status line.++showRequestLine :: Http Request -> String -> String+showRequestLine (Http (Request m u) v _) =+    shows m . ss " " . ss u . ss " "+  . shows v . eol++-- | Show HTTP response status line.++showResponseLine :: Http Response -> String -> String+showResponseLine (Http (Response s) v _) =+    shows v . ss " "+  . shows (codeFromStatus s)+  . ss " " . shows s . eol++instance Show Headers where+  showsPrec _ =+      foldr (\a b -> a . eol . b) id+    . map (\(k, a) -> ss k . ss ": " . ss a)+    . unHeaders++instance Show Version where+  showsPrec _ (Version a b) = ss "HTTP/" . shows a . ss "." . shows b++eol :: ShowS+eol = ss "\r\n"++ss :: String -> ShowS+ss = showString+

+ src/Network/Protocol/Http/Status.hs view

@@ -0,0 +1,164 @@+module Network.Protocol.Http.Status where {- doc ok -}++import Data.Bimap+import Data.Maybe+import Prelude hiding (lookup)++{- | HTTP status codes. -}++data Status =+    Continue                     -- ^ 100+  | SwitchingProtocols           -- ^ 101+  | OK                           -- ^ 200+  | Created                      -- ^ 201+  | Accepted                     -- ^ 202+  | NonAuthoritativeInformation  -- ^ 203+  | NoContent                    -- ^ 204+  | ResetContent                 -- ^ 205+  | PartialContent               -- ^ 206+  | MultipleChoices              -- ^ 300+  | MovedPermanently             -- ^ 301+  | Found                        -- ^ 302+  | SeeOther                     -- ^ 303+  | NotModified                  -- ^ 304+  | UseProxy                     -- ^ 305+  | TemporaryRedirect            -- ^ 307+  | BadRequest                   -- ^ 400+  | Unauthorized                 -- ^ 401+  | PaymentRequired              -- ^ 402+  | Forbidden                    -- ^ 403+  | NotFound                     -- ^ 404+  | MethodNotAllowed             -- ^ 405+  | NotAcceptable                -- ^ 406+  | ProxyAuthenticationRequired  -- ^ 407+  | RequestTimeOut               -- ^ 408+  | Conflict                     -- ^ 409+  | Gone                         -- ^ 410+  | LengthRequired               -- ^ 411+  | PreconditionFailed           -- ^ 412+  | RequestEntityTooLarge        -- ^ 413+  | RequestURITooLarge           -- ^ 414+  | UnsupportedMediaType         -- ^ 415+  | RequestedRangeNotSatisfiable -- ^ 416+  | ExpectationFailed            -- ^ 417+  | InternalServerError          -- ^ 500+  | NotImplemented               -- ^ 501+  | BadGateway                   -- ^ 502+  | ServiceUnavailable           -- ^ 503+  | GatewayTimeOut               -- ^ 504+  | HTTPVersionNotSupported      -- ^ 505+  | CustomStatus Int String+  deriving (Eq, Ord)++{- | rfc2616 sec6.1.1 Status Code and Reason Phrase. -}++instance Show Status where+  show Continue                     = "Continue"+  show SwitchingProtocols           = "Switching Protocols"+  show OK                           = "OK"+  show Created                      = "Created"+  show Accepted                     = "Accepted"+  show NonAuthoritativeInformation  = "Non-Authoritative Information"+  show NoContent                    = "No Content"+  show ResetContent                 = "Reset Content"+  show PartialContent               = "Partial Content"+  show MultipleChoices              = "Multiple Choices"+  show MovedPermanently             = "Moved Permanently"+  show Found                        = "Found"+  show SeeOther                     = "See Other"+  show NotModified                  = "Not Modified"+  show UseProxy                     = "Use Proxy"+  show TemporaryRedirect            = "Temporary Redirect"+  show BadRequest                   = "Bad Request"+  show Unauthorized                 = "Unauthorized"+  show PaymentRequired              = "Payment Required"+  show Forbidden                    = "Forbidden"+  show NotFound                     = "Not Found"+  show MethodNotAllowed             = "Method Not Allowed"+  show NotAcceptable                = "Not Acceptable"+  show ProxyAuthenticationRequired  = "Proxy Authentication Required"+  show RequestTimeOut               = "Request Time-out"+  show Conflict                     = "Conflict"+  show Gone                         = "Gone"+  show LengthRequired               = "Length Required"+  show PreconditionFailed           = "Precondition Failed"+  show RequestEntityTooLarge        = "Request Entity Too Large"+  show RequestURITooLarge           = "Request-URI Too Large"+  show UnsupportedMediaType         = "Unsupported Media Type"+  show RequestedRangeNotSatisfiable = "Requested range not satisfiable"+  show ExpectationFailed            = "Expectation Failed"+  show InternalServerError          = "Internal Server Error"+  show NotImplemented               = "Not Implemented"+  show BadGateway                   = "Bad Gateway"+  show ServiceUnavailable           = "Service Unavailable"+  show GatewayTimeOut               = "Gateway Time-out"+  show HTTPVersionNotSupported      = "HTTP Version not supported"+  show (CustomStatus _ s)           = s++{- |+RFC2616 sec6.1.1 Status Code and Reason Phrase.++Bidirectional mapping from status numbers to codes.+-}++statusCodes :: Bimap Int Status+statusCodes = fromList [+    (100, Continue)+  , (101, SwitchingProtocols)+  , (200, OK)+  , (201, Created)+  , (202, Accepted)+  , (203, NonAuthoritativeInformation)+  , (204, NoContent)+  , (205, ResetContent)+  , (206, PartialContent)+  , (300, MultipleChoices)+  , (301, MovedPermanently)+  , (302, Found)+  , (303, SeeOther)+  , (304, NotModified)+  , (305, UseProxy)+  , (307, TemporaryRedirect)+  , (400, BadRequest)+  , (401, Unauthorized)+  , (402, PaymentRequired)+  , (403, Forbidden)+  , (404, NotFound)+  , (405, MethodNotAllowed)+  , (406, NotAcceptable)+  , (407, ProxyAuthenticationRequired)+  , (408, RequestTimeOut)+  , (409, Conflict)+  , (410, Gone)+  , (411, LengthRequired)+  , (412, PreconditionFailed)+  , (413, RequestEntityTooLarge)+  , (414, RequestURITooLarge)+  , (415, UnsupportedMediaType)+  , (416, RequestedRangeNotSatisfiable)+  , (417, ExpectationFailed)+  , (500, InternalServerError)+  , (501, NotImplemented)+  , (502, BadGateway)+  , (503, ServiceUnavailable)+  , (504, GatewayTimeOut)+  , (505, HTTPVersionNotSupported)+  ]++-- | Every status greater-than or equal to 400 is considered to be a failure.+statusFailure :: Status -> Bool+statusFailure st = codeFromStatus st >= 400++-- | Conversion from status numbers to codes.+statusFromCode :: Int -> Status+statusFromCode num =+    fromMaybe (CustomStatus num "Unknown Status")+  $ lookup num statusCodes++-- | Conversion from status codes to numbers.+codeFromStatus :: Status -> Int+codeFromStatus (CustomStatus i _) = i+codeFromStatus st =+    fromMaybe 0 -- function is total, should not happen.+  $ lookupR st statusCodes+

+ src/Network/Protocol/Mime.hs view

@@ -0,0 +1,664 @@+{- |+Handling mime types. This module contains a mapping from file extensions to+mime-types taken from the Apache webserver project.+-}++module Network.Protocol.Mime where++import Data.Map++type Mime = String++{- | Get the mimetype for the specified extension. -}++mime :: String -> Maybe Mime+mime ext = Data.Map.lookup ext extensionToMime++{- | The default mimetype is text/plain. -}++defaultMime :: Mime+defaultMime = "text/plain"++{- | The mapping from extension to mimetype. -}++extensionToMime :: Map String Mime+extensionToMime = fromList+  [ ("123",       "application/vnd.lotus-1-2-3")+  , ("3dml",      "text/vnd.in3d.3dml")+  , ("3g2",       "video/3gpp2")+  , ("3gp",       "video/3gpp")+  , ("ace",       "application/x-ace-compressed")+  , ("acu",       "application/vnd.acucobol")+  , ("acutc",     "application/vnd.acucorp")+  , ("aep",       "application/vnd.audiograph")+  , ("afp",       "application/vnd.ibm.modcap")+  , ("ai",        "application/postscript")+  , ("aif",       "audio/x-aiff")+  , ("aifc",      "audio/x-aiff")+  , ("aiff",      "audio/x-aiff")+  , ("ami",       "application/vnd.amiga.ami")+  , ("apr",       "application/vnd.lotus-approach")+  , ("asc",       "application/pgp-signature")+  , ("asf",       "application/vnd.ms-asf")+  , ("asf",       "video/x-ms-asf")+  , ("asm",       "text/x-asm")+  , ("aso",       "application/vnd.accpac.simply.aso")+  , ("asx",       "video/x-ms-asf")+  , ("atc",       "application/vnd.acucorp")+  , ("atom",      "application/atom+xml")+  , ("atomcat",   "application/atomcat+xml")+  , ("atomsvc",   "application/atomsvc+xml")+  , ("atx",       "application/vnd.antix.game-component")+  , ("au",        "audio/basic")+  , ("bat",       "application/x-msdownload")+  , ("bcpio",     "application/x-bcpio")+  , ("bdm",       "application/vnd.syncml.dm+wbxml")+  , ("bh2",       "application/vnd.fujitsu.oasysprs")+  , ("bin",       "application/octet-stream")+  , ("bmi",       "application/vnd.bmi")+  , ("bmp",       "image/bmp")+  , ("box",       "application/vnd.previewsystems.box")+  , ("boz",       "application/x-bzip2")+  , ("bpk",       "application/octet-stream")+  , ("btif",      "image/prs.btif")+  , ("bz",        "application/x-bzip")+  , ("bz2",       "application/x-bzip2")+  , ("c",         "text/x-c")+  , ("c4d",       "application/vnd.clonk.c4group")+  , ("c4f",       "application/vnd.clonk.c4group")+  , ("c4g",       "application/vnd.clonk.c4group")+  , ("c4p",       "application/vnd.clonk.c4group")+  , ("c4u",       "application/vnd.clonk.c4group")+  , ("cab",       "application/vnd.ms-cab-compressed")+  , ("cc",        "text/x-c")+  , ("ccxml",     "application/ccxml+xml")+  , ("cdbcmsg",   "application/vnd.contact.cmsg")+  , ("cdf",       "application/x-netcdf")+  , ("cdkey",     "application/vnd.mediastation.cdkey")+  , ("cdx",       "chemical/x-cdx")+  , ("cdxml",     "application/vnd.chemdraw+xml")+  , ("cdy",       "application/vnd.cinderella")+  , ("cer",       "application/pkix-cert")+  , ("cgm",       "image/cgm")+  , ("chat",      "application/x-chat")+  , ("chm",       "application/vnd.ms-htmlhelp")+  , ("chrt",      "application/vnd.kde.kchart")+  , ("cif",       "chemical/x-cif")+  , ("cii",       "application/vnd.anser-web-certificate-issue-initiation")+  , ("cil",       "application/vnd.ms-artgalry")+  , ("cla",       "application/vnd.claymore")+  , ("class",     "application/octet-stream")+  , ("clkk",      "application/vnd.crick.clicker.keyboard")+  , ("clkp",      "application/vnd.crick.clicker.palette")+  , ("clkt",      "application/vnd.crick.clicker.template")+  , ("clkw",      "application/vnd.crick.clicker.wordbank")+  , ("clkx",      "application/vnd.crick.clicker")+  , ("clp",       "application/x-msclip")+  , ("cmc",       "application/vnd.cosmocaller")+  , ("cmdf",      "chemical/x-cmdf")+  , ("cml",       "chemical/x-cml")+  , ("cmp",       "application/vnd.yellowriver-custom-menu")+  , ("cmx",       "image/x-cmx")+  , ("com",       "application/x-msdownload")+  , ("conf",      "text/plain")+  , ("cpio",      "application/x-cpio")+  , ("cpp",       "text/x-c")+  , ("cpt",       "application/mac-compactpro")+  , ("crd",       "application/x-mscardfile")+  , ("crl",       "application/pkix-crl")+  , ("crt",       "application/x-x509-ca-cert")+  , ("csh",       "application/x-csh")+  , ("csml",      "chemical/x-csml")+  , ("csp",       "application/vnd.commonspace")+  , ("css",       "text/css")+  , ("cst",       "application/vnd.commonspace")+  , ("csv",       "text/csv")+  , ("curl",      "application/vnd.curl")+  , ("cww",       "application/prs.cww")+  , ("cxx",       "text/x-c")+  , ("daf",       "application/vnd.mobius.daf")+  , ("davmount",  "application/davmount+xml")+  , ("dcr",       "application/x-director")+  , ("dd2",       "application/vnd.oma.dd2+xml")+  , ("ddd",       "application/vnd.fujixerox.ddd")+  , ("def",       "text/plain")+  , ("der",       "application/x-x509-ca-cert")+  , ("dfac",      "application/vnd.dreamfactory")+  , ("dic",       "text/x-c")+  , ("dir",       "application/x-director")+  , ("dis",       "application/vnd.mobius.dis")+  , ("dist",      "application/octet-stream")+  , ("distz",     "application/octet-stream")+  , ("djv",       "image/vnd.djvu")+  , ("djvu",      "image/vnd.djvu")+  , ("dll",       "application/x-msdownload")+  , ("dmg",       "application/octet-stream")+  , ("dms",       "application/octet-stream")+  , ("dna",       "application/vnd.dna")+  , ("doc",       "application/msword")+  , ("dot",       "application/msword")+  , ("dp",        "application/vnd.osgi.dp")+  , ("dpg",       "application/vnd.dpgraph")+  , ("dsc",       "text/prs.lines.tag")+  , ("dtd",       "application/xml-dtd")+  , ("dump",      "application/octet-stream")+  , ("dvi",       "application/x-dvi")+  , ("dwf",       "model/vnd.dwf")+  , ("dwg",       "image/vnd.dwg")+  , ("dxf",       "image/vnd.dxf")+  , ("dxp",       "application/vnd.spotfire.dxp")+  , ("dxr",       "application/x-director")+  , ("ecelp4800", "audio/vnd.nuera.ecelp4800")+  , ("ecelp7470", "audio/vnd.nuera.ecelp7470")+  , ("ecelp9600", "audio/vnd.nuera.ecelp9600")+  , ("ecma",      "application/ecmascript")+  , ("edm",       "application/vnd.novadigm.edm")+  , ("edx",       "application/vnd.novadigm.edx")+  , ("efif",      "application/vnd.picsel")+  , ("ei6",       "application/vnd.pg.osasli")+  , ("elc",       "application/octet-stream")+  , ("eml",       "message/rfc822")+  , ("eol",       "audio/vnd.digital-winds")+  , ("eot",       "application/vnd.ms-fontobject")+  , ("eps",       "application/postscript")+  , ("es3",       "application/vnd.eszigno3+xml")+  , ("esf",       "application/vnd.epson.esf")+  , ("et3",       "application/vnd.eszigno3+xml")+  , ("etx",       "text/x-setext")+  , ("exe",       "application/x-msdownload")+  , ("ext",       "application/vnd.novadigm.ext")+  , ("ez",        "application/andrew-inset")+  , ("ez2",       "application/vnd.ezpix-album")+  , ("ez3",       "application/vnd.ezpix-package")+  , ("f",         "text/x-fortran")+  , ("f77",       "text/x-fortran")+  , ("f90",       "text/x-fortran")+  , ("fbs",       "image/vnd.fastbidsheet")+  , ("fdf",       "application/vnd.fdf")+  , ("fe_launch", "application/vnd.denovo.fcselayout-link")+  , ("fg5",       "application/vnd.fujitsu.oasysgp")+  , ("fgd",       "application/x-director")+  , ("fli",       "video/x-fli")+  , ("flo",       "application/vnd.micrografx.flo")+  , ("flw",       "application/vnd.kde.kivio")+  , ("flx",       "text/vnd.fmi.flexstor")+  , ("fly",       "text/vnd.fly")+  , ("fm",        "application/vnd.framemaker")+  , ("fnc",       "application/vnd.frogans.fnc")+  , ("for",       "text/x-fortran")+  , ("fpx",       "image/vnd.fpx")+  , ("frame",     "application/vnd.framemaker")+  , ("fsc",       "application/vnd.fsc.weblaunch")+  , ("fst",       "image/vnd.fst")+  , ("ftc",       "application/vnd.fluxtime.clip")+  , ("fti",       "application/vnd.anser-web-funds-transfer-initiation")+  , ("fvt",       "video/vnd.fvt")+  , ("fzs",       "application/vnd.fuzzysheet")+  , ("g3",        "image/g3fax")+  , ("gac",       "application/vnd.groove-account")+  , ("gdl",       "model/vnd.gdl")+  , ("ghf",       "application/vnd.groove-help")+  , ("gif",       "image/gif")+  , ("gim",       "application/vnd.groove-identity-message")+  , ("gph",       "application/vnd.flographit")+  , ("gqf",       "application/vnd.grafeq")+  , ("gqs",       "application/vnd.grafeq")+  , ("gram",      "application/srgs")+  , ("grv",       "application/vnd.groove-injector")+  , ("grxml",     "application/srgs+xml")+  , ("gtar",      "application/x-gtar")+  , ("gtm",       "application/vnd.groove-tool-message")+  , ("gtw",       "model/vnd.gtw")+  , ("h",         "text/x-c")+  , ("h261",      "video/h261")+  , ("h263",      "video/h263")+  , ("h264",      "video/h264")+  , ("hbci",      "application/vnd.hbci")+  , ("hdf",       "application/x-hdf")+  , ("hh",        "text/x-c")+  , ("hlp",       "application/winhlp")+  , ("hpgl",      "application/vnd.hp-hpgl")+  , ("hpid",      "application/vnd.hp-hpid")+  , ("hps",       "application/vnd.hp-hps")+  , ("hqx",       "application/mac-binhex40")+  , ("htke",      "application/vnd.kenameaapp")+  , ("htm",       "text/html")+  , ("html",      "text/html")+  , ("hvd",       "application/vnd.yamaha.hv-dic")+  , ("hvp",       "application/vnd.yamaha.hv-voice")+  , ("hvs",       "application/vnd.yamaha.hv-script")+  , ("ico",       "image/vnd.microsoft.icon")+  , ("ics",       "text/calendar")+  , ("ief",       "image/ief")+  , ("ifb",       "text/calendar")+  , ("ifm",       "application/vnd.shana.informed.formdata")+  , ("iges",      "model/iges")+  , ("igl",       "application/vnd.igloader")+  , ("igs",       "model/iges")+  , ("igx",       "application/vnd.micrografx.igx")+  , ("iif",       "application/vnd.shana.informed.interchange")+  , ("imp",       "application/vnd.accpac.simply.imp")+  , ("ims",       "application/vnd.ms-ims")+  , ("in",        "text/plain")+  , ("ipk",       "application/vnd.shana.informed.package")+  , ("irm",       "application/vnd.ibm.rights-management")+  , ("irp",       "application/vnd.irepository.package+xml")+  , ("iso",       "application/octet-stream")+  , ("itp",       "application/vnd.shana.informed.formtemplate")+  , ("ivp",       "application/vnd.immervision-ivp")+  , ("ivu",       "application/vnd.immervision-ivu")+  , ("jad",       "text/vnd.sun.j2me.app-descriptor")+  , ("jam",       "application/vnd.jam")+  , ("java",      "text/x-java-source")+  , ("jisp",      "application/vnd.jisp")+  , ("jlt",       "application/vnd.hp-jlyt")+  , ("jpe",       "image/jpeg")+  , ("jpeg",      "image/jpeg")+  , ("jpg",       "image/jpeg")+  , ("jpgm",      "video/jpm")+  , ("jpgv",      "video/jpeg")+  , ("jpm",       "video/jpm")+  , ("js",        "application/javascript")+  , ("json",      "application/json")+  , ("kar",       "audio/midi")+  , ("karbon",    "application/vnd.kde.karbon")+  , ("kfo",       "application/vnd.kde.kformula")+  , ("kia",       "application/vnd.kidspiration")+  , ("kml",       "application/vnd.google-earth.kml+xml")+  , ("kmz",       "application/vnd.google-earth.kmz")+  , ("kne",       "application/vnd.kinar")+  , ("knp",       "application/vnd.kinar")+  , ("kon",       "application/vnd.kde.kontour")+  , ("kpr",       "application/vnd.kde.kpresenter")+  , ("kpt",       "application/vnd.kde.kpresenter")+  , ("ksp",       "application/vnd.kde.kspread")+  , ("ktr",       "application/vnd.kahootz")+  , ("ktz",       "application/vnd.kahootz")+  , ("kwd",       "application/vnd.kde.kword")+  , ("kwt",       "application/vnd.kde.kword")+  , ("latex",     "application/x-latex")+  , ("lbd",       "application/vnd.llamagraphics.life-balance.desktop")+  , ("lbe",       "application/vnd.llamagraphics.life-balance.exchange+xml")+  , ("les",       "application/vnd.hhe.lesson-player")+  , ("lha",       "application/octet-stream")+  , ("list",      "text/plain")+  , ("list3820",  "application/vnd.ibm.modcap")+  , ("listafp",   "application/vnd.ibm.modcap")+  , ("log",       "text/plain")+  , ("lrm",       "application/vnd.ms-lrm")+  , ("ltf",       "application/vnd.frogans.ltf")+  , ("lvp",       "audio/vnd.lucent.voice")+  , ("lwp",       "application/vnd.lotus-wordpro")+  , ("lzh",       "application/octet-stream")+  , ("m13",       "application/x-msmediaview")+  , ("m14",       "application/x-msmediaview")+  , ("m1v",       "video/mpeg")+  , ("m2a",       "audio/mpeg")+  , ("m2v",       "video/mpeg")+  , ("m3a",       "audio/mpeg")+  , ("m3u",       "audio/x-mpegurl")+  , ("m4u",       "video/vnd.mpegurl")+  , ("ma",        "application/mathematica")+  , ("mag",       "application/vnd.ecowin.chart")+  , ("maker",     "application/vnd.framemaker")+  , ("man",       "text/troff")+  , ("mathml",    "application/mathml+xml")+  , ("mb",        "application/mathematica")+  , ("mbk",       "application/vnd.mobius.mbk")+  , ("mbox",      "application/mbox")+  , ("mc1",       "application/vnd.medcalcdata")+  , ("mcd",       "application/vnd.mcd")+  , ("mdb",       "application/x-msaccess")+  , ("mdi",       "image/vnd.ms-modi")+  , ("me",        "text/troff")+  , ("mesh",      "model/mesh")+  , ("mfm",       "application/vnd.mfmp")+  , ("mgz",       "application/vnd.proteus.magazine")+  , ("mid",       "audio/midi")+  , ("midi",      "audio/midi")+  , ("mif",       "application/vnd.mif")+  , ("mime",      "message/rfc822")+  , ("mj2",       "video/mj2")+  , ("mjp2",      "video/mj2")+  , ("mlp",       "application/vnd.dolby.mlp")+  , ("mmd",       "application/vnd.chipnuts.karaoke-mmd")+  , ("mmf",       "application/vnd.smaf")+  , ("mmr",       "image/vnd.fujixerox.edmics-mmr")+  , ("mny",       "application/x-msmoney")+  , ("mov",       "video/quicktime")+  , ("mp2",       "audio/mpeg")+  , ("mp2a",      "audio/mpeg")+  , ("mp3",       "audio/mpeg")+  , ("mp4",       "video/mp4")+  , ("mp4a",      "audio/mp4")+  , ("mp4s",      "application/mp4")+  , ("mp4v",      "video/mp4")+  , ("mpc",       "application/vnd.mophun.certificate")+  , ("mpe",       "video/mpeg")+  , ("mpeg",      "video/mpeg")+  , ("mpg",       "video/mpeg")+  , ("mpg4",      "video/mp4")+  , ("mpga",      "audio/mpeg")+  , ("mpkg",      "application/vnd.apple.installer+xml")+  , ("mpm",       "application/vnd.blueice.multipass")+  , ("mpn",       "application/vnd.mophun.application")+  , ("mpp",       "application/vnd.ms-project")+  , ("mpt",       "application/vnd.ms-project")+  , ("mpy",       "application/vnd.ibm.minipay")+  , ("mqy",       "application/vnd.mobius.mqy")+  , ("mrc",       "application/marc")+  , ("ms",        "text/troff")+  , ("mscml",     "application/mediaservercontrol+xml")+  , ("mseq",      "application/vnd.mseq")+  , ("msf",       "application/vnd.epson.msf")+  , ("msh",       "model/mesh")+  , ("msi",       "application/x-msdownload")+  , ("msl",       "application/vnd.mobius.msl")+  , ("mts",       "model/vnd.mts")+  , ("mus",       "application/vnd.musician")+  , ("mvb",       "application/x-msmediaview")+  , ("mwf",       "application/vnd.mfer")+  , ("mxf",       "application/mxf")+  , ("mxl",       "application/vnd.recordare.musicxml")+  , ("mxml",      "application/xv+xml")+  , ("mxs",       "application/vnd.triscape.mxs")+  , ("mxu",       "video/vnd.mpegurl")+  , ("n-gage",    "application/vnd.nokia.n-gage.symbian.install")+  , ("nb",        "application/mathematica")+  , ("nc",        "application/x-netcdf")+  , ("ngdat",     "application/vnd.nokia.n-gage.data")+  , ("nlu",       "application/vnd.neurolanguage.nlu")+  , ("nml",       "application/vnd.enliven")+  , ("nnd",       "application/vnd.noblenet-directory")+  , ("nns",       "application/vnd.noblenet-sealer")+  , ("nnw",       "application/vnd.noblenet-web")+  , ("npx",       "image/vnd.net-fpx")+  , ("nsf",       "application/vnd.lotus-notes")+  , ("oa2",       "application/vnd.fujitsu.oasys2")+  , ("oa3",       "application/vnd.fujitsu.oasys3")+  , ("oas",       "application/vnd.fujitsu.oasys")+  , ("obd",       "application/x-msbinder")+  , ("oda",       "application/oda")+  , ("odc",       "application/vnd.oasis.opendocument.chart")+  , ("odf",       "application/vnd.oasis.opendocument.formula")+  , ("odg",       "application/vnd.oasis.opendocument.graphics")+  , ("odi",       "application/vnd.oasis.opendocument.image")+  , ("odp",       "application/vnd.oasis.opendocument.presentation")+  , ("ods",       "application/vnd.oasis.opendocument.spreadsheet")+  , ("odt",       "application/vnd.oasis.opendocument.text")+  , ("ogg",       "application/ogg")+  , ("oprc",      "application/vnd.palm")+  , ("org",       "application/vnd.lotus-organizer")+  , ("otc",       "application/vnd.oasis.opendocument.chart-template")+  , ("otf",       "application/vnd.oasis.opendocument.formula-template")+  , ("otg",       "application/vnd.oasis.opendocument.graphics-template")+  , ("oth",       "application/vnd.oasis.opendocument.text-web")+  , ("oti",       "application/vnd.oasis.opendocument.image-template")+  , ("otm",       "application/vnd.oasis.opendocument.text-master")+  , ("otp",       "application/vnd.oasis.opendocument.presentation-template")+  , ("ots",       "application/vnd.oasis.opendocument.spreadsheet-template")+  , ("ott",       "application/vnd.oasis.opendocument.text-template")+  , ("oxt",       "application/vnd.openofficeorg.extension")+  , ("p",         "text/x-pascal")+  , ("p10",       "application/pkcs10")+  , ("p12",       "application/x-pkcs12")+  , ("p7b",       "application/x-pkcs7-certificates")+  , ("p7c",       "application/pkcs7-mime")+  , ("p7m",       "application/pkcs7-mime")+  , ("p7r",       "application/x-pkcs7-certreqresp")+  , ("p7s",       "application/pkcs7-signature")+  , ("pas",       "text/x-pascal")+  , ("pbd",       "application/vnd.powerbuilder6")+  , ("pbm",       "image/x-portable-bitmap")+  , ("pcl",       "application/vnd.hp-pcl")+  , ("pclxl",     "application/vnd.hp-pclxl")+  , ("pct",       "image/x-pict")+  , ("pcx",       "image/x-pcx")+  , ("pdb",       "application/vnd.palm")+  , ("pdb",       "chemical/x-pdb")+  , ("pdf",       "application/pdf")+  , ("pfr",       "application/font-tdpfr")+  , ("pfx",       "application/x-pkcs12")+  , ("pgm",       "image/x-portable-graymap")+  , ("pgn",       "application/x-chess-pgn")+  , ("pgp",       "application/pgp-encrypted")+  , ("pic",       "image/x-pict")+  , ("pkg",       "application/octet-stream")+  , ("pki",       "application/pkixcmp")+  , ("pkipath",   "application/pkix-pkipath")+  , ("plb",       "application/vnd.3gpp.pic-bw-large")+  , ("plc",       "application/vnd.mobius.plc")+  , ("plf",       "application/vnd.pocketlearn")+  , ("pls",       "application/pls+xml")+  , ("pml",       "application/vnd.ctc-posml")+  , ("png",       "image/png")+  , ("pnm",       "image/x-portable-anymap")+  , ("portpkg",   "application/vnd.macports.portpkg")+  , ("pot",       "application/vnd.ms-powerpoint")+  , ("ppd",       "application/vnd.cups-ppd")+  , ("ppm",       "image/x-portable-pixmap")+  , ("pps",       "application/vnd.ms-powerpoint")+  , ("ppt",       "application/vnd.ms-powerpoint")+  , ("pqa",       "application/vnd.palm")+  , ("prc",       "application/vnd.palm")+  , ("pre",       "application/vnd.lotus-freelance")+  , ("prf",       "application/pics-rules")+  , ("ps",        "application/postscript")+  , ("psb",       "application/vnd.3gpp.pic-bw-small")+  , ("psd",       "image/vnd.adobe.photoshop")+  , ("ptid",      "application/vnd.pvi.ptid1")+  , ("pub",       "application/x-mspublisher")+  , ("pvb",       "application/vnd.3gpp.pic-bw-var")+  , ("pwn",       "application/vnd.3m.post-it-notes")+  , ("qam",       "application/vnd.epson.quickanime")+  , ("qbo",       "application/vnd.intu.qbo")+  , ("qfx",       "application/vnd.intu.qfx")+  , ("qps",       "application/vnd.publishare-delta-tree")+  , ("qt",        "video/quicktime")+  , ("qwd",       "application/vnd.quark.quarkxpress")+  , ("qwt",       "application/vnd.quark.quarkxpress")+  , ("qxb",       "application/vnd.quark.quarkxpress")+  , ("qxd",       "application/vnd.quark.quarkxpress")+  , ("qxl",       "application/vnd.quark.quarkxpress")+  , ("qxt",       "application/vnd.quark.quarkxpress")+  , ("ra",        "audio/x-pn-realaudio")+  , ("ram",       "audio/x-pn-realaudio")+  , ("rar",       "application/x-rar-compressed")+  , ("ras",       "image/x-cmu-raster")+  , ("rcprofile", "application/vnd.ipunplugged.rcprofile")+  , ("rdf",       "application/rdf+xml")+  , ("rdz",       "application/vnd.data-vision.rdz")+  , ("rep",       "application/vnd.businessobjects")+  , ("rgb",       "image/x-rgb")+  , ("rif",       "application/reginfo+xml")+  , ("rl",        "application/resource-lists+xml")+  , ("rlc",       "image/vnd.fujixerox.edmics-rlc")+  , ("rm",        "application/vnd.rn-realmedia")+  , ("rmi",       "audio/midi")+  , ("rmp",       "audio/x-pn-realaudio-plugin")+  , ("rms",       "application/vnd.jcp.javame.midlet-rms")+  , ("rnc",       "application/relax-ng-compact-syntax")+  , ("roff",      "text/troff")+  , ("rpss",      "application/vnd.nokia.radio-presets")+  , ("rpst",      "application/vnd.nokia.radio-preset")+  , ("rs",        "application/rls-services+xml")+  , ("rsd",       "application/rsd+xml")+  , ("rss",       "application/rss+xml")+  , ("rtf",       "application/rtf")+  , ("rtx",       "text/richtext")+  , ("s",         "text/x-asm")+  , ("saf",       "application/vnd.yamaha.smaf-audio")+  , ("sbml",      "application/sbml+xml")+  , ("sc",        "application/vnd.ibm.secure-container")+  , ("scd",       "application/x-msschedule")+  , ("scm",       "application/vnd.lotus-screencam")+  , ("sdkd",      "application/vnd.solent.sdkm+xml")+  , ("sdkm",      "application/vnd.solent.sdkm+xml")+  , ("sdp",       "application/sdp")+  , ("see",       "application/vnd.seemail")+  , ("sema",      "application/vnd.sema")+  , ("semd",      "application/vnd.semd")+  , ("semf",      "application/vnd.semf")+  , ("setpay",    "application/set-payment-initiation")+  , ("setreg",    "application/set-registration-initiation")+  , ("sfs",       "application/vnd.spotfire.sfs")+  , ("sgm",       "text/sgml")+  , ("sgml",      "text/sgml")+  , ("sh",        "application/x-sh")+  , ("shar",      "application/x-shar")+  , ("shf",       "application/shf+xml")+  , ("sig",       "application/pgp-signature")+  , ("silo",      "model/mesh")+  , ("sit",       "application/x-stuffit")+  , ("sitx",      "application/x-stuffitx")+  , ("skd",       "application/vnd.koan")+  , ("skm",       "application/vnd.koan")+  , ("skp",       "application/vnd.koan")+  , ("skt",       "application/vnd.koan")+  , ("slt",       "application/vnd.epson.salt")+  , ("smi",       "application/smil+xml")+  , ("smil",      "application/smil+xml")+  , ("snd",       "audio/basic")+  , ("so",        "application/octet-stream")+  , ("spc",       "application/x-pkcs7-certificates")+  , ("spf",       "application/vnd.yamaha.smaf-phrase")+  , ("spl",       "application/x-futuresplash")+  , ("spot",      "text/vnd.in3d.spot")+  , ("src",       "application/x-wais-source")+  , ("ssf",       "application/vnd.epson.ssf")+  , ("ssml",      "application/ssml+xml")+  , ("stf",       "application/vnd.wt.stf")+  , ("stk",       "application/hyperstudio")+  , ("str",       "application/vnd.pg.format")+  , ("sus",       "application/vnd.sus-calendar")+  , ("susp",      "application/vnd.sus-calendar")+  , ("sv4cpio",   "application/x-sv4cpio")+  , ("sv4crc",    "application/x-sv4crc")+  , ("svd",       "application/vnd.svd")+  , ("svg",       "image/svg+xml")+  , ("svgz",      "image/svg+xml")+  , ("swf",       "application/x-shockwave-flash")+  , ("t",         "text/troff")+  , ("tao",       "application/vnd.tao.intent-module-archive")+  , ("tar",       "application/x-tar")+  , ("tcl",       "application/x-tcl")+  , ("tex",       "application/x-tex")+  , ("texi",      "application/x-texinfo")+  , ("texinfo",   "application/x-texinfo")+  , ("text",      "text/plain")+  , ("tif",       "image/tiff")+  , ("tiff",      "image/tiff")+  , ("tmo",       "application/vnd.tmobile-livetv")+  , ("torrent",   "application/x-bittorrent")+  , ("tpl",       "application/vnd.groove-tool-template")+  , ("tpt",       "application/vnd.trid.tpt")+  , ("tr",        "text/troff")+  , ("tra",       "application/vnd.trueapp")+  , ("trm",       "application/x-msterminal")+  , ("tsv",       "text/tab-separated-values")+  , ("twd",       "application/vnd.simtech-mindmapper")+  , ("twds",      "application/vnd.simtech-mindmapper")+  , ("txd",       "application/vnd.genomatix.tuxedo")+  , ("txf",       "application/vnd.mobius.txf")+  , ("txt",       "text/plain")+  , ("ufd",       "application/vnd.ufdl")+  , ("ufdl",      "application/vnd.ufdl")+  , ("umj",       "application/vnd.umajin")+  , ("unityweb",  "application/vnd.unity")+  , ("uoml",      "application/vnd.uoml+xml")+  , ("uri",       "text/uri-list")+  , ("uris",      "text/uri-list")+  , ("urls",      "text/uri-list")+  , ("ustar",     "application/x-ustar")+  , ("utz",       "application/vnd.uiq.theme")+  , ("uu",        "text/x-uuencode")+  , ("vcd",       "application/x-cdlink")+  , ("vcf",       "text/x-vcard")+  , ("vcg",       "application/vnd.groove-vcard")+  , ("vcs",       "text/x-vcalendar")+  , ("vcx",       "application/vnd.vcx")+  , ("vis",       "application/vnd.visionary")+  , ("viv",       "video/vnd.vivo")+  , ("vrml",      "model/vrml")+  , ("vsd",       "application/vnd.visio")+  , ("vsf",       "application/vnd.vsf")+  , ("vss",       "application/vnd.visio")+  , ("vst",       "application/vnd.visio")+  , ("vsw",       "application/vnd.visio")+  , ("vtu",       "model/vnd.vtu")+  , ("vxml",      "application/voicexml+xml")+  , ("wav",       "audio/wav")+  , ("wav",       "audio/x-wav")+  , ("wax",       "audio/x-ms-wax")+  , ("wbmp",      "image/vnd.wap.wbmp")+  , ("wbs",       "application/vnd.criticaltools.wbs+xml")+  , ("wbxml",     "application/vnd.wap.wbxml")+  , ("wcm",       "application/vnd.ms-works")+  , ("wdb",       "application/vnd.ms-works")+  , ("wks",       "application/vnd.ms-works")+  , ("wm",        "video/x-ms-wm")+  , ("wma",       "audio/x-ms-wma")+  , ("wmd",       "application/x-ms-wmd")+  , ("wmf",       "application/x-msmetafile")+  , ("wml",       "text/vnd.wap.wml")+  , ("wmlc",      "application/vnd.wap.wmlc")+  , ("wmls",      "text/vnd.wap.wmlscript")+  , ("wmlsc",     "application/vnd.wap.wmlscriptc")+  , ("wmv",       "video/x-ms-wmv")+  , ("wmx",       "video/x-ms-wmx")+  , ("wmz",       "application/x-ms-wmz")+  , ("wpd",       "application/vnd.wordperfect")+  , ("wpl",       "application/vnd.ms-wpl")+  , ("wps",       "application/vnd.ms-works")+  , ("wqd",       "application/vnd.wqd")+  , ("wri",       "application/x-mswrite")+  , ("wrl",       "model/vrml")+  , ("wsdl",      "application/wsdl+xml")+  , ("wspolicy",  "application/wspolicy+xml")+  , ("wtb",       "application/vnd.webturbo")+  , ("wvx",       "video/x-ms-wvx")+  , ("x3d",       "application/vnd.hzn-3d-crossword")+  , ("xar",       "application/vnd.xara")+  , ("xbd",       "application/vnd.fujixerox.docuworks.binder")+  , ("xbm",       "image/x-xbitmap")+  , ("xdm",       "application/vnd.syncml.dm+xml")+  , ("xdp",       "application/vnd.adobe.xdp+xml")+  , ("xdw",       "application/vnd.fujixerox.docuworks")+  , ("xenc",      "application/xenc+xml")+  , ("xfdf",      "application/vnd.adobe.xfdf")+  , ("xfdl",      "application/vnd.xfdl")+  , ("xht",       "application/xhtml+xml")+  , ("xhtml",     "application/xhtml+xml")+  , ("xhvml",     "application/xv+xml")+  , ("xif",       "image/vnd.xiff")+  , ("xla",       "application/vnd.ms-excel")+  , ("xlc",       "application/vnd.ms-excel")+  , ("xlm",       "application/vnd.ms-excel")+  , ("xls",       "application/vnd.ms-excel")+  , ("xlt",       "application/vnd.ms-excel")+  , ("xlw",       "application/vnd.ms-excel")+  , ("xml",       "application/xml")+  , ("xo",        "application/vnd.olpc-sugar")+  , ("xop",       "application/xop+xml")+  , ("xpm",       "image/x-xpixmap")+  , ("xpr",       "application/vnd.is-xpr")+  , ("xps",       "application/vnd.ms-xpsdocument")+  , ("xpw",       "application/vnd.intercon.formnet")+  , ("xpx",       "application/vnd.intercon.formnet")+  , ("xsl",       "application/xml")+  , ("xslt",      "application/xslt+xml")+  , ("xsm",       "application/vnd.syncml+xml")+  , ("xspf",      "application/xspf+xml")+  , ("xul",       "application/vnd.mozilla.xul+xml")+  , ("xvm",       "application/xv+xml")+  , ("xvml",      "application/xv+xml")+  , ("xwd",       "image/x-xwindowdump")+  , ("xyz",       "chemical/x-xyz")+  , ("zaz",       "application/vnd.zzazz.deck+xml")+  , ("zip",       "application/zip")+  , ("zmm",       "application/vnd.handheld-entertainment+xml")+  , ("avi",       "video/x-msvideo")+  , ("movie",     "video/x-sgi-movie")+  , ("ice",       "x-conference/x-cooltalk")+  ]+

+ src/Network/Protocol/Uri.hs view

@@ -0,0 +1,93 @@+{- | See rfc2396 for more info. -}++{-# LANGUAGE TemplateHaskell #-}+module Network.Protocol.Uri (++  -- * URI datatype.++    Scheme+  , RegName+  , Port+  , Query+  , Fragment+  , Hash+  , UserInfo+  , PathSegment+  , Parameters++  , Domain (Domain)+  , IPv4 (IPv4)+  , Path (Path)+  , Host (Hostname, RegName, IP)+  , Authority (Authority)+  , Uri (Uri)++  -- * Accessing parts of URIs.++  , relative+  , scheme+  , userinfo+  , authority+  , host+  , domain+  , ipv4+  , regname+  , port+  , path+  , segments+  , query+  , fragment++  -- * More advanced labels and functions.++  , pathAndQuery+  , queryParams+  , params+  , extension++  , remap++  -- * Encoding/decoding URI encoded strings.++  , encode+  , decode+  , encoded++  -- * Creating empty URIs.++  , mkUri+  , mkScheme+  , mkPath+  , mkAuthority+  , mkQuery+  , mkFragment+  , mkUserinfo+  , mkHost+  , mkPort++  -- * Parsing URIs.++  , toUri+  , parseUri+  , parseAbsoluteUri+  , parseAuthority+  , parsePath+  , parseHost++  -- * Filename related utilities.++  , mimetype+  , normalize+  , jail+  , (/+)++  ) where++import Network.Protocol.Uri.Data+import Network.Protocol.Uri.Encode+import Network.Protocol.Uri.Parser+import Network.Protocol.Uri.Path+import Network.Protocol.Uri.Printer ()+import Network.Protocol.Uri.Query+import Network.Protocol.Uri.Remap+

+ src/Network/Protocol/Uri/Chars.hs view

@@ -0,0 +1,19 @@+module Network.Protocol.Uri.Chars+  ( unreserved+  , genDelims+  , subDelims+  ) where++import Data.Char++-- 2.3.  Unreserved Characters+unreserved :: Char -> Bool+unreserved c = isAlphaNum c || elem c "-._~"++-- 2.2.  Reserved Characters+genDelims :: Char -> Bool+genDelims = flip elem ":/?#[]@"++subDelims :: Char -> Bool+subDelims = flip elem "!$&'()*+,;="+

+ src/Network/Protocol/Uri/Data.hs view

@@ -0,0 +1,185 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Network.Protocol.Uri.Data where++import Prelude hiding ((.), id)+import Control.Category+import Data.Record.Label+import Data.Maybe+import Network.Protocol.Uri.Encode++type Scheme      = String+type RegName     = String+type Port        = Int+type Query       = String+type Fragment    = String+type Hash        = String+type UserInfo    = String+type PathSegment = String++data IPv4 = IPv4 Int Int Int Int+  deriving (Eq, Ord)++data Domain = Domain { __parts :: [String] }+  deriving (Eq, Ord)++data Host =+    Hostname { __domain  :: Domain }+  | RegName  { __regname :: RegName }+  | IP       { __ipv4    :: IPv4   }+--  | IPv6     { __ipv6    :: IPv6   }+  deriving (Eq, Ord)++data Authority = Authority+  { __userinfo :: UserInfo+  , __host     :: Host+  , __port     :: Maybe Port+  }+  deriving (Eq, Ord)++data Path = Path { __segments :: [PathSegment] }+  deriving (Eq, Ord)++data Uri = Uri+  { _relative  :: Bool+  , _scheme    :: Scheme+  , _authority :: Authority+  , __path     :: Path+  , __query    :: Query+  , __fragment :: Fragment+  }+  deriving (Eq, Ord)++$(mkLabels [''Domain, ''Path, ''Host, ''Authority, ''Uri])++_parts    :: Domain :-> [String]+_domain   :: Host :-> Domain+_ipv4     :: Host :-> IPv4+_regname  :: Host :-> String+_host     :: Authority :-> Host+_port     :: Authority :-> Maybe Port+_userinfo :: Authority :-> UserInfo+_segments :: Path :-> [PathSegment]+_path     :: Uri :-> Path++-- | Access raw (URI-encoded) query.++_query :: Uri :-> Query++-- | Access authority part of the URI.++authority :: Uri :-> Authority++-- | Access domain part of the URI, returns `Nothing' when the host is a+-- regname or IP-address.++domain :: Uri :-> Maybe Domain+domain = (f <-> Hostname . fromJust) `iso` (_host . authority)+  where+    f (Hostname d) = Just d+    f _            = Nothing++-- | Access regname part of the URI, returns `Nothing' when the host is a+-- domain or IP-address.++regname :: Uri :-> Maybe RegName+regname = (f <-> RegName . fromJust) `iso` (_host . authority)+  where+    f (RegName r) = Just r+    f _           = Nothing++-- | Access IPv4-address part of the URI, returns `Nothing' when the host is a+-- domain or regname.++ipv4 :: Uri :-> Maybe IPv4+ipv4 = (f <-> IP . fromJust) `iso` (_host . authority)+  where+    f (IP i) = Just i+    f _      = Nothing++-- | Access raw (URI-encoded) fragment.++_fragment :: Uri :-> Fragment++-- | Access the port number part of the URI when available.++port :: Uri :-> Maybe Port+port = _port . authority++-- | Access the query part of the URI, the part that follows the ?. The query+-- will be properly decoded when reading and encoded when writing.++query :: Uri :-> Query+query = encoded `iso` _query++-- | Access the fragment part of the URI, the part that follows the #. The+-- fragment will be properly decoded when reading and encoded when writing.++fragment :: Uri :-> Fragment+fragment = encoded `iso` _fragment++-- | Is a URI relative?++relative :: Uri :-> Bool++-- | Access the scheme part of the URI. A scheme is probably the protocol+-- indicator like /http/, /ftp/, etc.++scheme :: Uri :-> Scheme++-- | Access the path part of the URI as a list of path segments. The segments+-- will still be URI-encoded.++segments :: Uri :-> [PathSegment]+segments = _segments . _path++-- | Access the userinfo part of the URI. The userinfo contains an optional+-- username and password or some other credentials.++userinfo :: Uri :-> String+userinfo = _userinfo . authority++-- | Constructors for making empty URI.++mkUri :: Uri+mkUri = Uri False mkScheme mkAuthority mkPath mkQuery mkFragment++-- | Constructors for making empty `Scheme`.++mkScheme :: Scheme+mkScheme = ""++-- | Constructors for making empty `Path`.++mkPath :: Path+mkPath = Path []++-- | Constructors for making empty `Authority`.++mkAuthority :: Authority+mkAuthority = Authority "" mkHost mkPort++-- | Constructors for making empty `Query`.++mkQuery :: Query+mkQuery = ""++-- | Constructors for making empty `Fragment`.++mkFragment :: Fragment+mkFragment = ""++-- | Constructors for making empty `UserInfo`.++mkUserinfo :: UserInfo+mkUserinfo = ""++-- | Constructors for making empty `Host`.++mkHost :: Host+mkHost = Hostname (Domain [])++-- | Constructors for making empty `Port`.++mkPort :: Maybe Port+mkPort = Nothing+

+ src/Network/Protocol/Uri/Encode.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Uri.Encode where++import Data.Bits+import Data.Char+import Data.Maybe+import Data.Record.Label+import Network.Protocol.Uri.Chars+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as U++-- | URI encode a string.++encode :: String -> String+encode = concatMap encodeChr+  where+    encodeChr c+      | unreserved c || genDelims c || subDelims c = [c]+      | otherwise = '%' :+          intToDigit (shiftR (ord c) 4) :+          intToDigit ((ord c) .&. 0x0F) : []++-- | URI decode a string.++decode :: String -> String+decode = U.toString . B.pack . map (fromIntegral . ord) . dec+  where+    dec [] = []+    dec ('%':d:e:ds) | isHexDigit d && isHexDigit e = (chr $ digs d * 16 + digs e) : dec ds +      where digs a = fromJust $ lookup (toLower a) $ zip "0123456789abcdef" [0..]+    dec (d:ds) = d : dec ds++-- | Decoding and encoding as a label.++encoded :: String :<->: String+encoded = decode <-> encode+

+ src/Network/Protocol/Uri/Parser.hs view

@@ -0,0 +1,288 @@+{-# LANGUAGE+    StandaloneDeriving+  , TypeOperators+  , FlexibleContexts+  , FlexibleInstances+  #-}+module Network.Protocol.Uri.Parser where++import Control.Applicative hiding (empty)+import Control.Category+import Data.Char+import Control.Monad+import Control.Applicative+import Data.List +import Data.Maybe+import Data.Record.Label+import Network.Protocol.Uri.Data+import Network.Protocol.Uri.Encode+import Network.Protocol.Uri.Printer ()+import Network.Protocol.Uri.Query+import Prelude hiding ((.), id, mod)+import Safe+import Text.ParserCombinators.Parsec hiding (many, (<|>))++instance Applicative (GenParser Char st) where+  pure = return+  (<*>) = ap++instance Alternative (GenParser Char st) where+  empty = mzero+  (<|>) = mplus++-- | Access the host part of the URI.++host :: Uri :-> String+host = (show <-> either (const mkHost) id . parseHost) `iso` (_host . authority)++-- | Access the path part of the URI. The query will be properly decoded when+-- reading and encoded when writing.++path :: Uri :-> FilePath+path = (decode . show <-> either (const mkPath) id . parsePath . encode) `iso` _path++-- | Access the path and query parts of the URI as a single string. The string+-- will will be properly decoded when reading and encoded when writing.++pathAndQuery :: Uri :-> String+pathAndQuery = values "?" `osi` Label ((\p q -> [p, q]) <$> idx 0 `for` path <*> idx 1 `for` query)+  where idx = flip (atDef "")++-- | Parse string into a URI and ignore all failures by returning an empty URI+-- when parsing fails. Can be quite useful in situations that parse errors are+-- unlikely.++toUri :: String -> Uri+toUri = either (const mkUri) id . parseUri++-- | Parse string into a URI.++parseUri :: String -> Either ParseError Uri+parseUri = parse pUriReference ""++-- | Parse string into a URI and only accept absolute URIs.++parseAbsoluteUri :: String -> Either ParseError Uri+parseAbsoluteUri = parse pAbsoluteUri ""++-- | Parse string into an authority.++parseAuthority :: String -> Either ParseError Authority+parseAuthority = parse pAuthority ""++-- | Parse string into a path.++parsePath :: String -> Either ParseError Path+parsePath = parse pPath ""++-- | Parse string into a host.++parseHost :: String -> Either ParseError Host+parseHost = parse pHost ""++-- D.2.  Modifications++pAlpha, pDigit, pAlphanum :: CharParser st Char+pAlpha    = letter+pDigit    = digit+pAlphanum = alphaNum++-- 2.3.  Unreserved Characters++pUnreserved :: GenParser Char st Char+pUnreserved  = pAlphanum <|> oneOf "-._~"++pReserved :: GenParser Char st Char+pReserved  = pGenDelims <|> pSubDelims++pGenDelims :: CharParser st Char+pGenDelims = oneOf ":/?#[]@"++pSubDelims :: CharParser st Char+pSubDelims = oneOf "!$&'()*+,;="++-- 2.1.  Percent-Encoding++pPctEncoded :: GenParser Char st String+pPctEncoded = (:) <$> char '%' <*> pHex++pHex :: GenParser Char st String+pHex = (\a b -> a:b:[])+    <$> hexDigit+    <*> hexDigit++-- 3.  Syntax Components++-- With the hier-part integrated.++pUri :: GenParser Char st Uri+pUri = (\a (b,c) d e -> Uri False a b c d e)+  <$> (pScheme <* string ":")+  <*> (q <|> p)+  <*> option "" (string "?" *> pQuery)+  <*> option "" (string "#" *> pFragment)+  where+    q = (,) <$> (string "//" *> pAuthority) <*> pPathAbempty+    p = ((,) mkAuthority) <$> (pPathAbsolute <|> pPathRootless {-<|> pPathEmpty-})++-- 3.1.  Scheme++pScheme :: GenParser Char st String+pScheme = (:) <$> pAlpha <*> many (pAlphanum <|> oneOf "+_.")++-- 3.2.  Authority++pAuthority :: GenParser Char st Authority+pAuthority = Authority+  <$> option mkUserinfo (try (pUserinfo <* string "@"))+  <*> pHost+  <*> option Nothing (string ":" *> pPort)++-- 3.2.1.  User Information++pUserinfo :: GenParser Char st String+pUserinfo = concat <$> many (+      (pure <$> pUnreserved)+  <|> (         pPctEncoded)+  <|> (pure <$> pSubDelims)+  <|> (pure <$> oneOf ":")+  )++-- 3.2.2.  Host++pHost :: GenParser Char st Host+pHost = diff <$> pRegName -- <|> RegName <$> pRegName+  where+    diff  a = either (const (RegName a)) sep (parse pHostname "" a)+    sep   a = if hst a then Hostname (Domain a) else ipreg a+    ipreg a = if ip a then IP (toIP a) else RegName (intercalate "." a)+    hst     = not . all isDigit . headDef "" . dropWhile null . reverse+    ip    a = length a == 4 && length (mapMaybe (either (const Nothing) Just . parse pDecOctet "") a) == 4+    toIP [a, b, c, d] = IPv4 (read a) (read b) (read c) (read d)+    toIP _            = IPv4 0 0 0 0++{-+pfff, ipv6 is sooo not gonna make it..++pIPLiteral = "[" ( IPv6address <|> IPvFuture  ) "]"++pIPvFuture = "v" 1*HEXDIG "." 1*( unreserved <|> subDelims <|> ":" )++pIPv6address =+                                 6( h16 ":" ) ls32+  <|>                       "::" 5( h16 ":" ) ls32+  <|> [               h16 ] "::" 4( h16 ":" ) ls32+  <|> [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+  <|> [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+  <|> [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32+  <|> [ *4( h16 ":" ) h16 ] "::"              ls32+  <|> [ *5( h16 ":" ) h16 ] "::"              h16+  <|> [ *6( h16 ":" ) h16 ] "::"++pH16           = 1*4HEXDIG+pLs32          = ( h16 ":" h16 ) <|> IPv4address+-}++pIPv4address :: GenParser Char st [Int]+pIPv4address = (:) <$> pDecOctet <*> (count 3 $ char '.' *> pDecOctet)++pDecOctet :: GenParser Char st Int+pDecOctet = read <$> choice [+    try ((\a b c -> [a,b,c]) <$> char '2' <*> char '5'      <*> oneOf "012345")+  , try ((\a b c -> [a,b,c]) <$> char '2' <*> oneOf "01234" <*> digit)+  , try ((\a b c -> [a,b,c]) <$> char '1' <*> digit         <*> digit)+  , try ((\a b   -> [a,b])   <$>              digit         <*> digit)+  ,     (pure                <$>                                digit)+  ]++pRegName :: GenParser Char st String+pRegName = concat <$> many1 (+      (pure <$> pUnreserved)+  <|>           pPctEncoded+  <|> (pure <$> pSubDelims))++-- Not actually part of the rfc3986, but comptability with the rfc2396.+-- This information can be useful, so why throw away.++pHostname :: GenParser Char st [String]+pHostname = sepBy (option "" pDomainlabel) (string ".")++pDomainlabel :: GenParser Char st String+pDomainlabel = intercalate "-" <$> sepBy1 (some pAlphanum) (string "-")++-- 3.2.3.  Port++pPort :: GenParser Char st (Maybe Port)+pPort = readMay <$> some pDigit++-- 3.4.  Query++pQuery :: GenParser Char st String+pQuery = concat <$> many (pPchar <|> pure <$> oneOf "/?")++-- 3.5.  Fragment++pFragment :: GenParser Char st String+pFragment = concat <$> many (pPchar <|> pure <$> oneOf "/?" )++-- 3.3.  Path++pPath, pPathAbempty, pPathAbsolute, pPathNoscheme, pPathRootless, pPathEmpty :: GenParser Char st Path++pPath =+      try pPathAbsolute -- begins with "/" but not "//"+  <|> try pPathNoscheme -- begins with a nonColon segment+  <|> try pPathRootless -- begins with a segment+  <|> pPathEmpty        -- zero characters++pPathAbempty  = Path . ("":) <$> _pSlashSegments+pPathAbsolute = (char '/' *>) $ Path . ("":) <$> (option [] $ (:) <$> pSegmentNz <*> _pSlashSegments)+pPathNoscheme = Path <$> ((:) <$> pSegmentNzNc <*> _pSlashSegments)+pPathRootless = Path <$> ((:) <$> pSegmentNz    <*> _pSlashSegments)+pPathEmpty    = Path [] <$ string ""++pSegment, pSegmentNz, pSegmentNzNc :: GenParser Char st String+pSegment     = concat <$> many pPchar+pSegmentNz   = concat <$> some pPchar+pSegmentNzNc = concat <$> some (+      (pure <$> pUnreserved)+  <|>           pPctEncoded+  <|> (pure <$> pSubDelims)+  <|> (pure <$> oneOf "@" ))++_pSlashSegments :: GenParser Char st [PathSegment]+_pSlashSegments = (many $ (:) <$> char '/' *> pSegment)+++pPchar :: GenParser Char st String+pPchar = choice+  [ pure <$> pUnreserved+  , pPctEncoded+  , pure <$> pSubDelims+  , pure <$> oneOf ":@"+  ]++-- 4.1.  URI Reference++pUriReference :: GenParser Char st Uri+pUriReference = try pAbsoluteUri <|> pRelativeRef++-- 4.2.  Relative Reference++-- With the relative-part integrated.++pRelativeRef :: GenParser Char st Uri+pRelativeRef = ($)+  <$> (try pRelativePart+  <|> ((Uri True mkScheme mkAuthority)+  <$> (pPathAbsolute <|> pPathRootless <|> pPathEmpty)))+  <*> option "" (string "?" *> pQuery)+  <*> option "" (string "#" *> pFragment)++pRelativePart :: GenParser Char st (Query -> Fragment -> Uri)+pRelativePart = Uri True mkScheme <$> (string "//" *> pAuthority) <*> pPathAbempty++-- 4.3.  Absolute URI++pAbsoluteUri :: GenParser Char st Uri+pAbsoluteUri = pUri

+ src/Network/Protocol/Uri/Path.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Uri.Path where++import Data.List+import Network.Protocol.Mime+import Data.Record.Label++{- | Label to access the extension of a filename. -}++extension :: FilePath :-> Maybe String+extension = label getExt setExt+  where+    splt     p = (\(a,b) -> (reverse a, reverse b)) $ break (=='.') $ reverse p+    isExt e  p = '/' `elem` e || not ('.' `elem` p)+    getExt   p = let (u, v) = splt p in+                 if isExt u v then Nothing else Just u+    setExt e p = let (u, v) = splt p in+                 (if isExt u v then p else init v) ++ maybe "" ('.':) e++{- |+Try to guess the correct mime type for the input file based on the file+extension.+-}++mimetype :: FilePath -> Maybe String+mimetype p = get extension p >>= mime++{- |+Normalize a path by removing or merging all dot or dot-dot segments and double+slashes. +-}++-- Todo: is this windows-safe?  is it really secure?++normalize :: FilePath -> FilePath+normalize p  = norm_rev (reverse p)+  where+    norm_rev ('/':t) = start_dir 0 "/" t+    norm_rev (    t) = start_dir 0 ""  t++    start_dir n q (".."           ) = rest_dir   n    q  ""+    start_dir n q ('/':t          ) = start_dir  n    q  t+    start_dir n q ('.':'/':t      ) = start_dir  n    q  t+    start_dir n q ('.':'.':'/': t ) = start_dir (n+1) q  t+    start_dir n q (t              ) = rest_dir   n    q  t++    rest_dir  n q  ""+        | n > 0      = foldr (++) q (replicate n "../")+        | null q     = "/"+        | otherwise  = q+    rest_dir  0 q ('/':t ) = start_dir  0   ('/':q)  t+    rest_dir  n q ('/':t ) = start_dir (n-1)     q   t+    rest_dir  0 q (h:t   ) = rest_dir   0   (  h:q)  t+    rest_dir  n q (_:t   ) = rest_dir   n        q   t++{- | Jail a filepath within a jail directory. -}++jail+  :: FilePath         -- ^ Jail directory.+  -> FilePath         -- ^ Filename to jail.+  -> Maybe FilePath+jail jailDir p =+  let nj = normalize jailDir+      np = normalize p in+  if nj `isPrefixOf` np -- && not (".." `isPrefixOf` np)+    then Just np+    else Nothing++{- | Concatenate and normalize two filepaths. -}++(/+) :: FilePath -> FilePath -> FilePath+a /+ b = normalize (a ++ "/" ++ b)+

+ src/Network/Protocol/Uri/Printer.hs view

@@ -0,0 +1,47 @@+module Network.Protocol.Uri.Printer where++import Network.Protocol.Uri.Data++instance Show Path where+  showsPrec _ (Path ("":xs)) = sc '/' . shows (Path xs)+  showsPrec _ (Path xs)      = intersperseS (sc '/') (map ss xs)++instance Show IPv4 where+  showsPrec _ (IPv4 a b c d) = intersperseS (sc '.') (map shows [a, b, c, d])++instance Show Domain where+  showsPrec _ (Domain d) = intersperseS (sc '.') (map ss d)++instance Show Host where+  showsPrec _ (Hostname d) = shows d+  showsPrec _ (IP i)       = shows i +  showsPrec _ (RegName r)  = ss r++instance Show Authority where+  showsPrec _ (Authority u h p) =+    let u' = if null u then id else ss u . ss "@"+        p' = maybe id (\s -> sc ':' . shows s) p+    in u' . shows h . p'++instance Show Uri where+  showsPrec _ (Uri _ s a p q f) =+    let s' = if null s then id else ss s . sc ':'+        a' = show a+        p' = shows p+        q' = if null q then id else sc '?' . ss q+        f' = if null f then id else sc '#' . ss f+        t' = if null a' then id else ss "//"+    in s' . t' . ss a' . p' . q' . f'++ss :: String -> ShowS+ss = showString++sc :: Char -> ShowS+sc = showChar++-- | ShowS version of intersperse.++intersperseS :: ShowS -> [ShowS] -> ShowS+intersperseS _ []     = id+intersperseS s (x:xs) = foldl (\a b -> a.s.b) x xs+

+ src/Network/Protocol/Uri/Query.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Uri.Query where++import Prelude hiding ((.), id)+import Control.Category+import Data.List+import Data.List.Split +import Data.Record.Label+import Network.Protocol.Uri.Data+import Network.Protocol.Uri.Encode++type Parameters = [(String, Maybe String)]++-- | Fetch the query parameters form a URI.++queryParams :: Uri :-> Parameters+queryParams = params `iso` _query++-- | Generic lens to parse/print a string as query parameters.++params :: String :<->: Parameters+params = keyValues "&" "=" . (from <-> to) . encoded+  where from = intercalate " " . splitOn "+"+        to   = intercalate "+" . splitOn " "++-- | Generic label for accessing key value pairs encoded in a string.++keyValues :: String -> String -> String :<->: Parameters+keyValues sep eqs = parser <-> printer+  where parser =+            filter (\(a, b) -> not (null a) || b /= Nothing && b /= Just "")+          . map (f . splitOn eqs)+          . concat+          . map (splitOn sep)+          . lines+          where f []     = ("", Nothing)+                f [x]    = (trim x, Nothing)+                f (x:xs) = (trim x, Just . trim $ intercalate eqs xs)+        printer = intercalate sep . map (\(a, b) -> a ++ maybe "" (eqs ++) b)++-- | Generic label for accessing lists of values encoded in a string.++values :: String -> String :<->: [String]+values sep = parser <-> printer+  where parser = filter (not . null) . concat . map (map trim . splitOn sep) . lines+        printer = intercalate sep++-- Helper to trim all heading and trailing whitespace.++trim :: String -> String+trim = rev (dropWhile (`elem` " \t\n\r"))+  where rev f = reverse . f . reverse . f+

+ src/Network/Protocol/Uri/Remap.hs view

@@ -0,0 +1,45 @@+module Network.Protocol.Uri.Remap where++import Control.Category+import Data.List +import Data.Record.Label+import Network.Protocol.Uri.Data+import Prelude hiding ((.), id, mod)++-- | Map one URI to another using a URI mapping scheme. A URI mapping scheme is+-- simply a pair of URIs of which only the host part, port number and path will+-- be taken into account when mapping.++remap :: (Uri, Uri) -> Uri -> Maybe Uri+remap (f, t) u =+  let+    ftu = [f, t, u]+    hst = _host . authority+    [h0, h1, h2] = map (get hst)      ftu+    [p0, p1, p2] = map (get port)     ftu+    [s0, s1, s2] = map (get segments) ftu+  in case+     ( remapHost h0 h1 h2+     , remapPort p0 p1 p2+     , remapPath s0 s1 s2+     ) of+    (Just h, Just p, Just s)+      -> Just (set hst h . set port p . set segments s $ u)+    _ -> Nothing+  where+  remapHost (Hostname (Domain a))+            (Hostname (Domain b))   (Hostname (Domain c))          = fmap (Hostname . Domain . (++b)) (a `stripPrefix` reverse c)+  remapHost (Hostname (Domain a)) b (Hostname (Domain c)) | a == c = Just b+  remapHost (RegName a)           b (RegName c)           | a == c = Just b+  remapHost (IP a)                b (IP c)                | a == c = Just b+  remapHost _                     _ _                              = Nothing+  remapPath xs ys zs = fmap (ys++) (xs `stripPrefix` zs)+  remapPort x y z = if x == z then Just y else Nothing++-- from = toUri "http://myhost:8080/ggl"+-- to   = toUri "http://google.com/gapp"+-- testRemap =+--   do let x = remap from to (toUri "http://images.myhost:8080/ggl/search?q=aapjes")+--      print x++