diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,8 +1,8 @@ name: Spock -version: 0.7.8.0 +version: 0.7.9.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: fast routing, middleware, json, sessions, cookies, database helper, csrf-protection -Homepage: https://github.com/agrafix/Spock +Homepage: http://www.spock.li Bug-reports: https://github.com/agrafix/Spock/issues license: BSD3 license-file: LICENSE @@ -69,10 +69,11 @@ Web.Spock.SimpleSpec build-depends: base, - hspec, - hspec-wai, + hspec >= 2.0, + hspec-wai >= 0.6, http-types, Spock, + reroute, text, wai diff --git a/src/Web/Spock/Internal/Core.hs b/src/Web/Spock/Internal/Core.hs --- a/src/Web/Spock/Internal/Core.hs +++ b/src/Web/Spock/Internal/Core.hs @@ -72,5 +72,4 @@ -> (forall a. m a -> IO a) -> SpockAllT r m () -> IO Wai.Middleware -spockAllT registryIf liftSpock routeDefs = - buildMiddleware registryIf liftSpock routeDefs +spockAllT = buildMiddleware diff --git a/src/Web/Spock/Internal/CoreAction.hs b/src/Web/Spock/Internal/CoreAction.hs --- a/src/Web/Spock/Internal/CoreAction.hs +++ b/src/Web/Spock/Internal/CoreAction.hs @@ -125,7 +125,7 @@ params = do p <- asks ri_params qp <- asks ri_queryParams - return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p)) + return (qp ++ map (first unCaptureVar) (HM.toList p)) {-# INLINE params #-} -- | Read a request param. Spock looks in route captures first, then in POST variables and at last in GET variables @@ -195,14 +195,14 @@ modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionT m () modifyVault f = do vaultIf <- asks ri_vaultIf - liftIO $ (vi_modifyVault vaultIf) f + liftIO $ vi_modifyVault vaultIf f {-# INLINE modifyVault #-} -- | Query the vault queryVault :: MonadIO m => V.Key a -> ActionT m (Maybe a) queryVault k = do vaultIf <- asks ri_vaultIf - liftIO $ (vi_lookupKey vaultIf) k + liftIO $ vi_lookupKey vaultIf k {-# INLINE queryVault #-} -- | Set a cookie living for a given number of seconds diff --git a/src/Web/Spock/Internal/Monad.hs b/src/Web/Spock/Internal/Monad.hs --- a/src/Web/Spock/Internal/Monad.hs +++ b/src/Web/Spock/Internal/Monad.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Web.Spock.Internal.Monad where import Web.Spock.Internal.Types @@ -18,8 +17,8 @@ type SpockState (t (WebStateM conn sess st)) = st type SpockSession (t (WebStateM conn sess st)) = sess runQuery a = webM $ runQueryImpl a - getState = webM $ getStateImpl - getSessMgr = webM $ getSessMgrImpl + getState = webM getStateImpl + getSessMgr = webM getSessMgrImpl instance HasSpock (WebStateM conn sess st) where type SpockConn (WebStateM conn sess st) = conn @@ -32,7 +31,7 @@ runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a runQueryImpl query = do pool <- asks web_dbConn - liftIO (withResource pool $ query) + liftIO (withResource pool query) getStateImpl :: WebStateM conn sess st st getStateImpl = asks web_state diff --git a/src/Web/Spock/Internal/SessionManager.hs b/src/Web/Spock/Internal/SessionManager.hs --- a/src/Web/Spock/Internal/SessionManager.hs +++ b/src/Web/Spock/Internal/SessionManager.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings, DoAndIfThenElse, RankNTypes #-} module Web.Spock.Internal.SessionManager ( createSessionManager , SessionId, Session(..), SessionManager(..) @@ -39,17 +39,18 @@ cacheHM <- atomically $ newTVar oldSess vaultKey <- V.newKey _ <- forkIO (forever (housekeepSessions cacheHM storeSessions)) - return $ SessionManager - { sm_getSessionId = getSessionIdImpl vaultKey cacheHM - , sm_readSession = readSessionImpl vaultKey cacheHM - , sm_writeSession = writeSessionImpl vaultKey cacheHM - , sm_modifySession = modifySessionImpl vaultKey cacheHM - , sm_clearAllSessions = clearAllSessionsImpl cacheHM - , sm_middleware = sessionMiddleware cfg vaultKey cacheHM - , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM - , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM - , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM - } + return + SessionManager + { sm_getSessionId = getSessionIdImpl vaultKey cacheHM + , sm_readSession = readSessionImpl vaultKey cacheHM + , sm_writeSession = writeSessionImpl vaultKey cacheHM + , sm_modifySession = modifySessionImpl vaultKey cacheHM + , sm_clearAllSessions = clearAllSessionsImpl cacheHM + , sm_middleware = sessionMiddleware cfg vaultKey cacheHM + , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM + , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM + , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM + } where (loadSessions, storeSessions) = case sc_persistCfg cfg of @@ -60,8 +61,7 @@ Just spc -> ( do sessions <- spc_load spc return $ foldl' genSession HM.empty sessions - , \hm -> - spc_store spc $ map mkSerializable $ HM.elems hm + , spc_store spc . map mkSerializable . HM.elems ) mkSerializable sess = (sess_id sess, sess_validUntil sess, sess_data sess) @@ -254,7 +254,7 @@ atomically $ modifyTVar' sessionRef (HM.insert sid expandedSession) return expandedSession else return sess - if (sess_validUntil sessWithPossibleExpansion) > now + if sess_validUntil sessWithPossibleExpansion > now then return $ Just sessWithPossibleExpansion else do deleteSessionImpl sessionRef sid return Nothing @@ -285,8 +285,7 @@ storeSessions newStatus threadDelay (1000 * 1000 * 60) -- 60 seconds where - filterOld now (_, sess) = - (sess_validUntil sess) > now + filterOld now (_, sess) = sess_validUntil sess > now killOld now hm = HM.fromList $ filter (filterOld now) $ HM.toList hm diff --git a/src/Web/Spock/Internal/Util.hs b/src/Web/Spock/Internal/Util.hs --- a/src/Web/Spock/Internal/Util.hs +++ b/src/Web/Spock/Internal/Util.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Spock.Internal.Util where +import Data.Maybe import Network.HTTP.Types import Network.Wai.Internal import qualified Data.Text as T @@ -16,7 +17,7 @@ mimeMapping :: HM.HashMap T.Text ClientPreferredFormat mimeMapping = - HM.fromList $ + HM.fromList [ ("application/json", PrefJSON) , ("text/javascript", PrefJSON) , ("text/json", PrefJSON) @@ -33,10 +34,7 @@ let (mimeTypeStr, _) = T.breakOn ";" t mimeTypes = map (T.toLower . T.strip) $ T.splitOn "," mimeTypeStr firstMatch [] = PrefUnknown - firstMatch (x:xs) = - case HM.lookup x mimeMapping of - Just pref -> pref - Nothing -> firstMatch xs + firstMatch (x:xs) = fromMaybe (firstMatch xs) (HM.lookup x mimeMapping) in firstMatch mimeTypes diff --git a/src/Web/Spock/Internal/Wire.hs b/src/Web/Spock/Internal/Wire.hs --- a/src/Web/Spock/Internal/Wire.hs +++ b/src/Web/Spock/Internal/Wire.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,6 +8,7 @@ {-# LANGUAGE TypeOperators #-} module Web.Spock.Internal.Wire where +import Control.Arrow ((***)) import Control.Applicative import Control.Concurrent.STM import Control.Exception @@ -142,8 +142,7 @@ mw fallbackApp where fallbackApp :: Wai.Application - fallbackApp _ respond = - respond $ notFound + fallbackApp _ respond = respond notFound makeActionEnvironment :: InternalState -> Wai.Request -> IO (ParamMap -> RequestInfo, TVar V.Vault, IO ()) makeActionEnvironment st req = @@ -151,8 +150,8 @@ vaultVar <- liftIO $ newTVarIO (Wai.vault req) let vaultIf = VaultIf - { vi_modifyVault = \modF -> atomically $ modifyTVar' vaultVar modF - , vi_lookupKey = \k -> V.lookup k <$> (atomically $ readTVar vaultVar) + { vi_modifyVault = atomically . modifyTVar' vaultVar + , vi_lookupKey = \k -> V.lookup k <$> atomically (readTVar vaultVar) } uploadedFiles = HM.fromList $ @@ -162,7 +161,7 @@ ) ) bodyFiles postParams = - map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams + map (T.decodeUtf8 *** T.decodeUtf8) bodyParams getParams = map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req queryParams = postParams ++ getParams @@ -195,7 +194,7 @@ do let env = mkEnv captures defResp = errorResponse status200 "" (r, respState, _) <- - runRWST (runErrorT $ runActionT $ selectedAction) env defResp + runRWST (runErrorT $ runActionT selectedAction) env defResp case r of Left (ActionRedirect loc) -> return $ Just $ ResponseState (rs_responseHeaders respState) status302 $ ResponseBody $ @@ -220,7 +219,7 @@ handleRequest registryLift allActions st coreApp req respond = do (mkEnv, vaultVar, cleanUp) <- makeActionEnvironment st req mRespState <- - (registryLift $ applyAction req mkEnv allActions) + registryLift (applyAction req mkEnv allActions) `catch` \(e :: SomeException) -> do putStrLn $ "Spock Error while handling " ++ show (Wai.pathInfo req) ++ ": " ++ show e return $ Just serverError diff --git a/src/Web/Spock/Safe.hs b/src/Web/Spock/Safe.hs --- a/src/Web/Spock/Safe.hs +++ b/src/Web/Spock/Safe.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Safe ( -- * Spock's route definition monad spock, SpockM , spockT, SpockT -- * Defining routes - , Path, root, var, static, () + , Path, root, Var, var, static, () -- * Rendering routes , renderRoute -- * Hooking routes @@ -39,7 +38,8 @@ import Data.HVect import Network.HTTP.Types.Method import Prelude hiding (head) -import Web.Routing.SafeRouting +import Web.Routing.SafeRouting hiding (renderRoute) +import qualified Web.Routing.SafeRouting as SR import qualified Data.Text as T import qualified Network.HTTP.Types as Http import qualified Network.Wai as Wai @@ -150,7 +150,7 @@ -> SpockAction conn sess st T.Text safeActionPath safeAction = do mgr <- getSessMgr - hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction) + hash <- sm_addSafeAction mgr (PackedSafeAction safeAction) return $ "/h/" <> hash hookSafeActions :: forall conn sess st. @@ -165,15 +165,19 @@ where run h = do mgr <- getSessMgr - mAction <- (sm_lookupSafeAction mgr) h + mAction <- sm_lookupSafeAction mgr h case mAction of Nothing -> do setStatus Http.status404 text "File not found" Just p@(PackedSafeAction action) -> do runSafeAction action - (sm_removeSafeAction mgr) p + sm_removeSafeAction mgr p -- | Combine two path components () :: Path as -> Path bs -> Path (Append as bs) () = () + +-- | Render a route applying path pieces +renderRoute :: HasRep as => Path as -> HVectElim as T.Text +renderRoute route = hVectCurry (T.cons '/' . SR.renderRoute route) diff --git a/src/Web/Spock/Shared.hs b/src/Web/Spock/Shared.hs --- a/src/Web/Spock/Shared.hs +++ b/src/Web/Spock/Shared.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Shared (-- * Helpers for running Spock runSpock, spockAsApp @@ -71,13 +69,13 @@ writeSession :: sess -> SpockAction conn sess st () writeSession d = do mgr <- getSessMgr - (sm_writeSession mgr) d + sm_writeSession mgr d -- | Modify the stored session modifySession :: (sess -> sess) -> SpockAction conn sess st () modifySession f = do mgr <- getSessMgr - (sm_modifySession mgr) f + sm_modifySession mgr f -- | Read the stored session readSession :: SpockAction conn sess st sess @@ -102,7 +100,5 @@ then do str <- readFile fp return (read str) else return [] - , spc_store = - \theData -> - writeFile fp (show theData) + , spc_store = writeFile fp . show } diff --git a/src/Web/Spock/Simple.hs b/src/Web/Spock/Simple.hs --- a/src/Web/Spock/Simple.hs +++ b/src/Web/Spock/Simple.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Simple ( -- * Spock's route definition monad spock, SpockM @@ -167,7 +166,7 @@ -> SpockAction conn sess st T.Text safeActionPath safeAction = do mgr <- getSessMgr - hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction) + hash <- sm_addSafeAction mgr (PackedSafeAction safeAction) return $ "/h/" <> hash hookSafeActions :: forall conn sess st. @@ -183,11 +182,11 @@ run = do Just h <- param "spock-csurf-protection" mgr <- getSessMgr - mAction <- (sm_lookupSafeAction mgr) h + mAction <- sm_lookupSafeAction mgr h case mAction of Nothing -> do setStatus Http.status404 text "File not found" Just p@(PackedSafeAction action) -> do runSafeAction action - (sm_removeSafeAction mgr) p + sm_removeSafeAction mgr p diff --git a/test/Web/Spock/SafeSpec.hs b/test/Web/Spock/SafeSpec.hs --- a/test/Web/Spock/SafeSpec.hs +++ b/test/Web/Spock/SafeSpec.hs @@ -20,13 +20,13 @@ get "test-slash" $ text "ok" get "/test-noslash" $ text "ok" get ("param-test" var) $ \(i :: Int) -> - text $ "int" <> (T.pack $ show i) + text $ "int" <> T.pack (show i) get ("param-test" "static") $ text "static" subcomponent "/subcomponent" $ do get "foo" $ text "foo" subcomponent "/subcomponent2" $ - do get "bar" $ text "bar" + get "bar" $ text "bar" get "preferred-format" $ do fmt <- preferredFormat case fmt of @@ -34,5 +34,24 @@ x -> text (T.pack (show x)) hookAny GET $ text . T.intercalate "/" +routeRenderingSpec :: Spec +routeRenderingSpec = + describe "Route Rendering" $ + do it "should work with argument-less routes" $ + do renderRoute "foo" `shouldBe` "/foo" + renderRoute "/foo" `shouldBe` "/foo" + renderRoute "/foo/" `shouldBe` "/foo" + renderRoute ("foo" "bar") `shouldBe` "/foo/bar" + it "should work with routes with args" $ + do let r1 = var :: Var Int + renderRoute r1 1 `shouldBe` "/1" + let r2 = "blog" (var :: Var Int) + renderRoute r2 2 `shouldBe` "/blog/2" + let r3 = "blog" (var :: Var Int) (var :: Var T.Text) + renderRoute r3 2 "BIIM" `shouldBe` "/blog/2/BIIM" + spec :: Spec -spec = describe "SafeRouting" $ frameworkSpec (spockAsApp $ spockT id app) +spec = + describe "SafeRouting" $ + do frameworkSpec (spockAsApp $ spockT id app) + routeRenderingSpec