diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#! /usr/bin/env runhaskell + +>import Distribution.Simple + +>main = defaultMain + diff --git a/salvia-protocol.cabal b/salvia-protocol.cabal new file mode 100644 --- /dev/null +++ b/salvia-protocol.cabal @@ -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 + diff --git a/src/Network/Protocol/Cookie.hs b/src/Network/Protocol/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Cookie.hs @@ -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 + diff --git a/src/Network/Protocol/Http.hs b/src/Network/Protocol/Http.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http.hs @@ -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 + diff --git a/src/Network/Protocol/Http/Data.hs b/src/Network/Protocol/Http/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Data.hs @@ -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 + diff --git a/src/Network/Protocol/Http/Headers.hs b/src/Network/Protocol/Http/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Headers.hs @@ -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" + diff --git a/src/Network/Protocol/Http/Parser.hs b/src/Network/Protocol/Http/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Parser.hs @@ -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) + diff --git a/src/Network/Protocol/Http/Printer.hs b/src/Network/Protocol/Http/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Printer.hs @@ -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 + diff --git a/src/Network/Protocol/Http/Status.hs b/src/Network/Protocol/Http/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Status.hs @@ -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 + diff --git a/src/Network/Protocol/Mime.hs b/src/Network/Protocol/Mime.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Mime.hs @@ -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") + ] + diff --git a/src/Network/Protocol/Uri.hs b/src/Network/Protocol/Uri.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Chars.hs b/src/Network/Protocol/Uri/Chars.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Chars.hs @@ -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 "!$&'()*+,;=" + diff --git a/src/Network/Protocol/Uri/Data.hs b/src/Network/Protocol/Uri/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Data.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Encode.hs b/src/Network/Protocol/Uri/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Encode.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Parser.hs b/src/Network/Protocol/Uri/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Parser.hs @@ -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 diff --git a/src/Network/Protocol/Uri/Path.hs b/src/Network/Protocol/Uri/Path.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Path.hs @@ -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) + diff --git a/src/Network/Protocol/Uri/Printer.hs b/src/Network/Protocol/Uri/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Printer.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Query.hs b/src/Network/Protocol/Uri/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Query.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Remap.hs b/src/Network/Protocol/Uri/Remap.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Remap.hs @@ -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 + +