diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Web/Routes.hs b/Web/Routes.hs new file mode 100644 --- /dev/null +++ b/Web/Routes.hs @@ -0,0 +1,15 @@ +module Web.Routes + ( module Web.Routes.Base + , module Web.Routes.PathInfo + , module Web.Routes.QuickCheck + , module Web.Routes.RouteT + , module Web.Routes.Site + ) + where + +import Web.Routes.Base +import Web.Routes.PathInfo +import Web.Routes.QuickCheck +import Web.Routes.RouteT +import Web.Routes.Site + diff --git a/Web/Routes/Base.hs b/Web/Routes/Base.hs new file mode 100644 --- /dev/null +++ b/Web/Routes/Base.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies, PackageImports, FlexibleContexts, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Web.Routes.Base +-- Copyright : (c) 2010 Jeremy Shaw +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : partners@seereason.com +-- Stability : experimental +-- Portability : portable +-- +-- Conversions between raw pathinfos and decoded path segments. +----------------------------------------------------------------------------- +module Web.Routes.Base + ( encodePathInfo + , decodePathInfo + ) where + +import Codec.Binary.UTF8.String (encodeString, decodeString) +import Data.List (intercalate) +import Network.URI + +{- + +From RFC1738 - 3.3 + + The HTTP URL scheme is used to designate Internet resources + accessible using HTTP (HyperText Transfer Protocol). + + The HTTP protocol is specified elsewhere. This specification only + describes the syntax of HTTP URLs. + + An HTTP URL takes the form: + + http://:/? + + where and are as described in Section 3.1. If : + is omitted, the port defaults to 80. No user name or password is + allowed. is an HTTP selector, and is a query + string. The is optional, as is the and its + preceding "?". If neither nor is present, the "/" + may also be omitted. + + Within the and components, "/", ";", "?" are + reserved. The "/" character may be used within HTTP to designate a + hierarchical structure. + +From FRC1808 - 2.1 URL Syntactic Components + + The URL syntax is dependent upon the scheme. Some schemes use + reserved characters like "?" and ";" to indicate special components, + while others just consider them to be part of the path. However, + there is enough uniformity in the use of URLs to allow a parser to + resolve relative URLs based upon a single, generic-RL syntax. This + generic-RL syntax consists of six components: + + :///;?# + + URL = ( absoluteURL | relativeURL ) [ "#" fragment ] + + absoluteURL = generic-RL | ( scheme ":" *( uchar | reserved ) ) + + generic-RL = scheme ":" relativeURL + + relativeURL = net_path | abs_path | rel_path + + net_path = "//" net_loc [ abs_path ] + abs_path = "/" rel_path + rel_path = [ path ] [ ";" params ] [ "?" query ] + + path = fsegment *( "/" segment ) + fsegment = 1*pchar + segment = *pchar + + params = param *( ";" param ) + param = *( pchar | "/" ) + + pchar = uchar | ":" | "@" | "&" | "=" + uchar = unreserved | escape + unreserved = alpha | digit | safe | extra + +From RFC2396 - 3.3 + + path_segments = segment *( "/" segment ) + segment = *pchar *( ";" param ) + param = *pchar + + pchar = unreserved | escaped | + ":" | "@" | "&" | "=" | "+" | "$" | "," + + The path may consist of a sequence of path segments separated by a + single slash "/" character. Within a path segment, the characters + "/", ";", "=", and "?" are reserved. Each path segment may include a + sequence of parameters, indicated by the semicolon ";" character. + The parameters are not significant to the parsing of relative + references. + +From RFC3986 - 3.3 + + The path component contains data, usually organized in hierarchical + form, that, along with data in the non-hierarchical query component + (Section 3.4), serves to identify a resource within the scope of the + URI's scheme and naming authority (if any). The path is terminated + by the first question mark ("?") or number sign ("#") character, or + by the end of the URI. + + If a URI contains an authority component, then the path component + must either be empty or begin with a slash ("/") character. If a URI + does not contain an authority component, then the path cannot begin + with two slash characters ("//"). In addition, a URI reference + (Section 4.1) may be a relative-path reference, in which case the + first path segment cannot contain a colon (":") character. The ABNF + requires five separate rules to disambiguate these cases, only one of + which will match the path substring within a given URI reference. We + use the generic term "path component" to describe the URI substring + matched by the parser to one of these rules. + + path = path-abempty ; begins with "/" or is empty + / path-absolute ; begins with "/" but not "//" + / path-noscheme ; begins with a non-colon segment + / path-rootless ; begins with a segment + / path-empty ; zero characters + + path-abempty = *( "/" segment ) + path-absolute = "/" [ segment-nz *( "/" segment ) ] + path-noscheme = segment-nz-nc *( "/" segment ) + path-rootless = segment-nz *( "/" segment ) + path-empty = 0 + + segment = *pchar + segment-nz = 1*pchar + segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) + ; non-zero-length segment without any colon ":" + + pchar = unreserved / pct-encoded / sub-delims / ":" / "@" + + A path consists of a sequence of path segments separated by a slash + ("/") character. A path is always defined for a URI, though the + defined path may be empty (zero length). Use of the slash character + to indicate hierarchy is only required when a URI will be used as the + context for relative references. For example, the URI + has a path of "fred@example.com", whereas + the URI has an empty path. + + The path segments "." and "..", also known as dot-segments, are + defined for relative reference within the path name hierarchy. They + are intended for use at the beginning of a relative-path reference + (Section 4.2) to indicate relative position within the hierarchical + tree of names. This is similar to their role within some operating + systems' file directory structures to indicate the current directory + and parent directory, respectively. However, unlike in a file + system, these dot-segments are only interpreted within the URI path + hierarchy and are removed as part of the resolution process (Section + 5.2). + + Aside from dot-segments in hierarchical paths, a path segment is + considered opaque by the generic syntax. URI producing applications + often use the reserved characters allowed in a segment to delimit + scheme-specific or dereference-handler-specific subcomponents. For + example, the semicolon (";") and equals ("=") reserved characters are + often used to delimit parameters and parameter values applicable to + that segment. The comma (",") reserved character is often used for + similar purposes. For example, one URI producer might use a segment + such as "name;v=1.1" to indicate a reference to version 1.1 of + "name", whereas another might use a segment such as "name,1.1" to + indicate the same. Parameter types may be defined by scheme-specific + semantics, but in most cases the syntax of a parameter is specific to + the implementation of the URI's dereferencing algorithm. +-} + + +{- + +Reserved characters: + +If a character is unreserved, then you can included it as the literal +character, or percent encode it, and it does not change its +meaning. The two urls will be equal to each other. + +Some characters are explicitly reserved in different url schemes. For +example the '/' character in a path component has special meaning, and +therefore any occurance of '/' must be escaped unless it is being used +for it's reserved purposed. + +The spec also provides a list of characters than can be reserved in +specific url spec. For example, a url producer can choose to use , as +a reserved character. However, it is not obligated to use , as a +reserved character. + +From RFC3986 - 2.2 + + Characters in the "reserved" set are not reserved in all contexts. + The set of characters actually reserved within any given URI + component is defined by that component. In general, a character is + reserved if the semantics of the URI changes if the character is + replaced with its escaped US-ASCII encoding. + +Some choices we made: + +The presence of ; and params in a path segment is handled differently +in the different RFCs. It does some clear, though that ; is supposed +to indicate the start of parameters. Hence we should escape ; so that +if it appears in a url it does not treated as parameters when it was +not meant to be. At present we offer no way for a user who actually +wants to add parameters. That would probably be done path extending +the encodePathInfo to be more like: + + encodePathInfo :: [(String, [Param])] -> String + +The spec also forbids a path from starting with // if the scheme has +no authority. This library is currently only intended to be used with +the http scheme, so we do not have to worry about that rule, since the +http scheme does have an authority. + +-} + +{-| +Encodes a list of path segments into a valid URL fragment. + +This function takes the following three steps: + +* UTF-8 encodes the characters. + +* Performs percent encoding on all unreserved characters, as well as \:\@\=\+\$, + +* Intercalates with a slash. + +For example: + +> encodePathInfo [\"foo\", \"bar\", \"baz\"] + +\"foo\/bar\/baz\" + +> encodePathInfo [\"foo bar\", \"baz\/bin\"] + +\"foo\%20bar\/baz\%2Fbin\" + +> encodePathInfo [\"שלום\"] + +\"%D7%A9%D7%9C%D7%95%D7%9D\" + +-} +encodePathInfo :: [String] -> String +encodePathInfo = + map encodeString `o` -- utf-8 encode the data characters in path components (we have not added any delimiters yet) + map (escapeURIString (\c -> isUnreserved c || c `elem` ":@&=+$,")) `o` -- percent encode the characters + map (\str -> case str of "." -> "%2E" ; ".." -> "%2E%2E" ; _ -> str) `o` -- encode . and .. + intercalate "/" -- add in the delimiters + where + -- reverse composition + o :: (a -> b) -> (b -> c) -> a -> c + o = flip (.) + +{-| +Performs the inverse operation of 'encodePathInfo'. + +In particular, this function: + +* Splits a string at each occurence of a forward slash. + +* Percent-decodes the individual pieces. + +* UTF-8 decodes the resulting data. + +This utilizes 'decodeString' from the utf8-string library, and thus all UTF-8 +decoding errors are handled as per that library. + +In general, you will want to strip the leading slash from a pathinfo before +passing it to this function. For example: + +> decodePathInfo \"\" + +\[\] + +> decodePathInfo \"\/\" + +[\"\"] + +-} +decodePathInfo :: String -> [String] +decodePathInfo = + splitPaths `o` -- split path on delimiters + map unEscapeString `o` -- decode any percent encoded characters + map decodeString -- decode octets + where + -- reverse composition + o :: (a -> b) -> (b -> c) -> a -> c + o = flip (.) + +splitPaths :: String -> [String] +splitPaths "" = [] +splitPaths s = + let (x, y) = break (== '/') $ drop1Slash s + in x : splitPaths y + where + drop1Slash ('/':x) = x + drop1Slash x = x diff --git a/Web/Routes/PathInfo.hs b/Web/Routes/PathInfo.hs new file mode 100644 --- /dev/null +++ b/Web/Routes/PathInfo.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module Web.Routes.PathInfo where + +import Control.Applicative (pure, (*>),(<*>)) +import Control.Monad (msum) +import Data.List (stripPrefix, tails) +import Data.Maybe (fromJust) +import Text.ParserCombinators.Parsec.Prim ((), GenParser, getInput, setInput, pzero) +import Text.ParserCombinators.Parsec.Error (ParseError, errorPos, errorMessages, showErrorMessages) +import Text.ParserCombinators.Parsec.Pos (incSourceLine, sourceName, sourceLine, sourceColumn) +import Text.ParserCombinators.Parsec.Prim (getPosition, token, parse, many) + +import Web.Routes.Base (decodePathInfo, encodePathInfo) +import Web.Routes.Site (Site(..)) + +-- this is not very efficient. Among other things, we need only consider the last 'n' characters of x where n == length y. +stripOverlap :: (Eq a) => [a] -> [a] -> [a] +stripOverlap x y = fromJust $ msum $ [ stripPrefix p y | p <- tails x] + +type URLParser a = GenParser String () a + +pToken :: tok -> (String -> Maybe a) -> URLParser a +pToken msg f = do pos <- getPosition + token id (const $ incSourceLine pos 1) f + +segment :: String -> URLParser String +segment x = (pToken (const x) (\y -> if x == y then Just x else Nothing)) x + +anySegment :: URLParser String +anySegment = pToken (const "any string") Just + +patternParse :: ([String] -> Either String a) -> URLParser a +patternParse p = + do segs <- getInput + case p segs of + (Right r) -> + do setInput [] + return r + (Left err) -> fail err + +parseSegments :: URLParser a -> [String] -> Either String a +parseSegments p segments = + case parse p (show segments) segments of + (Left e) -> Left (showParseError e) + (Right r) -> Right r + +{- + +This requires parsec 3, can't figure out how to do it in parsec 2 yet. + +p2u :: Parser a -> URLParser a +p2u p = + mkPT $ \state@(State sInput sPos sUser) -> + case sInput of + (s:ss) -> + do r <- runParsecT p (State s sPos sUser) + return (fmap (fmap (fixReply ss)) r) + + where + fixReply :: [String] -> (Reply String u a) -> (Reply [String] u a) + fixReply _ (Error err) = (Error err) + fixReply ss (Ok a (State "" sPos sUser) e) = (Ok a (State ss sPos sUser) e) + fixReply ss (Ok a (State s sPos sUser) e) = (Ok a (State (s:ss) sPos sUser) e) +-} + +{- +p2u :: Parser a -> URLParser a +p2u p = + do (State sInput sPos sUser) <- getParserState + case sInput of + (s:ss) -> let r = runParser p () "" s + in case r of + (Left e) -> return e +-} + +{- + mkPT $ \state@(State sInput sPos sUser) -> + case sInput of + (s:ss) -> + do r <- runParsecT p (State s sPos sUser) + return (fmap (fmap (fixReply ss)) r) + + where + fixReply :: [String] -> (Reply String u a) -> (Reply [String] u a) + fixReply _ (Error err) = (Error err) + fixReply ss (Ok a (State "" sPos sUser) e) = (Ok a (State ss sPos sUser) e) + fixReply ss (Ok a (State s sPos sUser) e) = (Ok a (State (s:ss) sPos sUser) e) +-} +class PathInfo a where + toPathSegments :: a -> [String] + fromPathSegments :: URLParser a + +toPathInfo :: (PathInfo u) => u -> String +toPathInfo = ('/' :) . encodePathInfo . toPathSegments + +-- should this fail if not all the input was consumed? +-- +-- in theory we +-- require the pathInfo to have the initial '/', but this code will +-- still work if it is missing. +-- + +-- If there are multiple //// at the beginning, we only drop the first +-- one, because we only added one in toPathInfo. Hence the others +-- should be significant. +-- +-- However, if the pathInfo was prepend with http://example.org/ with +-- a trailing slash, then things might not line up. +fromPathInfo :: (PathInfo u) => String -> Either String u +fromPathInfo pi = + parseSegments fromPathSegments (decodePathInfo $ dropSlash pi) + where + dropSlash ('/':rs) = rs + dropSlash x = x + +mkSitePI :: (PathInfo url) => ((url -> String) -> url -> a) -> Site url a +mkSitePI handler = + Site { handleSite = handler + , formatPathSegments = toPathSegments + , parsePathSegments = parseSegments fromPathSegments + } + +showParseError :: ParseError -> String +showParseError pErr = + let pos = errorPos pErr + posMsg = sourceName pos ++ " (segment " ++ show (sourceLine pos) ++ " character " ++ show (sourceColumn pos) ++ "): " + msgs = errorMessages pErr + in posMsg ++ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" msgs + +-- it's instances all the way down + +instance PathInfo [String] where + toPathSegments = id + fromPathSegments = many anySegment + +instance PathInfo String where + toPathSegments = (:[]) + fromPathSegments = anySegment + +instance PathInfo Int where + toPathSegments i = [show i] + fromPathSegments = pToken (const "int") checkInt + where checkInt str = + case reads str of + [(n,[])] -> Just n + _ -> Nothing + +instance PathInfo Integer where + toPathSegments i = [show i] + fromPathSegments = pToken (const "integer") checkInteger + where checkInteger str = + case reads str of + [(n,[])] -> Just n + _ -> Nothing diff --git a/Web/Routes/QuickCheck.hs b/Web/Routes/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/Web/Routes/QuickCheck.hs @@ -0,0 +1,9 @@ +module Web.Routes.QuickCheck where + +import Web.Routes.PathInfo (PathInfo, toPathInfo, fromPathInfo) + +pathInfoInverse_prop :: (Eq url, PathInfo url) => url -> Bool +pathInfoInverse_prop url = + case (fromPathInfo $ toPathInfo url) of + Right url' -> url == url' + _ -> False diff --git a/Web/Routes/RouteT.hs b/Web/Routes/RouteT.hs new file mode 100644 --- /dev/null +++ b/Web/Routes/RouteT.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, TypeFamilies, PackageImports, FlexibleContexts, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Web.Route.RouteT +-- Copyright : (c) 2010 Jeremy Shaw +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : partners@seereason.com +-- Stability : experimental +-- Portability : portable +-- +-- Declaration of the 'RouteT' monad transformer +----------------------------------------------------------------------------- +module Web.Routes.RouteT where + +import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty)) +import Control.Monad (MonadPlus(mzero, mplus)) +import Control.Monad.Fix (MonadFix(mfix)) + +-- * RouteT Monad Transformer + +type Link = String + +-- |monad transformer for generating URLs +newtype RouteT url m a = RouteT { unRouteT :: (url -> Link) -> m a } +-- deriving (Functor, Monad, MonadFix, MonadPlus) -- , MonadIO, MonadTrans, MonadReader (url -> Link)) + +runRouteT :: RouteT url m a -> (url -> Link) -> m a +runRouteT = unRouteT + +-- | Transform the computation inside a @RouteT@. +mapRouteT :: (m a -> n b) -> RouteT url m a -> RouteT url n b +mapRouteT f (RouteT m) = RouteT $ f . m + +-- | Execute a computation in a modified environment +withRouteT :: ((url' -> Link) -> (url -> Link)) -> RouteT url m a -> RouteT url' m a +withRouteT f (RouteT m) = RouteT $ m . f + +liftRouteT :: m a -> RouteT url m a +liftRouteT m = RouteT (const m) + +askRouteT :: (Monad m) => RouteT url m (url -> String) +askRouteT = RouteT return + +instance (Functor m) => Functor (RouteT url m) where + fmap f = mapRouteT (fmap f) + +instance (Applicative m) => Applicative (RouteT url m) where + pure = liftRouteT . pure + f <*> v = RouteT $ \ url -> unRouteT f url <*> unRouteT v url + +instance (Alternative m) => Alternative (RouteT url m) where + empty = liftRouteT empty + m <|> n = RouteT $ \ url -> unRouteT m url <|> unRouteT n url + +instance (Monad m) => Monad (RouteT url m) where + return = liftRouteT . return + m >>= k = RouteT $ \ url -> do + a <- unRouteT m url + unRouteT (k a) url + fail msg = liftRouteT (fail msg) + +instance (MonadPlus m, Monad (RouteT url m)) => MonadPlus (RouteT url m) where + mzero = liftRouteT mzero + m `mplus` n = RouteT $ \ url -> unRouteT m url `mplus` unRouteT n url + +instance (MonadFix m) => MonadFix (RouteT url m) where + mfix f = RouteT $ \ url -> mfix $ \ a -> unRouteT (f a) url + +class ShowURL m where + type URL m + showURL :: (URL m) -> m Link -- ^ convert a URL value into a Link (aka, a String) + +instance (Monad m) => ShowURL (RouteT url m) where + type URL (RouteT url m) = url + showURL url = + do showF <- askRouteT + return (showF url) + +-- |used to embed a RouteT into a larger parent url +nestURL :: (Monad m) => (url2 -> url1) -> RouteT url2 m a -> RouteT url1 m a +nestURL b = withRouteT (. b) + +crossURL :: (Monad m) => (url2 -> url1) -> RouteT url1 m (url2 -> Link) +crossURL f = + do showF <- askRouteT + return $ \url2 -> showF (f url2) diff --git a/Web/Routes/Site.hs b/Web/Routes/Site.hs new file mode 100644 --- /dev/null +++ b/Web/Routes/Site.hs @@ -0,0 +1,60 @@ +module Web.Routes.Site where + +import Data.Maybe (isJust, fromJust) +import Data.Monoid (Monoid(mappend)) +import Web.Routes.Base (decodePathInfo, encodePathInfo) + +{-| + +A site groups together the three functions necesary to make an application: + +* A function to convert from the URL type to path segments. + +* A function to convert from path segments to the URL, if possible. + +* A function to return the application for a given URL. + +There are two type parameters for Site: the first is the URL datatype, the +second is the application datatype. The application datatype will depend upon +your server backend. +-} +data Site url a + = Site { + {-| + Return the appropriate application for a given URL. + + The first argument is a function which will give an appropriate + URL (as a String) for a URL datatype. This is usually + constructed by a combination of 'formatPathSegments' and the + prepending of an absolute application root. + + Well behaving applications should use this function to + generating all internal URLs. + -} + handleSite :: (url -> String) -> url -> a + -- | This function must be the inverse of 'parsePathSegments'. + , formatPathSegments :: url -> [String] + -- | This function must be the inverse of 'formatPathSegments'. + , parsePathSegments :: [String] -> Either String url + } + +-- | Override the \"default\" URL, ie the result of 'parsePathSegments' []. +setDefault :: url -> Site url a -> Site url a +setDefault defUrl (Site handle format parse) = + Site handle format parse' + where + parse' [] = Right defUrl + parse' x = parse x + +instance Functor (Site url) where + fmap f site = site { handleSite = \showFn u -> f (handleSite site showFn u) } + +-- | Retrieve the application to handle a given request. +runSite :: String -- ^ application root, with trailing slash + -> Site url a + -> String -- ^ path info, leading slash stripped + -> (Either String a) +runSite approot site pathInfo = + case parsePathSegments site $ decodePathInfo pathInfo of + (Left errs) -> (Left errs) + (Right url) -> Right $ (handleSite site) (\url -> approot ++ (encodePathInfo $ formatPathSegments site url)) url diff --git a/web-routes.cabal b/web-routes.cabal new file mode 100644 --- /dev/null +++ b/web-routes.cabal @@ -0,0 +1,32 @@ +Name: web-routes +Version: 0.22.0 +License: BSD3 +Author: jeremy@seereason.com +Maintainer: partners@seereason.com +Bug-Reports: http://bugzilla.seereason.com/ +Category: Web, Language +Synopsis: Library for maintaining correctness and composability of URLs within an application. +Description: A collection of types and functions that ensure that URLs generated by an application are valid. Need more properties here. +Cabal-Version: >= 1.6 +Build-type: Simple + +Library + Build-Depends: base >= 4 && < 5, + parsec >= 2 && <3, + bytestring >= 0.9 && < 0.10, + network >= 2.2 && < 2.3, + utf8-string >= 0.3 && < 0.4 + Exposed-Modules: Web.Routes + Web.Routes.Base + Web.Routes.PathInfo + Web.Routes.QuickCheck + Web.Routes.RouteT + Web.Routes.Site + + Extensions: TemplateHaskell, + FlexibleContexts, + CPP + +source-repository head + type: darcs + location: http://src.seereason.com/web-routes/