packages feed

web-routes (empty) → 0.22.0

raw patch · 8 files changed

+656/−0 lines, 8 filesdep +basedep +bytestringdep +networksetup-changed

Dependencies added: base, bytestring, network, parsec, utf8-string

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Routes.hs view
@@ -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+
+ Web/Routes/Base.hs view
@@ -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://<host>:<port>/<path>?<searchpart>++   where <host> and <port> are as described in Section 3.1. If :<port>+   is omitted, the port defaults to 80.  No user name or password is+   allowed.  <path> is an HTTP selector, and <searchpart> is a query+   string. The <path> is optional, as is the <searchpart> and its+   preceding "?". If neither <path> nor <searchpart> is present, the "/"+   may also be omitted.++   Within the <path> and <searchpart> 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:++      <scheme>://<net_loc>/<path>;<params>?<query>#<fragment>++   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<pchar>++      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+   <mailto:fred@example.com> has a path of "fred@example.com", whereas+   the URI <foo://info.example.com?fred> 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
+ Web/Routes/PathInfo.hs view
@@ -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
+ Web/Routes/QuickCheck.hs view
@@ -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
+ Web/Routes/RouteT.hs view
@@ -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)
+ Web/Routes/Site.hs view
@@ -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
+ web-routes.cabal view
@@ -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/