diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -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 diff --git a/src/Tests.hs b/src/Tests.hs deleted file mode 100644 --- a/src/Tests.hs +++ /dev/null @@ -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 diff --git a/src/Tests/Routing.hs b/src/Tests/Routing.hs deleted file mode 100644 --- a/src/Tests/Routing.hs +++ /dev/null @@ -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}]}]} diff --git a/src/Web/Spock.hs b/src/Web/Spock.hs --- a/src/Web/Spock.hs +++ b/src/Web/Spock.hs @@ -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 diff --git a/src/Web/Spock/Core.hs b/src/Web/Spock/Core.hs --- a/src/Web/Spock/Core.hs +++ b/src/Web/Spock/Core.hs @@ -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 "

Authentication required.

" diff --git a/src/Web/Spock/Monad.hs b/src/Web/Spock/Monad.hs --- a/src/Web/Spock/Monad.hs +++ b/src/Web/Spock/Monad.hs @@ -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 diff --git a/src/Web/Spock/SafeActions.hs b/src/Web/Spock/SafeActions.hs --- a/src/Web/Spock/SafeActions.hs +++ b/src/Web/Spock/SafeActions.hs @@ -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 here to delete user!" ] +-- > html $ "Click here 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) diff --git a/src/Web/Spock/Types.hs b/src/Web/Spock/Types.hs --- a/src/Web/Spock/Types.hs +++ b/src/Web/Spock/Types.hs @@ -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 } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Web/Spock/RoutingSpec.hs b/test/Web/Spock/RoutingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Spock/RoutingSpec.hs @@ -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}]}]} diff --git a/test/Web/Spock/WireSpec.hs b/test/Web/Spock/WireSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Spock/WireSpec.hs @@ -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"