web-routes 0.27.1 → 0.27.2

raw patch · 6 files changed

+188/−31 lines, 6 filesdep +HUnitdep +QuickCheckdep +ghc-primdep ~bytestringdep ~http-typesdep ~networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HUnit, QuickCheck, ghc-prim, split, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-th, web-routes

Dependency ranges changed: bytestring, http-types, network

API changes (from Hackage documentation)

Files

• Web/Routes/Base.hs +2/−2
• Web/Routes/PathInfo.hs +111/−16
• Web/Routes/QuickCheck.hs +6/−0
• Web/Routes/RouteT.hs +7/−7
• test/Test.hs +41/−0
• web-routes.cabal +21/−6

@@ -253,7 +253,7 @@ encodePathInfoUtf8 segments qs = encodePath segments (queryTextToQuery qs)  encodePathInfoString :: [String] -> [(String, String)] -> String-encodePathInfoString pieces qs = +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 ..@@ -261,7 +261,7 @@       y = paramsToQueryString qs    in x pieces ++ y     where-      -- reverse composition +      -- reverse composition       o :: (a -> b) -> (b -> c) -> a -> c       o = flip (.) 

@@ -1,4 +1,9 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ > 702+{-# LANGUAGE DefaultSignatures, OverloadedStrings, ScopedTypeVariables, TypeOperators #-}+#endif+ module Web.Routes.PathInfo     ( stripOverlap     , stripOverlapBS@@ -15,6 +20,10 @@     , fromPathInfo     , mkSitePI     , showParseError+#if __GLASGOW_HASKELL__ > 702+    -- * Re-exported for convenience+    , Generic+#endif     ) where  import Blaze.ByteString.Builder (Builder, toByteString)@@ -27,7 +36,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal, signed) import Data.Maybe (fromJust)-import Network.HTTP.Types +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)@@ -35,6 +44,14 @@ import Web.Routes.Base (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]@@ -76,7 +93,7 @@ -- > 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 =@@ -111,8 +128,8 @@ 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) -> +p2u p =+  mkPT $ \state@(State sInput sPos sUser) ->   case sInput of     (s:ss) ->        do r <- runParsecT p (State s sPos sUser)@@ -121,22 +138,22 @@     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) +      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 = +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) -> +  mkPT $ \state@(State sInput sPos sUser) ->   case sInput of     (s:ss) ->        do r <- runParsecT p (State s sPos sUser)@@ -145,14 +162,92 @@     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) +      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+-- <http://hackage.haskell.org/package/web-routes-th web-routes-th>. 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@@ -168,7 +263,7 @@                  -> Text toPathInfoParams url params = encodePathInfo (toPathSegments url) params --- should this fail if not all the input was consumed?  +-- should this fail if not all the input was consumed? -- -- in theory we -- require the pathInfo to have the initial '/', but this code will@@ -182,8 +277,8 @@ -- 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'. --- +-- | parse a 'String' into 'url' using 'PathInfo'.+-- -- returns @Left "parse error"@ on failure -- -- returns @Right url@ on success@@ -193,7 +288,7 @@   parseSegments fromPathSegments (decodePathInfo $ dropSlash pi)   where     dropSlash s =-        if ((B.pack "/") `B.isPrefixOf` s) +        if ((B.singleton '/') `B.isPrefixOf` s)         then B.tail s         else s 

@@ -3,6 +3,12 @@ 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

@@ -38,7 +38,7 @@ -- | 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) +runRouteT :: (url -> RouteT url m a)           -> ((url -> [(Text, Maybe Text)] -> Text) -> url -> m a) runRouteT r = \f u -> (unRouteT (r u)) f @@ -59,7 +59,7 @@ instance (Functor m) => Functor (RouteT url m) where   fmap f = mapRouteT (fmap f) -instance (Applicative m) => Applicative (RouteT url m) where  +instance (Applicative m) => Applicative (RouteT url m) where   pure = liftRouteT . pure   f <*> v = RouteT $ \ url -> unRouteT f url <*> unRouteT v url @@ -90,16 +90,16 @@ 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  +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 (MonadRWS r w s m) => MonadRWS r w s (RouteT url m) -instance (MonadState s m) => MonadState s (RouteT url m) where  +instance (MonadState s m) => MonadState s (RouteT url m) where   get = liftRouteT get   put s = liftRouteT $ put s @@ -116,12 +116,12 @@     askRouteFn = askRouteT  showURL :: (MonadRoute m) => URL m -> m Text-showURL url = +showURL url =     do showFn <- askRouteFn        return (showFn url [])  showURLParams  :: (MonadRoute m) => URL m -> [(Text, Maybe Text)] -> m Text-showURLParams url params = +showURLParams url params =     do showFn <- askRouteFn        return (showFn url params) 

@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, OverloadedStrings, TemplateHaskell #-}++module Main (main) where++import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.Framework.TH+import Test.HUnit+import Test.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_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++main :: IO ()+main = $defaultMainGenerator

@@ -1,5 +1,5 @@ Name:             web-routes-Version:          0.27.1+Version:          0.27.2 License:          BSD3 License-File:     LICENSE Author:           jeremy@seereason.com@@ -8,19 +8,34 @@ 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+Cabal-Version:    >= 1.8 Build-type:       Simple +test-suite Test+  type             : exitcode-stdio-1.0+  main-is          : Test.hs+  hs-source-dirs   : test+  build-depends    : base == 4.*,+                     HUnit,+                     QuickCheck,+                     test-framework,+                     test-framework-hunit,+                     test-framework-quickcheck2,+                     test-framework-th,+                     web-routes+ Library         Build-Depends:    base >= 4 && < 5,                           blaze-builder >= 0.2 && < 0.4,                           parsec >= 2 && <4,-                          bytestring >= 0.9 && < 0.10,-                          http-types == 0.6.*,+                          bytestring >= 0.9 && < 0.11,+                          http-types >= 0.6,                           mtl,-                          network >= 2.2 && < 2.4,+                          network >= 2.2 && < 2.5,                           text == 0.11.*,                           utf8-string >= 0.3 && < 0.4+        if impl(ghc >= 7.2)+          Build-Depends:  ghc-prim, split         Exposed-Modules:  Web.Routes                           Web.Routes.Base                           Web.Routes.PathInfo@@ -34,4 +49,4 @@  source-repository head     type:     darcs-    location: http://src.seereason.com/web-routes/+    location: http://hub.darcs.net/stepcut/web-routes