web-routes-0.27.14.3/0000755000000000000000000000000007346545000012313 5ustar0000000000000000web-routes-0.27.14.3/LICENSE0000644000000000000000000000275707346545000013333 0ustar0000000000000000Copyright (c)2010, Jeremy Shaw All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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. * Neither the name of Jeremy Shaw nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT OWNER 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. web-routes-0.27.14.3/Setup.hs0000644000000000000000000000005607346545000013750 0ustar0000000000000000import Distribution.Simple main = defaultMain web-routes-0.27.14.3/Web/0000755000000000000000000000000007346545000013030 5ustar0000000000000000web-routes-0.27.14.3/Web/Routes.hs0000644000000000000000000000050107346545000014641 0ustar0000000000000000module 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-0.27.14.3/Web/Routes/0000755000000000000000000000000007346545000014311 5ustar0000000000000000web-routes-0.27.14.3/Web/Routes/Base.hs0000644000000000000000000002615007346545000015523 0ustar0000000000000000{-# 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 , decodePathInfoParams ) where import Blaze.ByteString.Builder (Builder, toByteString) import Codec.Binary.UTF8.String (encodeString, decodeString) import Data.ByteString (ByteString) import Data.List (intercalate, intersperse) import Data.Text (Text) import Data.Text.Encoding as Text (encodeUtf8, decodeUtf8) import Network.HTTP.Types (Query, encodePath, decodePath, decodePathSegments, queryTextToQuery, queryToQueryText) {- 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 :: [Text] -> [(Text, Maybe Text)] -> Text encodePathInfo segments qs = Text.decodeUtf8 $ toByteString $ encodePathInfoUtf8 segments qs encodePathInfoUtf8 :: [Text] -> [(Text, Maybe Text)] -> Builder encodePathInfoUtf8 segments qs = encodePath segments (queryTextToQuery qs) {-| 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 \"\/\" [\"\"] Note that while function accepts a 'Text' value, it is expected that 'Text' will only contain the subset of characters which are allowed to appear in a URL. -} decodePathInfo :: ByteString -> [Text] decodePathInfo = decodePathSegments -- | Returns path segments as well as possible query string components -- -- For example: -- -- > decodePathInfoParams "/home?q=1" -- (["home"],[("q",Just "1")]) -- decodePathInfoParams :: ByteString -> ([Text], [(Text, Maybe Text)]) decodePathInfoParams = fmap queryToQueryText . decodePath web-routes-0.27.14.3/Web/Routes/PathInfo.hs0000644000000000000000000002725707346545000016372 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, TupleSections #-} #if __GLASGOW_HASKELL__ > 702 {-# LANGUAGE DefaultSignatures, OverloadedStrings, ScopedTypeVariables, TypeOperators #-} #endif module Web.Routes.PathInfo ( stripOverlap , stripOverlapBS , stripOverlapText , URLParser , pToken , segment , anySegment , patternParse , parseSegments , PathInfo(..) , toPathInfo , toPathInfoParams , fromPathInfo , fromPathInfoParams , mkSitePI , showParseError #if __GLASGOW_HASKELL__ > 702 -- * Re-exported for convenience , Generic #endif ) where import Blaze.ByteString.Builder (Builder, toByteString) import Control.Applicative ((<$>), (<*)) import Control.Monad (msum) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List as List (stripPrefix, tails) import Data.Text as Text (Text, pack, unpack, null, tails, stripPrefix) import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal, signed) import Data.Maybe (fromJust) import Network.HTTP.Types import Text.ParserCombinators.Parsec.Combinator (notFollowedBy) import Text.ParserCombinators.Parsec.Error (ParseError, errorPos, errorMessages, showErrorMessages) import Text.ParserCombinators.Parsec.Pos (incSourceLine, sourceName, sourceLine, sourceColumn) import Text.ParserCombinators.Parsec.Prim ((), GenParser, getInput, setInput, getPosition, token, parse, many) import Web.Routes.Base (decodePathInfoParams, decodePathInfo, encodePathInfo) import Web.Routes.Site (Site(..)) #if __GLASGOW_HASKELL__ > 702 import Control.Applicative ((<$), (<*>), (<|>), pure) import Data.Char (toLower, isUpper) import Data.List (intercalate) import Data.List.Split (split, dropInitBlank, keepDelimsL, whenElt) import GHC.Generics #endif -- 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 $ [ List.stripPrefix p y | p <- List.tails x] stripOverlapText :: Text -> Text -> Text stripOverlapText x y = fromJust $ msum $ [ Text.stripPrefix p y | p <- Text.tails x ] stripOverlapBS :: B.ByteString -> B.ByteString -> B.ByteString stripOverlapBS x y = fromJust $ msum $ [ stripPrefix p y | p <- B.tails x ] -- fromJust will never fail where stripPrefix :: B.ByteString -> B.ByteString -> Maybe B.ByteString stripPrefix x y | x `B.isPrefixOf` y = Just $ B.drop (B.length x) y | otherwise = Nothing type URLParser a = GenParser Text () a pToken :: tok -> (Text -> Maybe a) -> URLParser a pToken msg f = do pos <- getPosition token unpack (const $ incSourceLine pos 1) f -- | match on a specific string segment :: Text -> URLParser Text segment x = (pToken (const x) (\y -> if x == y then Just x else Nothing)) unpack x -- | match on any string anySegment :: URLParser Text anySegment = pToken (const "any string") Just -- | Only matches if all segments have been consumed eof :: URLParser () eof = notFollowedBy anySegment "end of input" -- | apply a function to the remainder of the segments -- -- useful if you want to just do normal pattern matching: -- > -- > foo ["foo", "bar"] = Right (Foo Bar) -- > foo ["baz"] = Right Baz -- > foo _ = Left "parse error" -- -- > patternParse foo patternParse :: ([Text] -> Either String a) -> URLParser a patternParse p = do segs <- getInput case p segs of (Right r) -> do setInput [] return r (Left err) -> fail err -- | show Parsec 'ParseError' using terms that relevant to parsing a url 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 -- | run a 'URLParser' on a list of path segments -- -- returns @Left "parse error"@ on failure. -- -- returns @Right a@ on success parseSegments :: URLParser a -> [Text] -> Either String a parseSegments p segments = case parse (p <* eof) (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) -} #if __GLASGOW_HASKELL__ > 702 hyphenate :: String -> Text hyphenate = pack . intercalate "-" . map (map toLower) . split splitter where splitter = dropInitBlank . keepDelimsL . whenElt $ isUpper class GPathInfo f where gtoPathSegments :: f url -> [Text] gfromPathSegments :: URLParser (f url) instance GPathInfo U1 where gtoPathSegments U1 = [] gfromPathSegments = pure U1 instance GPathInfo a => GPathInfo (D1 c a) where gtoPathSegments = gtoPathSegments . unM1 gfromPathSegments = M1 <$> gfromPathSegments instance GPathInfo a => GPathInfo (S1 c a) where gtoPathSegments = gtoPathSegments . unM1 gfromPathSegments = M1 <$> gfromPathSegments instance forall c a. (GPathInfo a, Constructor c) => GPathInfo (C1 c a) where gtoPathSegments m@(M1 x) = (hyphenate . conName) m : gtoPathSegments x gfromPathSegments = M1 <$ segment (hyphenate . conName $ (undefined :: C1 c a r)) <*> gfromPathSegments instance (GPathInfo a, GPathInfo b) => GPathInfo (a :*: b) where gtoPathSegments (a :*: b) = gtoPathSegments a ++ gtoPathSegments b gfromPathSegments = (:*:) <$> gfromPathSegments <*> gfromPathSegments instance (GPathInfo a, GPathInfo b) => GPathInfo (a :+: b) where gtoPathSegments (L1 x) = gtoPathSegments x gtoPathSegments (R1 x) = gtoPathSegments x gfromPathSegments = L1 <$> gfromPathSegments <|> R1 <$> gfromPathSegments instance PathInfo a => GPathInfo (K1 i a) where gtoPathSegments = toPathSegments . unK1 gfromPathSegments = K1 <$> fromPathSegments #endif -- | Simple parsing and rendering for a type to and from URL path segments. -- -- If you're using GHC 7.2 or later, you can use @DeriveGeneric@ to derive -- instances of this class: -- -- > {-# LANGUAGE DeriveGeneric #-} -- > data Sitemap = Home | BlogPost Int deriving Generic -- > instance PathInfo Sitemap -- -- This results in the following instance: -- -- > instance PathInfo Sitemap where -- > toPathSegments Home = ["home"] -- > toPathSegments (BlogPost x) = "blog-post" : toPathSegments x -- > fromPathSegments = Home <$ segment "home" -- > <|> BlogPost <$ segment "blog-post" <*> fromPathSegments -- -- And here it is in action: -- -- >>> toPathInfo (BlogPost 123) -- "/blog-post/123" -- >>> fromPathInfo "/blog-post/123" :: Either String Sitemap -- Right (BlogPost 123) -- -- To instead derive instances using @TemplateHaskell@, see -- . class PathInfo url where toPathSegments :: url -> [Text] fromPathSegments :: URLParser url #if __GLASGOW_HASKELL__ > 702 default toPathSegments :: (Generic url, GPathInfo (Rep url)) => url -> [Text] toPathSegments = gtoPathSegments . from default fromPathSegments :: (Generic url, GPathInfo (Rep url)) => URLParser url fromPathSegments = to <$> gfromPathSegments #endif -- |convert url into the path info portion of a URL toPathInfo :: (PathInfo url) => url -> Text toPathInfo = decodeUtf8 . toByteString . toPathInfoUtf8 -- |convert url into the path info portion of a URL toPathInfoUtf8 :: (PathInfo url) => url -> Builder toPathInfoUtf8 = flip encodePath [] . toPathSegments -- |convert url + params into the path info portion of a URL + a query string toPathInfoParams :: (PathInfo url) => url -- ^ url -> [(Text, Maybe Text)] -- ^ query string parameter -> Text toPathInfoParams url params = encodePathInfo (toPathSegments url) params -- 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. -- | parse a 'String' into 'url' using 'PathInfo'. -- -- returns @Left "parse error"@ on failure -- -- returns @Right url@ on success fromPathInfo :: (PathInfo url) => ByteString -> Either String url fromPathInfo pi = parseSegments fromPathSegments (decodePathInfo $ dropSlash pi) -- | parse a 'String' into '(url, Query)' using 'PathInfo'. -- -- returns @Left "parse error"@ on failure -- -- returns @Right (url, Query@ on success fromPathInfoParams :: (PathInfo url) => ByteString -> Either String (url, [(Text, Maybe Text)]) fromPathInfoParams pi = (,query) <$> parseSegments fromPathSegments url where (url, query) = decodePathInfoParams $ dropSlash pi -- | Removes a leading slash, if it exists dropSlash :: ByteString -> ByteString dropSlash s = if ((B.singleton '/') `B.isPrefixOf` s) then B.tail s else s -- | turn a routing function into a 'Site' value using the 'PathInfo' class mkSitePI :: (PathInfo url) => ((url -> [(Text, Maybe Text)] -> Text) -> url -> a) -- ^ a routing function -> Site url a mkSitePI handler = Site { handleSite = handler , formatPathSegments = (\x -> (x, [])) . toPathSegments , parsePathSegments = parseSegments fromPathSegments } -- it's instances all the way down instance PathInfo Text where toPathSegments = (:[]) fromPathSegments = anySegment instance PathInfo [Text] where toPathSegments = id fromPathSegments = many anySegment instance PathInfo String where toPathSegments = (:[]) . pack fromPathSegments = unpack <$> anySegment instance PathInfo [String] where toPathSegments = id . map pack fromPathSegments = many (unpack <$> anySegment) instance PathInfo Int where toPathSegments i = [pack $ show i] fromPathSegments = pToken (const "Int") checkIntegral instance PathInfo Integer where toPathSegments i = [pack $ show i] fromPathSegments = pToken (const "Integer") checkIntegral instance PathInfo Int64 where toPathSegments i = [pack $ show i] fromPathSegments = pToken (const "Int64") checkIntegral checkIntegral :: Integral a => Text -> Maybe a checkIntegral txt = case signed decimal txt of (Left e) -> Nothing (Right (n, r)) | Text.null r -> Just n | otherwise -> Nothing web-routes-0.27.14.3/Web/Routes/QuickCheck.hs0000644000000000000000000000075507346545000016666 0ustar0000000000000000module Web.Routes.QuickCheck where import qualified Data.Text.Encoding as Text import Web.Routes.PathInfo (PathInfo, toPathInfo, fromPathInfo) -- | test that a 'PathInfo' instance is valid -- -- Generates 'Arbitrary' 'url' values and checks that: -- -- fromPathInfo . toPathInfo == id -- pathInfoInverse_prop :: (Eq url, PathInfo url) => url -> Bool pathInfoInverse_prop url = case (fromPathInfo $ Text.encodeUtf8 $ toPathInfo url) of Right url' -> url == url' _ -> False web-routes-0.27.14.3/Web/Routes/RouteT.hs0000644000000000000000000001264307346545000016075 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, 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.Catch (MonadCatch(catch), MonadThrow(throwM)) import Control.Monad.Cont(MonadCont(callCC)) import Control.Monad.Error (MonadError(throwError, catchError)) #if !MIN_VERSION_base(4,13,0) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Prelude hiding (fail) import Control.Monad.Fail (MonadFail(..)) #endif import Control.Monad.Fix (MonadFix(mfix)) import Control.Monad.Reader(MonadReader(ask,local)) import Control.Monad.RWS (MonadRWS) import Control.Monad.State(MonadState(get,put)) import Control.Monad.Trans (MonadTrans(lift), MonadIO(liftIO)) import Control.Monad.Writer(MonadWriter(listen, tell, pass)) import Data.Text (Text) -- * RouteT Monad Transformer -- |monad transformer for generating URLs newtype RouteT url m a = RouteT { unRouteT :: (url -> [(Text, Maybe Text)] -> Text) -> m a } class (Monad m) => MonadRoute m where type URL m askRouteFn :: m (URL m -> [(Text, Maybe Text)] -> Text) instance MonadCatch m => MonadCatch (RouteT url m) where catch action handler = RouteT $ \ fn -> catch (action' fn) (\ e -> handler' e fn) where action' = unRouteT action handler' e = unRouteT (handler e) instance MonadThrow m => MonadThrow (RouteT url m) where throwM = throwM' where throwM' e = RouteT $ \ _fn -> throwM e -- | convert a 'RouteT' based route handler to a handler that can be used with the 'Site' type -- -- NOTE: this function used to be the same as 'unRouteT'. If you want the old behavior, just call 'unRouteT'. runRouteT :: (url -> RouteT url m a) -> ((url -> [(Text, Maybe Text)] -> Text) -> url -> m a) runRouteT r = \f u -> (unRouteT (r u)) f -- | 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' -> [(Text, Maybe Text)] -> Text) -> (url -> [(Text, Maybe Text)] -> Text)) -> 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 -> [(Text, Maybe Text)] -> Text) 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 instance (MonadFail m) => MonadFail (RouteT url m) where 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 (MonadCont m) => MonadCont (RouteT url m) where callCC f = RouteT $ \url -> callCC $ \c -> unRouteT (f (\a -> RouteT $ \_ -> c a)) url instance (MonadError e m) => MonadError e (RouteT url m) where throwError = liftRouteT . throwError catchError action handler = RouteT $ \f -> catchError (unRouteT action f) (\e -> unRouteT (handler e) f) instance (MonadFix m) => MonadFix (RouteT url m) where mfix f = RouteT $ \ url -> mfix $ \ a -> unRouteT (f a) url instance (MonadIO m) => MonadIO (RouteT url m) where liftIO = lift . liftIO instance (MonadReader r m) => MonadReader r (RouteT url m) where ask = liftRouteT ask local f = mapRouteT (local f) instance (MonadRWS r w s m) => MonadRWS r w s (RouteT url m) instance (MonadState s m) => MonadState s (RouteT url m) where get = liftRouteT get put s = liftRouteT $ put s instance MonadTrans (RouteT url) where lift = liftRouteT instance (MonadWriter w m) => MonadWriter w (RouteT url m) where tell w = liftRouteT $ tell w listen m = mapRouteT listen m pass m = mapRouteT pass m instance (Monad m) => MonadRoute (RouteT url m) where type URL (RouteT url m) = url askRouteFn = askRouteT showURL :: (MonadRoute m) => URL m -> m Text showURL url = do showFn <- askRouteFn return (showFn url []) showURLParams :: (MonadRoute m) => URL m -> [(Text, Maybe Text)] -> m Text showURLParams url params = do showFn <- askRouteFn return (showFn url params) nestURL :: (url1 -> url2) -> RouteT url1 m a -> RouteT url2 m a nestURL transform (RouteT r) = do RouteT $ \showFn -> r (\url params -> showFn (transform url) params) web-routes-0.27.14.3/Web/Routes/Site.hs0000644000000000000000000000501107346545000015546 0ustar0000000000000000module Web.Routes.Site where import Data.ByteString import Data.Monoid import Data.Text (Text) 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 -> [(Text, Maybe Text)] -> Text) -> url -> a -- | This function must be the inverse of 'parsePathSegments'. , formatPathSegments :: url -> ([Text], [(Text, Maybe Text)]) -- | This function must be the inverse of 'formatPathSegments'. , parsePathSegments :: [Text] -> 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. -- -- NOTE: use 'decodePathInfo' to convert a 'ByteString' url to a properly decoded list of path segments runSite :: Text -- ^ application root, with trailing slash -> Site url a -> [Text] -- ^ path info, (call 'decodePathInfo' on path with leading slash stripped) -> (Either String a) runSite approot site pathInfo = case parsePathSegments site pathInfo of (Left errs) -> (Left errs) (Right url) -> Right $ handleSite site showFn url where showFn url qs = let (pieces, qs') = formatPathSegments site url in approot `mappend` (encodePathInfo pieces (qs ++ qs')) web-routes-0.27.14.3/test/0000755000000000000000000000000007346545000013272 5ustar0000000000000000web-routes-0.27.14.3/test/Test.hs0000644000000000000000000000375107346545000014553 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, OverloadedStrings, TemplateHaskell #-} module Main (main) where import Data.Text (Text) import Test.HUnit import Test.QuickCheck import Test.Hspec import Test.Hspec.QuickCheck import Web.Routes newtype ArticleId = ArticleId Int deriving (Eq, Show, Num, PathInfo, Arbitrary) data Sitemap = Home | Article ArticleId deriving (Eq, Show, Generic) instance PathInfo Sitemap instance Arbitrary Sitemap where arbitrary = oneof [return Home, fmap Article arbitrary] prop_PathInfo_isomorphism :: Sitemap -> Bool prop_PathInfo_isomorphism = pathInfoInverse_prop case_toPathInfo :: Assertion case_toPathInfo = do toPathInfo Home @?= "/home" toPathInfo (Article 0) @?= "/article/0" case_toPathInfoParams :: Assertion case_toPathInfoParams = do toPathInfoParams Home [("q",Just "1"),("r",Just "2")] @?= "/home?q=1&r=2" toPathInfoParams (Article 0) [("q",Just "1"),("r",Just "2")] @?= "/article/0?q=1&r=2" case_fromPathInfo :: Assertion case_fromPathInfo = do fromPathInfo "/home" @?= Right Home fromPathInfo "/article/0" @?= Right (Article 0) case fromPathInfo "/" :: Either String Sitemap of Left _ -> return () url -> assertFailure $ "expected a Left, but got: " ++ show url case_fromPathInfoParams :: Assertion case_fromPathInfoParams = do fromPathInfoParams "/home?q=1&r=2" @?= Right (Home, [("q",Just "1"),("r",Just "2")]) fromPathInfoParams "/article/0?q=1&r=2" @?= Right (Article 0, [("q",Just "1"),("r",Just "2")]) case fromPathInfoParams "/?q=1&r=2" :: Either String (Sitemap, [(Text, Maybe Text)]) of Left _ -> return () url -> assertFailure $ "expected a Left, but got: " ++ show url main :: IO () main = hspec $ do prop "toPathInfo" case_toPathInfo prop "toPathInfoParams" case_toPathInfoParams prop "fromPathInfo" case_fromPathInfo prop "fromPathInfoParams" case_fromPathInfoParams prop "PathInfo_isomorphism" prop_PathInfo_isomorphism web-routes-0.27.14.3/web-routes.cabal0000644000000000000000000000363307346545000015400 0ustar0000000000000000Name: web-routes Version: 0.27.14.3 License: BSD3 License-File: LICENSE Author: jeremy@seereason.com Maintainer: partners@seereason.com Category: Web, Language Synopsis: portable, type-safe URL routing Description: A collection of types and functions that ensure that URLs generated by an application are valid. Need more properties here. Homepage: http://www.happstack.com/docs/crashcourse/index.html#web-routes Cabal-Version: >= 1.8 Build-type: Simple tested-with: GHC==8.0.1, GHC==8.2.2, GHC==8.4.1, GHC==8.6.5, GHC==8.8.1 test-suite Test type : exitcode-stdio-1.0 main-is : Test.hs hs-source-dirs : test build-depends : base == 4.*, HUnit, hspec, QuickCheck, text, web-routes Library Build-Depends: base >= 4.9 && < 5, blaze-builder >= 0.2 && < 0.5, parsec >= 2 && < 4, bytestring >= 0.9 && < 0.11, http-types >= 0.6 && < 0.13, mtl >= 2.0 && < 2.3, text >= 0.11 && < 1.3, utf8-string >= 0.3 && < 1.1, exceptions >= 0.6.1 && < 0.11 if impl(ghc >= 7.2) Build-Depends: ghc-prim, split Exposed-Modules: Web.Routes Web.Routes.Base Web.Routes.PathInfo Web.Routes.QuickCheck Web.Routes.RouteT Web.Routes.Site Extensions: FlexibleContexts, CPP source-repository head type: git location: https://github.com/Happstack/web-routes.git