Spock 0.6.5.0 → 0.6.6.0

raw patch · 11 files changed

+193/−171 lines, 11 filesdep +QuickCheckdep +Spockdep +hspec2dep −HTFdep −pool-conduitdep ~case-insensitivedep ~conduitdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, Spock, hspec2

Dependencies removed: HTF, pool-conduit

Dependency ranges changed: case-insensitive, conduit, mtl, text, time, transformers

API changes (from Hackage documentation)

Files

• Spock.cabal +21/−50
• src/Tests.hs +0/−9
• src/Tests/Routing.hs +0/−86
• src/Web/Spock.hs +6/−7
• src/Web/Spock/Core.hs +33/−0
• src/Web/Spock/Monad.hs +1/−8
• src/Web/Spock/SafeActions.hs +5/−4
• src/Web/Spock/Types.hs +1/−7
• test/Spec.hs +1/−0
• test/Web/Spock/RoutingSpec.hs +109/−0
• test/Web/Spock/WireSpec.hs +16/−0

@@ -1,5 +1,5 @@ name:                Spock-version:             0.6.5.0+version:             0.6.6.0 synopsis:            Another Haskell web framework for rapid development description:         This toolbox provides everything you need to get a quick start into web hacking with haskell: routing, middleware, json, blaze, sessions, cookies, database helper, csrf-protection, global state Homepage:            https://github.com/agrafix/Spock@@ -14,41 +14,40 @@  library   hs-source-dirs:      src-  exposed-modules:     Web.Spock+  exposed-modules:     Web.Spock,+                       Web.Spock.Routing,+                       Web.Spock.Wire   other-modules:       Web.Spock.SessionManager,                        Web.Spock.Monad,                        Web.Spock.Types,                        Web.Spock.SafeActions,                        Web.Spock.Digestive,-                       Web.Spock.Core,-                       Web.Spock.Wire,-                       Web.Spock.Routing,-                       Web.Spock.Util-  build-depends:       aeson >= 0.6.2.1 && < 0.9,+                       Web.Spock.Util,+                       Web.Spock.Core+  build-depends:       aeson >= 0.6.2.1 && <0.9,                        base >= 4 && < 5,                        base64-bytestring ==1.*,                        blaze-html ==0.7.*,                        bytestring ==0.10.*,-                       case-insensitive ==1.1.*,-                       conduit >= 1.0 && < 1.2,+                       case-insensitive >=1.1 && <1.3,+                       conduit >= 1.0 && <1.3,                        containers ==0.5.*,                        digestive-functors ==0.7.*,                        directory ==1.2.*,                        hashable ==1.2.*,                        http-types ==0.8.*,                        monad-control ==0.3.*,-                       mtl ==2.1.*,+                       mtl >=2.1 && <2.3,                        old-locale ==1.*,                        path-pieces >=0.1.4,-                       pool-conduit ==0.1.*,                        random ==1.*,                        regex-compat ==0.95.*,                        resource-pool ==0.2.*,-                       resourcet >= 0.4 && < 1.2,+                       resourcet >= 0.4 && <1.2,                        stm ==2.4.*,-                       text >= 0.11.3.1 && < 1.2,-                       time ==1.4.*,-                       transformers ==0.3.*,+                       text >= 0.11.3.1 && <1.3,+                       time >=1.4 && <1.6,+                       transformers >=0.3 && <0.5,                        transformers-base ==0.4.*,                        unordered-containers ==0.2.*,                        vault ==0.3.*,@@ -61,43 +60,15 @@  test-suite spocktests   type:                exitcode-stdio-1.0-  hs-source-dirs:      src-  main-is:             Tests.hs-  other-modules:       Tests.Routing-  build-depends:       HTF >=0.11 && <0.13,-                       aeson >= 0.6.2.1 && < 0.9,+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:       Web.Spock.WireSpec, Web.Spock.RoutingSpec+  build-depends:       QuickCheck,+                       Spock,                        base >= 4 && < 5,-                       base64-bytestring ==1.*,-                       blaze-html ==0.7.*,-                       bytestring ==0.10.*,-                       case-insensitive ==1.1.*,-                       conduit >= 1.0 && < 1.2,-                       containers ==0.5.*,-                       digestive-functors ==0.7.*,-                       directory ==1.2.*,-                       hashable ==1.2.*,-                       http-types ==0.8.*,-                       monad-control ==0.3.*,-                       mtl ==2.1.*,-                       old-locale ==1.*,-                       path-pieces >=0.1.4,-                       pool-conduit ==0.1.*,-                       random ==1.*,-                       regex-compat ==0.95.*,-                       resource-pool ==0.2.*,-                       resourcet >= 0.4 && < 1.2,-                       stm ==2.4.*,-                       text >= 0.11.3.1 && < 1.2,-                       time ==1.4.*,-                       transformers ==0.3.*,-                       transformers-base ==0.4.*,-                       unordered-containers ==0.2.*,-                       vault ==0.3.*,+                       hspec2 >=0.4 && <0.5,                        vector ==0.10.*,-                       wai >=3.0 && <4.0,-                       wai-extra >=3.0 && <4.0,-                       warp >=3.0 && <4.0,-                       xsd ==0.4.*+                       unordered-containers ==0.2.*   ghc-options: -Wall -fno-warn-orphans  source-repository head

@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import Test.Framework-import {-@ HTF_TESTS @-} Tests.Routing-import {-@ HTF_TESTS @-} Tests.Wire--main :: IO ()-main = htfMain htf_importedTests

@@ -1,86 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE OverloadedStrings #-}-module Tests.Routing (htf_thisModulesTests) where--import Test.Framework--import Web.Spock.Routing-import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HM--test_matchNode :: IO ()-test_matchNode =-    do assertEqual (False, Nothing) (matchNode "foo" (RouteNodeRoot))-       assertEqual (True, Just (CaptureVar "x", "123")) (matchNode "123" (RouteNodeCapture (CaptureVar "x")))-       assertEqual (True, Just (CaptureVar "x", "123")) (matchNode "123" (RouteNodeRegex (CaptureVar "x") (buildRegex "^[0-9]+$")))--test_matchRoute :: IO ()-test_matchRoute =-    do assertEqual noMatches (matchRoute "random" routingTree)-       assertEqual (oneMatch emptyParamMap [1]) (matchRoute "/" routingTree)-       assertEqual noMatches (matchRoute "/baz" routingTree)-       assertEqual (oneMatch emptyParamMap [2]) (matchRoute "/bar" routingTree)-       assertEqual (oneMatch (vMap [("baz", "5")]) [3]) (matchRoute "/bar/5" routingTree)-       assertEqual multiMatch (matchRoute "/bar/bingo" routingTree)-       assertEqual (oneMatch (vMap [("baz", "23")]) [4]) (matchRoute "/bar/23/baz" routingTree)-       assertEqual (oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]) (matchRoute "/bar/23/baz/100" routingTree)-       assertEqual (oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]) (matchRoute "/ba/23/100" routingTree)-       assertEqual (oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6]) (matchRoute "/entry/344/2014-20-14T12:23" routingTree)-       assertEqual (oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7]) (matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree)-       assertEqual multiMatch' (matchRoute "/entry/1/audit" routingTree)-       assertEqual (oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9]) (matchRoute "/entry/2/rel/3" routingTree)-    where-      vMap kv =-          HM.fromList $ map (\(k, v) -> (CaptureVar k, v)) kv-      multiMatch =-          ((oneMatch emptyParamMap [5])-            ++ oneMatch (vMap [("baz", "bingo")]) [3])-      multiMatch' =-          ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])-           ++ (oneMatch (vMap [("eid", "1")]) [8]))-      noMatches = []-      oneMatch pm m = [(pm, m)]-      routingTree =-          foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes-      routes =-          [ ("/", [1])-          , ("/bar", [2 :: Int])-          , ("/bar/:baz", [3])-          , ("/bar/bingo", [5])-          , ("/bar/:baz/baz", [4])-          , ("/bar/:baz/baz/:bim", [4])-          , ("/ba/:baz/:bim", [4])-          , ("/entry/:cid/:since", [6])-          , ("/entry/bytags/:cid/:since", [7])-          , ("/entry/:eid/audit", [8])-          , ("/entry/:eid/rel/:cid", [9])-          ]--test_parseRouteNode :: IO ()-test_parseRouteNode =-    do assertEqual (RouteNodeText "foo") (parseRouteNode "foo")-       assertEqual (RouteNodeCapture (CaptureVar "bar")) (parseRouteNode ":bar")-       assertEqual (RouteNodeRegex (CaptureVar "bar") (buildRegex "^[0-9]$")) (parseRouteNode "{bar:^[0-9]$}")--test_addToRoutingTree :: IO ()-test_addToRoutingTree =-    do assertEqual baseRoute (addToRoutingTree "/" [True] emptyT)-       assertEqual (fooBar []) (addToRoutingTree "/foo/:bar" [True] emptyT)-       assertEqual (fooBar baz) (addToRoutingTree "/foo/:bar/baz" [True] (fooBar []))-    where-      emptyT = emptyRoutingTree-      baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty}-      baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }]-      fooBar xs =-          RoutingTree-          { rt_node =-                RouteData {rd_node = RouteNodeRoot, rd_data = Nothing }-          , rt_children =-              V.fromList-                   [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing}-                                 , rt_children =-                                     V.fromList-                                          [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (CaptureVar "bar")-                                                                              , rd_data = Just [True]-                                                                              }-                                                        , rt_children = V.fromList xs}]}]}

@@ -26,6 +26,8 @@       -- * Sessions     , SessionCfg (..)     , readSession, writeSession, modifySession, clearAllSessions+      -- * Basic HTTP-Auth+    , requireBasicAuth       -- * Safe actions     , SafeAction (..)     , safeActionPath@@ -44,7 +46,6 @@ import Web.Spock.Types import qualified Web.Spock.Core as C -import Control.Applicative import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Pool@@ -58,15 +59,13 @@     do sessionMgr <- createSessionManager sessionCfg        connectionPool <-            case poolOrConn of-             PCConduitPool p ->-                 return (ConduitPool p)              PCPool p ->-                 return (DataPool p)+                 return p              PCConn cb ->                  let pc = cb_poolConfiguration cb-                 in DataPool <$> createPool (cb_createConn cb) (cb_destroyConn cb)-                                  (pc_stripes pc) (pc_keepOpenTime pc)-                                   (pc_resPerStripe pc)+                 in createPool (cb_createConn cb) (cb_destroyConn cb)+                        (pc_stripes pc) (pc_keepOpenTime pc)+                        (pc_resPerStripe pc)        let internalState =                WebState                { web_dbConn = connectionPool

@@ -11,6 +11,7 @@     , setCookie, setCookie'     , bytes, lazyBytes, text, html, file, json, blaze     , combineRoute, subcomponent+    , requireBasicAuth     ) where @@ -19,6 +20,7 @@ import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State hiding (get, put)+import Data.Monoid import Data.Time import Network.HTTP.Types.Method import Network.HTTP.Types.Status@@ -31,6 +33,7 @@ import Web.Spock.Wire import qualified Data.Aeson as A import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BSL import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as HM@@ -244,3 +247,33 @@ blaze val =     do setHeader "Content-Type" "text/html"        lazyBytes $ renderHtml val++-- | Basic authentification+-- provide a title for the prompt and a function to validate+-- user and password. Usage example:+--+-- > get "/my-secret-page" $+-- >   requireBasicAuth "Secret Page" (\user pass -> return (user == "admin" && pass == "1234")) $+-- >   do html "This is top secret content. Login using that secret code I provided ;-)"+--+requireBasicAuth :: MonadIO m => T.Text -> (T.Text -> T.Text -> m Bool) -> ActionT m a -> ActionT m a+requireBasicAuth realmTitle authFun cont =+    do mAuthHeader <- header "Authorization"+       case mAuthHeader of+         Nothing ->+             authFailed+         Just authHeader ->+             let (_, rawValue) =+                     T.breakOn " " authHeader+                 (user, rawPass) =+                     (T.breakOn ":" . T.decodeUtf8 . B64.decodeLenient . T.encodeUtf8 . T.strip) rawValue+                 pass = T.drop 1 rawPass+             in do isOk <- lift $ authFun user pass+                   if isOk+                   then cont+                   else authFailed+    where+      authFailed =+          do setStatus status401+             setHeader "WWW-Authenticate" ("Basic realm=\"" <> realmTitle <> "\"")+             html "<h1>Authentication required.</h1>"

@@ -13,7 +13,6 @@ import Data.Time.Clock ( UTCTime(..) ) import Web.PathPieces import qualified Data.ByteString.Lazy as BSL-import qualified Data.Conduit.Pool as CP import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Text.XML.XSD.DateTime as XSD@@ -40,13 +39,7 @@ runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a runQueryImpl query =     do pool <- asks web_dbConn-       let fun =-               case pool of-                 DataPool p ->-                     withResource p-                 ConduitPool p ->-                     CP.withResource p-       liftIO (fun query)+       liftIO (withResource pool $ query)  getStateImpl :: WebStateM conn sess st st getStateImpl = asks web_state

@@ -7,8 +7,9 @@  import Web.Spock.Core import Web.Spock.Types-import Network.HTTP.Types.Status +import Data.Monoid+import Network.HTTP.Types.Status import qualified Data.Text as T  -- | Wire up a safe action: Safe actions are actions that are protected from@@ -22,9 +23,9 @@ -- >          redirect "/user-list" -- > -- > get "/user-details/:userId" $--- >   do userId <- param "userId"+-- >   do userId <- param' "userId" -- >      deleteUrl <- safeActionPath (DeleteUser userId)--- >      html $ TL.concat [ "Click <a href='", TL.fromStrict deleteUrl, "'>here</a> to delete user!" ]+-- >      html $ "Click <a href='" <> deleteUrl <> "'>here</a> to delete user!" -- -- Note that safeActions currently only support GET and POST requests. --@@ -39,7 +40,7 @@ safeActionPath safeAction =     do mgr <- getSessMgr        hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)-       return $ T.concat [ "/h/", hash ]+       return $ "/h/" <> hash  hookSafeActions :: forall conn sess st.                    ( HasSpock (SpockAction conn sess st)

@@ -19,7 +19,6 @@ import Data.Time.Clock ( UTCTime(..), NominalDiffTime ) import Data.Typeable import Network.Wai-import qualified Data.Conduit.Pool as CP import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -51,7 +50,6 @@ -- a connection pool. See 'ConnBuilder' data PoolOrConn a    = PCPool (Pool a)-   | PCConduitPool (CP.Pool a)    | PCConn (ConnBuilder a)  -- | Configuration for the session manager@@ -63,13 +61,9 @@    , sc_emptySession :: a    } -data ConnectionPool conn-   = DataPool (Pool conn)-   | ConduitPool (CP.Pool conn)- data WebState conn sess st    = WebState-   { web_dbConn :: ConnectionPool conn+   { web_dbConn :: Pool conn    , web_sessionMgr :: SessionManager conn sess st    , web_state :: st    }

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.RoutingSpec (spec) where++import Test.Hspec++import Web.Spock.Routing+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM++spec :: Spec+spec =+    do matchNodeDesc+       matchRouteDesc+       parseRouteNodeDesc+       addToRoutingTreeDesc++matchNodeDesc :: Spec+matchNodeDesc =+    describe "matchNode" $+    do it "shouldn't match to root node" $+          matchNode "foo" RouteNodeRoot `shouldBe` (False, Nothing)+       it "should capture basic variables" $+          matchNode "123" (RouteNodeCapture (CaptureVar "x")) `shouldBe` (True, Just (CaptureVar "x", "123"))+       it "should work with regex" $+          matchNode "123" (RouteNodeRegex (CaptureVar "x") (buildRegex "^[0-9]+$")) `shouldBe` (True, Just (CaptureVar "x", "123"))++matchRouteDesc :: Spec+matchRouteDesc =+    describe "matchRoute" $+    do it "shouldn't match unknown routes" $+          do matchRoute "random" routingTree `shouldBe` noMatches+             matchRoute "/baz" routingTree `shouldBe` noMatches+       it "should match known routes" $+          do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1]+             matchRoute "/bar" routingTree `shouldBe` oneMatch emptyParamMap [2]+       it "should capture variables in routes" $+          do matchRoute "/bar/5" routingTree `shouldBe` oneMatch (vMap [("baz", "5")]) [3]+             matchRoute "/bar/23/baz" routingTree `shouldBe` oneMatch (vMap [("baz", "23")]) [4]+             matchRoute "/bar/23/baz/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]+             matchRoute "/ba/23/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4]+             matchRoute "/entry/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6]+             matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7]+             matchRoute "/entry/2/rel/3" routingTree `shouldBe` oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9]+       it "should handle multiple possibile matches correctly" $+          do matchRoute "/bar/bingo" routingTree `shouldBe` multiMatch+             matchRoute "/entry/1/audit" routingTree `shouldBe` multiMatch'+    where+      vMap kv =+          HM.fromList $ map (\(k, v) -> (CaptureVar k, v)) kv+      multiMatch =+          ((oneMatch emptyParamMap [5])+            ++ oneMatch (vMap [("baz", "bingo")]) [3])+      multiMatch' =+          ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])+           ++ (oneMatch (vMap [("eid", "1")]) [8]))+      noMatches = []+      oneMatch pm m = [(pm, m)]+      routingTree =+          foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes+      routes =+          [ ("/", [1])+          , ("/bar", [2 :: Int])+          , ("/bar/:baz", [3])+          , ("/bar/bingo", [5])+          , ("/bar/:baz/baz", [4])+          , ("/bar/:baz/baz/:bim", [4])+          , ("/ba/:baz/:bim", [4])+          , ("/entry/:cid/:since", [6])+          , ("/entry/bytags/:cid/:since", [7])+          , ("/entry/:eid/audit", [8])+          , ("/entry/:eid/rel/:cid", [9])+          ]++parseRouteNodeDesc :: Spec+parseRouteNodeDesc =+    describe "parseRouteNode" $+    do it "parses text nodes correctly" $+          parseRouteNode "foo" `shouldBe` RouteNodeText "foo"+       it "parses capture variables" $+          parseRouteNode ":bar" `shouldBe` RouteNodeCapture (CaptureVar "bar")+       it "parses regex capture variables" $+          parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (CaptureVar "bar") (buildRegex "^[0-9]$")++addToRoutingTreeDesc :: Spec+addToRoutingTreeDesc =+    describe "addToRoutingTree" $+    do it "adds the root node correctly" $+          addToRoutingTree "/" [True] emptyT `shouldBe` baseRoute+       it "adds a new branch correctly" $+          addToRoutingTree "/foo/:bar" [True] emptyT `shouldBe` fooBar []+       it "add a new subbranch correctly" $+          addToRoutingTree "/foo/:bar/baz" [True] (fooBar []) `shouldBe` fooBar baz+    where+      emptyT = emptyRoutingTree+      baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty}+      baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }]+      fooBar xs =+          RoutingTree+          { rt_node =+                RouteData {rd_node = RouteNodeRoot, rd_data = Nothing }+          , rt_children =+              V.fromList+                   [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing}+                                 , rt_children =+                                     V.fromList+                                          [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (CaptureVar "bar")+                                                                              , rd_data = Just [True]+                                                                              }+                                                        , rt_children = V.fromList xs}]}]}

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.WireSpec (spec) where++import Web.Spock.Wire+import Test.Hspec++spec :: Spec+spec =+    do describe "combineRoute" $+         do it "handles slashes correctly" $+               do ("/" `combineRoute`  "foo") `shouldBe` "/foo"+                  ("" `combineRoute`  "foo") `shouldBe` "/foo"+                  ("/" `combineRoute`  "/foo") `shouldBe` "/foo"+                  ("" `combineRoute`  "/foo") `shouldBe` "/foo"+                  ("/test" `combineRoute`  "foo") `shouldBe` "/test/foo"+                  ("/test" `combineRoute`  "") `shouldBe` "/test"