web-routes 0.25.3 → 0.26.2

raw patch · 6 files changed

+146/−84 lines, 6 filesdep +blaze-builderdep +http-typesdep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-builder, http-types, text

API changes (from Hackage documentation)

Files

• Web/Routes/Base.hs +20/−4
• Web/Routes/PathInfo.hs +86/−45
• Web/Routes/QuickCheck.hs +2/−1
• Web/Routes/RouteT.hs +23/−25
• Web/Routes/Site.hs +11/−8
• web-routes.cabal +4/−1

@@ -16,9 +16,14 @@        , decodePathInfo        ) 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.URI+import Network.HTTP.Types (encodePath, decodePathSegments, queryTextToQuery)  {- @@ -240,8 +245,15 @@ \"%D7%A9%D7%9C%D7%95%D7%9D\"  -}-encodePathInfo :: [String] -> [(String, String)] -> String-encodePathInfo pieces qs = +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)++encodePathInfoString :: [String] -> [(String, String)] -> String+encodePathInfoString pieces qs =    let x = 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 ..@@ -278,9 +290,13 @@  [\"\"] +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 :: String -> [String]-decodePathInfo =+decodePathInfo :: ByteString -> [Text]+decodePathInfo = decodePathSegments++decodePathInfoString :: String -> [String]+decodePathInfoString =   splitPaths         `o` -- split path on delimiters   map unEscapeString `o` -- decode any percent encoded characters   map decodeString       -- decode octets

@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Web.Routes.PathInfo     ( stripOverlap+    , stripOverlapBS+    , stripOverlapText     , URLParser     , pToken     , segment@@ -15,10 +17,17 @@     , showParseError     ) where -import Control.Applicative ((<*))+import Blaze.ByteString.Builder (Builder, toByteString)+import Control.Applicative ((<$>), (<*)) import Control.Monad (msum)-import Data.List (stripPrefix, tails)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+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) 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)@@ -28,20 +37,32 @@  -- 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]+stripOverlap x y = fromJust $ msum $ [ List.stripPrefix p y | p <- List.tails x] -type URLParser a = GenParser String () a+stripOverlapText :: Text -> Text -> Text+stripOverlapText x y = fromJust $ msum $ [ Text.stripPrefix p y | p <- Text.tails x ] -pToken :: tok -> (String -> Maybe a) -> URLParser a+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 id (const $ incSourceLine pos 1) f+                  token unpack (const $ incSourceLine pos 1) f  -- | match on a specific string-segment :: String -> URLParser String-segment x = (pToken (const x) (\y -> if x == y then Just x else Nothing)) <?> x+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 String+anySegment :: URLParser Text anySegment = pToken (const "any string") Just  -- | Only matches if all segments have been consumed@@ -57,7 +78,7 @@ -- > foo _              = Left "parse error" --  -- > patternParse foo-patternParse :: ([String] -> Either String a) -> URLParser a+patternParse :: ([Text] -> Either String a) -> URLParser a patternParse p =   do segs <- getInput      case p segs of@@ -65,13 +86,21 @@          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 -> [String] -> Either String a+parseSegments :: URLParser a -> [Text] -> Either String a parseSegments p segments =   case parse (p <* eof) (show segments) segments of     (Left e)  -> Left (showParseError e)@@ -121,19 +150,23 @@ -}  class PathInfo url where-  toPathSegments :: url -> [String]+  toPathSegments :: url -> [Text]   fromPathSegments :: URLParser url  -- |convert url into the path info portion of a URL-toPathInfo :: (PathInfo url) => url -> String-toPathInfo = ('/' :) . flip encodePathInfo [] . toPathSegments+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-                 -> [(String, String)] -- ^ query string parameter-                 -> String-toPathInfoParams url params = ('/' :) . flip encodePathInfo params . toPathSegments $ 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?   --@@ -154,16 +187,19 @@ -- returns @Left "parse error"@ on failure -- -- returns @Right url@ on success-fromPathInfo :: (PathInfo url) => String -> Either String url++fromPathInfo :: (PathInfo url) => ByteString -> Either String url fromPathInfo pi =   parseSegments fromPathSegments (decodePathInfo $ dropSlash pi)   where-    dropSlash ('/':rs) = rs-    dropSlash x        = x+    dropSlash s =+        if ((B.pack "/") `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 -> [(String, String)] -> String) -> url -> a) -- ^ a routing function+            ((url -> [(Text, Maybe Text)] -> Text) -> url -> a) -- ^ a routing function          -> Site url a mkSitePI handler =   Site { handleSite         = handler@@ -171,36 +207,41 @@        , parsePathSegments  = parseSegments fromPathSegments        } --- | 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- -- it's instances all the way down -instance PathInfo [String] where+instance PathInfo Text where+  toPathSegments = (:[])+  fromPathSegments = anySegment++instance PathInfo [Text] where   toPathSegments = id   fromPathSegments = many anySegment  instance PathInfo String where-  toPathSegments = (:[])-  fromPathSegments = anySegment+  toPathSegments = (:[]) . pack+  fromPathSegments = unpack <$> anySegment +instance PathInfo [String] where+  toPathSegments = id . map pack+  fromPathSegments = many (unpack <$> 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+  toPathSegments i = [pack $ show i]+  fromPathSegments = pToken (const "Int") checkInt+   where checkInt txt =+           case decimal txt of+             (Left e) -> Nothing+             (Right (n, r))+                 | Text.null r -> Just n+                 | otherwise -> 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+  toPathSegments i = [pack $ show i]+  fromPathSegments = pToken (const "Integer") checkInt+   where checkInt txt =+           case decimal txt of+             (Left e) -> Nothing+             (Right (n, r))+                 | Text.null r -> Just n+                 | otherwise -> Nothing+

@@ -1,9 +1,10 @@ module Web.Routes.QuickCheck where +import qualified Data.Text.Encoding as Text import Web.Routes.PathInfo (PathInfo, toPathInfo, fromPathInfo)  pathInfoInverse_prop :: (Eq url, PathInfo url) => url -> Bool pathInfoInverse_prop url =-    case (fromPathInfo $ toPathInfo url) of+    case (fromPathInfo $ Text.encodeUtf8 $ toPathInfo url) of       Right url' -> url == url'       _ -> False

@@ -23,20 +23,23 @@ 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 -type Link = String- -- |monad transformer for generating URLs-newtype RouteT url m a = RouteT { unRouteT :: (url -> [(String, String)] -> Link) -> m a }+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)+ -- | 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 -> [(String, String)] -> String) -> 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@.@@ -44,13 +47,13 @@ mapRouteT f (RouteT m) = RouteT $ f . m  -- | Execute a computation in a modified environment-withRouteT :: ((url' -> [(String, String)] -> Link) -> (url -> [(String, String)] -> Link)) -> RouteT url m a -> RouteT url' m a+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 -> [(String, String)] -> String)+askRouteT :: (Monad m) => RouteT url m (url -> [(Text, Maybe Text)] -> Text) askRouteT = RouteT return  instance (Functor m) => Functor (RouteT url m) where@@ -108,26 +111,21 @@   listen m = mapRouteT listen m   pass   m = mapRouteT pass   m --class ShowURL m where-    type URL m-    showURLParams :: (URL m) -> [(String, String)] -> m Link -- ^ convert a URL value and a parameter list into a Link (aka, a String)--instance (Monad m) => ShowURL (RouteT url m) where+instance (Monad m) => MonadRoute (RouteT url m) where     type URL (RouteT url m) = url-    showURLParams url params =-        do showF <- askRouteT-           return (showF url params)+    askRouteFn = askRouteT --- | convert a URL value into a Link (aka, a String) using a null parameter list.-showURL :: ShowURL m => URL m -> m Link  -showURL url = showURLParams url []+showURL :: (MonadRoute m) => URL m -> m Text+showURL url = +    do showFn <- askRouteFn+       return (showFn 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)+showURLParams  :: (MonadRoute m) => URL m -> [(Text, Maybe Text)] -> m Text+showURLParams url params = +    do showFn <- askRouteFn+       return (showFn url params) -crossURL :: (Monad m) => (url2 -> url1) -> [(String, String)] -> RouteT url1 m (url2 -> Link)-crossURL f params = -    do showF <- askRouteT-       return $ \url2 -> showF (f url2) 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)

@@ -1,5 +1,8 @@ module Web.Routes.Site where +import Data.ByteString+import Data.Monoid+import Data.Text (Text) import Web.Routes.Base (decodePathInfo, encodePathInfo)  {-|@@ -29,11 +32,11 @@                Well behaving applications should use this function to                generating all internal URLs.            -}-             handleSite         :: (url -> [(String, String)] -> String) -> url -> a+             handleSite         :: (url -> [(Text, Maybe Text)] -> Text) -> url -> a            -- | This function must be the inverse of 'parsePathSegments'.-           , formatPathSegments :: url -> ([String], [(String, String)])+           , formatPathSegments :: url -> ([Text], [(Text, Maybe Text)])            -- | This function must be the inverse of 'formatPathSegments'.-           , parsePathSegments  :: [String] -> Either String url+           , parsePathSegments  :: [Text] -> Either String url            }  -- | Override the \"default\" URL, ie the result of 'parsePathSegments' [].@@ -48,15 +51,15 @@   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+runSite :: Text -- ^ application root, with trailing slash         -> Site url a-        -> String -- ^ path info, leading slash stripped+        -> ByteString -- ^ 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 go url+        (Right url) -> Right $ handleSite site showFn url   where-    go url qs =+    showFn url qs =         let (pieces, qs') = formatPathSegments site url-        in approot ++ encodePathInfo pieces (qs ++ qs')+        in approot `mappend` (encodePathInfo pieces (qs ++ qs'))

@@ -1,5 +1,5 @@ Name:             web-routes-Version:          0.25.3+Version:          0.26.2 License:          BSD3 License-File:     LICENSE Author:           jeremy@seereason.com@@ -13,10 +13,13 @@  Library         Build-Depends:    base >= 4 && < 5,+                          blaze-builder >= 0.2 && < 0.4,                           parsec >= 2 && <4,                           bytestring >= 0.9 && < 0.10,+                          http-types == 0.6.*,                           mtl,                           network >= 2.2 && < 2.4,+                          text == 0.11.*,                           utf8-string >= 0.3 && < 0.4         Exposed-Modules:  Web.Routes                           Web.Routes.Base