diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013 - 2014, Alexander Thiemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Thiemann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,10 +1,11 @@ name: Spock -version: 0.7.5.2 +version: 0.7.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: fast routing, middleware, json, blaze, sessions, cookies, database helper, csrf-protection +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 Bug-reports: https://github.com/agrafix/Spock/issues license: BSD3 +license-file: LICENSE author: Alexander Thiemann maintainer: Alexander Thiemann copyright: (c) 2013 - 2014 Alexander Thiemann @@ -23,7 +24,6 @@ other-modules: Web.Spock.Internal.Core, Web.Spock.Internal.CoreAction, - Web.Spock.Internal.Digestive, Web.Spock.Internal.Monad, Web.Spock.Internal.SessionManager, Web.Spock.Internal.Types, @@ -32,11 +32,9 @@ aeson >= 0.6.2.1, base >= 4 && < 5, base64-bytestring >=1.0, - blaze-html >=0.7, bytestring >=0.10, case-insensitive >=1.1, containers >=0.5, - digestive-functors >=0.7, directory >=1.2, hashable >=1.2, http-types >=0.8, @@ -58,7 +56,7 @@ wai >=3.0, wai-extra >=3.0, warp >=3.0 - ghc-options: -Wall -fno-warn-orphans + ghc-options: -auto-all -Wall -fno-warn-orphans test-suite spocktests type: exitcode-stdio-1.0 @@ -79,6 +77,15 @@ wai ghc-options: -Wall -fno-warn-orphans + +benchmark spock-simple-example + type: exitcode-stdio-1.0 + ghc-options: -auto-all -Wall -O2 + hs-source-dirs: examples/simple + main-is: Main.hs + build-depends: + base, + Spock source-repository head type: git diff --git a/examples/simple/Main.hs b/examples/simple/Main.hs new file mode 100644 --- /dev/null +++ b/examples/simple/Main.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Web.Spock.Safe + +main :: IO () +main = + runSpock 8080 $ spockT id $ + do get "foo" $ + text "bar" + get ("hello" var) $ \name -> + text name 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 @@ -8,14 +8,14 @@ , files, params, param, param', setStatus, setHeader, redirect , jumpNext, middlewarePass, modifyVault, queryVault , setCookie, setCookie' - , bytes, lazyBytes, text, html, file, json, blaze + , bytes, lazyBytes, text, html, file, json , requireBasicAuth , preferredFormat, ClientPreferredFormat(..) ) where -import Web.Spock.Internal.Wire import Web.Spock.Internal.Util +import Web.Spock.Internal.Wire import Control.Arrow (first) import Control.Monad @@ -27,8 +27,6 @@ import Network.HTTP.Types.Status import Prelude hiding (head) import System.Locale -import Text.Blaze.Html (Html) -import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Web.PathPieces import Web.Routing.AbstractRouter import qualified Data.Aeson as A @@ -82,12 +80,14 @@ then return chunks else parseAll (chunks `BS.append` bs) parseAll BS.empty +{-# INLINE body #-} -- | Parse the request body as json jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a) jsonBody = do b <- body return $ A.decodeStrict b +{-# INLINE jsonBody #-} -- | Parse the request body as json and fails with 500 status code on error jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a @@ -99,11 +99,13 @@ text (T.pack $ "Failed to parse json: " ++ err) Right val -> return val +{-# INLINE jsonBody' #-} -- | Get uploaded files files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile) files = asks ri_files +{-# INLINE files #-} -- | Get all request params params :: MonadIO m => ActionT m [(T.Text, T.Text)] @@ -143,19 +145,27 @@ setStatus :: MonadIO m => Status -> ActionT m () setStatus s = modify $ \rs -> rs { rs_status = s } +{-# INLINE setStatus #-} -- | Set a response header. Overwrites already defined headers setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () setHeader k v = - modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) } + modify $ \rs -> + rs + { rs_responseHeaders = + HM.insert (CI.mk $ T.encodeUtf8 k) (T.encodeUtf8 v) (rs_responseHeaders rs) + } +{-# INLINE setHeader #-} -- | Abort the current action and jump the next one matching the route jumpNext :: MonadIO m => ActionT m a jumpNext = throwError ActionTryNext +{-# INLINE jumpNext #-} -- | Redirect to a given url redirect :: MonadIO m => T.Text -> ActionT m a redirect = throwError . ActionRedirect +{-# INLINE redirect #-} -- | If the Spock application is used as a middleware, you can use -- this to pass request handeling to the underlying application. @@ -163,6 +173,7 @@ -- this will result in 404 error. middlewarePass :: MonadIO m => ActionT m a middlewarePass = throwError ActionMiddlewarePass +{-# INLINE middlewarePass #-} -- | Modify the vault (useful for sharing data between middleware and app) modifyVault :: MonadIO m => (V.Vault -> V.Vault) -> ActionT m () @@ -202,24 +213,28 @@ bytes :: MonadIO m => BS.ByteString -> ActionT m a bytes val = lazyBytes $ BSL.fromStrict val +{-# INLINE bytes #-} -- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type" lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a lazyBytes val = do modify $ \rs -> rs { rs_responseBody = ResponseLBS val } throwError ActionDone +{-# INLINE lazyBytes #-} -- | Send text as a response body. Content-Type will be "text/plain" text :: MonadIO m => T.Text -> ActionT m a text val = do setHeader "Content-Type" "text/plain; charset=utf-8" bytes $ T.encodeUtf8 val +{-# INLINE text #-} -- | Send a text as response body. Content-Type will be "text/html" html :: MonadIO m => T.Text -> ActionT m a html val = do setHeader "Content-Type" "text/html; charset=utf-8" bytes $ T.encodeUtf8 val +{-# INLINE html #-} -- | Send a file as response file :: MonadIO m => T.Text -> FilePath -> ActionT m a @@ -227,18 +242,14 @@ do setHeader "Content-Type" contentType modify $ \rs -> rs { rs_responseBody = ResponseFile filePath } throwError ActionDone +{-# INLINE file #-} -- | Send json as response. Content-Type will be "application/json" json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b json val = do setHeader "Content-Type" "application/json; charset=utf-8" lazyBytes $ A.encode val - --- | Send blaze html as response. Content-Type will be "text/html" -blaze :: MonadIO m => Html -> ActionT m a -blaze val = - do setHeader "Content-Type" "text/html; charset=utf-8" - lazyBytes $ renderHtml val +{-# INLINE json #-} -- | Basic authentification -- provide a title for the prompt and a function to validate diff --git a/src/Web/Spock/Internal/Digestive.hs b/src/Web/Spock/Internal/Digestive.hs deleted file mode 100644 --- a/src/Web/Spock/Internal/Digestive.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse #-} -module Web.Spock.Internal.Digestive - ( runForm ) -where - -import Web.Spock.Internal.CoreAction - -import Control.Applicative -import Control.Monad.Trans -import Network.HTTP.Types -import Network.Wai -import Text.Digestive.Form -import Text.Digestive.Types -import Text.Digestive.View -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T - --- | Run a digestive functors form -runForm :: (Functor m, MonadIO m) - => T.Text -- ^ form name - -> Form v (ActionT m) a - -> ActionT m (View v, Maybe a) -runForm formName form = - do httpMethod <- requestMethod <$> request - if httpMethod == methodGet - then do f <- getForm formName form - return (f, Nothing) - else postForm formName form (const $ return localEnv) - where - localEnv path = - do let name = fromPath $ path - applyParam f = - map (f . snd) . filter ((== name) . fst) - vars <- (applyParam (TextInput)) <$> params - sentFiles <- (applyParam (FileInput . T.unpack . uf_name) . HM.toList) <$> files - return (vars ++ sentFiles) 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 @@ -14,6 +14,7 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans +import Data.List (foldl') import Data.Time import System.Locale import System.Random @@ -30,9 +31,10 @@ createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st) createSessionManager cfg = - do cacheHM <- atomically $ newTVar HM.empty + do oldSess <- loadSessions + cacheHM <- atomically $ newTVar oldSess vaultKey <- V.newKey - _ <- forkIO (forever (housekeepSessions cacheHM)) + _ <- forkIO (forever (housekeepSessions cacheHM storeSessions)) return $ SessionManager { sm_getSessionId = getSessionIdImpl vaultKey cacheHM , sm_readSession = readSessionImpl vaultKey cacheHM @@ -44,6 +46,30 @@ , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM } + where + (loadSessions, storeSessions) = + case sc_persistCfg cfg of + Nothing -> + ( return HM.empty + , const $ return () + ) + Just spc -> + ( do sessions <- spc_load spc + return $ foldl' genSession HM.empty sessions + , \hm -> + spc_store spc $ map mkSerializable $ HM.elems hm + ) + mkSerializable sess = + (sess_id sess, sess_validUntil sess, sess_data sess) + genSession hm (sid, validUntil, theData) = + let s = + Session + { sess_id = sid + , sess_validUntil = validUntil + , sess_data = theData + , sess_safeActions = SafeActionStore HM.empty HM.empty + } + in HM.insert sid s hm getSessionIdImpl :: V.Key SessionId -> UserSessions conn sess st @@ -232,10 +258,16 @@ clearAllSessionsImpl sessionRef = liftIO $ atomically $ modifyTVar' sessionRef (const HM.empty) -housekeepSessions :: UserSessions conn sess st -> IO () -housekeepSessions sessionRef = +housekeepSessions :: UserSessions conn sess st + -> (HM.HashMap SessionId (Session conn sess st) -> IO ()) + -> IO () +housekeepSessions sessionRef storeSessions = do now <- getCurrentTime - atomically $ modifyTVar' sessionRef (killOld now) + newStatus <- + atomically $ + do modifyTVar' sessionRef (killOld now) + readTVar sessionRef + storeSessions newStatus threadDelay (1000 * 1000 * 60) -- 60 seconds where filterOld now (_, sess) = diff --git a/src/Web/Spock/Internal/Types.hs b/src/Web/Spock/Internal/Types.hs --- a/src/Web/Spock/Internal/Types.hs +++ b/src/Web/Spock/Internal/Types.hs @@ -62,6 +62,13 @@ , sc_sessionTTL :: NominalDiffTime , sc_sessionIdEntropy :: Int , sc_emptySession :: a + , sc_persistCfg :: Maybe (SessionPersistCfg a) + } + +data SessionPersistCfg a + = SessionPersistCfg + { spc_load :: IO [(SessionId, UTCTime, a)] + , spc_store :: [(SessionId, UTCTime, a)] -> IO () } data WebState conn sess st 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 @@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Web.Spock.Internal.Wire where import Control.Applicative @@ -41,9 +42,9 @@ data UploadedFile = UploadedFile - { uf_name :: T.Text - , uf_contentType :: T.Text - , uf_tempLocation :: FilePath + { uf_name :: !T.Text + , uf_contentType :: !T.Text + , uf_tempLocation :: !FilePath } data VaultIf @@ -64,18 +65,18 @@ data ResponseBody = ResponseFile FilePath | ResponseLBS BSL.ByteString - | ResponseRedirect T.Text + | ResponseRedirect !T.Text deriving (Show, Eq) data ResponseState = ResponseState - { rs_responseHeaders :: [(T.Text, T.Text)] - , rs_status :: Status - , rs_responseBody :: ResponseBody + { rs_responseHeaders :: !(HM.HashMap (CI.CI BS.ByteString) BS.ByteString) + , rs_status :: !Status + , rs_responseBody :: !ResponseBody } deriving (Show, Eq) data ActionInterupt - = ActionRedirect T.Text + = ActionRedirect !T.Text | ActionTryNext | ActionError String | ActionDone @@ -103,12 +104,14 @@ ResponseRedirect target -> Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty where - waiHeaders = map (\(k, v) -> (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)) headers + waiHeaders = + HM.toList headers errorResponse :: Status -> BSL.ByteString -> ResponseState errorResponse s e = ResponseState - { rs_responseHeaders = [("Content-Type", "text/html")] + { rs_responseHeaders = + HM.singleton "Content-Type" "text/html" , rs_status = s , rs_responseBody = ResponseLBS $ @@ -144,6 +147,93 @@ fallbackApp _ respond = respond $ notFound +makeActionEnvironment :: InternalState -> Wai.Request -> IO (ParamMap -> RequestInfo, TVar V.Vault, IO ()) +makeActionEnvironment st req = + do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req + 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) + } + uploadedFiles = + HM.fromList $ + map (\(k, fileInfo) -> + ( T.decodeUtf8 k + , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo) + ) + ) bodyFiles + postParams = + map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams + getParams = + map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req + queryParams = postParams ++ getParams + return ( \params -> + RequestInfo + { ri_request = req + , ri_params = params + , ri_queryParams = queryParams + , ri_files = uploadedFiles + , ri_vaultIf = vaultIf + } + , vaultVar + , removeUploadedFiles uploadedFiles + ) + +removeUploadedFiles :: HM.HashMap k UploadedFile -> IO () +removeUploadedFiles uploadedFiles = + forM_ (HM.elems uploadedFiles) $ \uploadedFile -> + do stillThere <- doesFileExist (uf_tempLocation uploadedFile) + when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile) + +applyAction :: MonadIO m + => Wai.Request + -> (ParamMap -> RequestInfo) + -> [(ParamMap, ActionT m ())] + -> m (Maybe ResponseState) +applyAction _ _ [] = + return $ Just $ errorResponse status404 "404 - File not found" +applyAction req mkEnv ((captures, selectedAction) : xs) = + do let env = mkEnv captures + defResp = errorResponse status200 "" + (r, respState, _) <- + runRWST (runErrorT $ runActionT $ selectedAction) env defResp + case r of + Left (ActionRedirect loc) -> + return $ Just $ ResponseState (rs_responseHeaders respState) status302 (ResponseRedirect loc) + Left ActionTryNext -> + applyAction req mkEnv xs + Left (ActionError errorMsg) -> + do liftIO $ putStrLn $ "Spock Error while handeling " + ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg + return $ Just serverError + Left ActionDone -> + return $ Just respState + Left ActionMiddlewarePass -> + return Nothing + Right () -> + return $ Just respState + +handleRequest :: MonadIO m => (forall a. m a -> IO a) + -> [(ParamMap, ActionT m ())] + -> InternalState + -> Wai.Application -> Wai.Application +handleRequest registryLift allActions st coreApp req respond = + do (mkEnv, vaultVar, cleanUp) <- makeActionEnvironment st req + mRespState <- + (registryLift $ applyAction req mkEnv allActions) + `catch` \(e :: SomeException) -> + do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e + return $ Just serverError + cleanUp + case mRespState of + Just respState -> + respond $ respStateToResponse respState + Nothing -> + do newVault <- atomically $ readTVar vaultVar + let req' = req { Wai.vault = V.union newVault (Wai.vault req) } + coreApp req' respond + buildMiddleware :: forall m r. (MonadIO m, AbstractRouter r, RouteAppliedAction r ~ ActionT m ()) => r -> (forall a. m a -> IO a) @@ -159,66 +249,7 @@ Left _ -> respond invalidReq Right stdMethod -> - runResourceT $ - withInternalState $ \st -> - do (bodyParams, bodyFiles) <- P.parseRequestBody (P.tempFileBackEnd st) req - 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) - } - uploadedFiles = - HM.fromList $ - map (\(k, fileInfo) -> - ( T.decodeUtf8 k - , UploadedFile (T.decodeUtf8 $ P.fileName fileInfo) (T.decodeUtf8 $ P.fileContentType fileInfo) (P.fileContent fileInfo) - ) - ) bodyFiles - postParams = - map (\(k, v) -> (T.decodeUtf8 k, T.decodeUtf8 v)) bodyParams - getParams = - map (\(k, mV) -> (T.decodeUtf8 k, T.decodeUtf8 $ fromMaybe BS.empty mV)) $ Wai.queryString req - queryParams = postParams ++ getParams - resp = errorResponse status200 "" - allActions = getMatchingRoutes stdMethod (Wai.pathInfo req) - applyAction :: [(ParamMap, ActionT m ())] -> m (Maybe ResponseState) - applyAction [] = - return $ Just $ errorResponse status404 "404 - File not found" - applyAction ((captures, selectedAction) : xs) = - do let env = RequestInfo req captures queryParams uploadedFiles vaultIf - (r, respState, _) <- - runRWST (runErrorT $ runActionT $ selectedAction) env resp - case r of - Left (ActionRedirect loc) -> - return $ Just $ ResponseState (rs_responseHeaders respState) - status302 (ResponseRedirect loc) - Left ActionTryNext -> - applyAction xs - Left (ActionError errorMsg) -> - do liftIO $ putStrLn $ "Spock Error while handeling " - ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg - return $ Just serverError - Left ActionDone -> - return $ Just respState - Left ActionMiddlewarePass -> - return Nothing - Right () -> - return $ Just respState - mRespState <- - liftIO $ (registryLift $ applyAction allActions) - `catch` \(e :: SomeException) -> - do putStrLn $ "Spock Error while handeling " ++ show (Wai.pathInfo req) ++ ": " ++ show e - return $ Just serverError - case mRespState of - Just respState -> - do forM_ (HM.elems uploadedFiles) $ \uploadedFile -> - do stillThere <- doesFileExist (uf_tempLocation uploadedFile) - when stillThere $ liftIO $ removeFile (uf_tempLocation uploadedFile) - liftIO $ respond $ respStateToResponse respState - Nothing -> - liftIO $ - do newVault <- atomically $ readTVar vaultVar - let req' = req { Wai.vault = V.union newVault (Wai.vault req) } - coreApp req' respond + do let allActions = getMatchingRoutes stdMethod (Wai.pathInfo req) + runResourceT $ withInternalState $ \st -> + handleRequest registryLift allActions st coreApp req respond return $ spockMiddleware . app 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 @@ -8,11 +8,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} module Web.Spock.Safe - ( -- * Spock's core - spock, SpockM, SpockAction - , spockT, SpockT, ActionT + ( -- * Spock's route definition monad + spock, SpockM + , spockT, SpockT -- * Defining routes - , Path, root, var, static, () + , Path, root, var, static, () -- * Rendering routes , renderRoute -- * Hooking routes @@ -30,7 +30,6 @@ import Web.Spock.Shared -import Web.Spock.Internal.CoreAction import Web.Spock.Internal.Types import qualified Web.Spock.Internal.Core as C @@ -175,3 +174,7 @@ Just p@(PackedSafeAction action) -> do runSafeAction action (sm_removeSafeAction mgr) p + +-- | Combine two path components +() :: Path as -> Path bs -> Path (Append as bs) +() = () 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 @@ -10,6 +10,8 @@ module Web.Spock.Shared (-- * Helpers for running Spock runSpock, spockAsApp + -- * Action types + , SpockAction, ActionT -- * Handeling requests , request, header, cookie , preferredFormat, ClientPreferredFormat(..) @@ -18,7 +20,7 @@ , params, param, param' -- * Sending responses , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes - , text, html, file, json, blaze + , text, html, file, json -- * Middleware helpers , middlewarePass, modifyVault, queryVault -- * Database @@ -28,21 +30,20 @@ -- * Basic HTTP-Auth , requireBasicAuth -- * Sessions - , SessionCfg (..), SessionId + , SessionCfg (..), SessionPersistCfg(..), SessionId + , readShowSessionPersist , getSessionId, readSession, writeSession, modifySession, clearAllSessions - -- * Digestive Functors - , runForm -- * Internals for extending Spock , getSpockHeart, runSpockIO, WebStateM, WebState ) where import Web.Spock.Internal.Monad -import Web.Spock.Internal.Digestive import Web.Spock.Internal.SessionManager import Web.Spock.Internal.Types import Web.Spock.Internal.CoreAction import Control.Monad +import System.Directory import qualified Web.Spock.Internal.Wire as W import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp @@ -90,3 +91,18 @@ clearAllSessions = do mgr <- getSessMgr sm_clearAllSessions mgr + +-- | Simple session persisting configuration. DO NOT USE IN PRODUCTION +readShowSessionPersist :: (Read a, Show a) => FilePath -> SessionPersistCfg a +readShowSessionPersist fp = + SessionPersistCfg + { spc_load = + do isThere <- doesFileExist fp + if isThere + then do str <- readFile fp + return (read str) + else return [] + , spc_store = + \theData -> + writeFile fp (show theData) + } 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 @@ -7,11 +7,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} module Web.Spock.Simple - ( -- * Spock's core - spock, SpockM, SpockAction - , spockT, SpockT, ActionT + ( -- * Spock's route definition monad + spock, SpockM + , spockT, SpockT -- * Defining routes - , SpockRoute, (<#>) + , SpockRoute, () -- * Hooking routes , subcomponent , get, post, head, put, delete, patch, hookRoute, hookAny @@ -76,11 +76,11 @@ C.spockAllT TextRouter liftFun app -- | Combine two route components safely --- "/foo" <#> "/bar" ===> "/foo/bar" --- "foo" <#> "bar" ===> "/foo/bar" --- "foo <#> "/bar" ===> "/foo/bar" -(<#>) :: SpockRoute -> SpockRoute -> SpockRoute -(SpockRoute t) <#> (SpockRoute t') = SpockRoute $ combineRoute t t' +-- "/foo" "/bar" ===> "/foo/bar" +-- "foo" "bar" ===> "/foo/bar" +-- "foo "/bar" ===> "/foo/bar" +() :: SpockRoute -> SpockRoute -> SpockRoute +(SpockRoute t) (SpockRoute t') = SpockRoute $ combineRoute t t' -- | Specify an action that will be run when the HTTP verb 'GET' and the given route match get :: MonadIO m => SpockRoute -> ActionT m () -> SpockT m () 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 @@ -17,9 +17,9 @@ put "verb-test" $ text "PUT" delete "verb-test" $ text "DELETE" patch "verb-test" $ text "PATCH" - get ("param-test" var) $ \(i :: Int) -> + get ("param-test" var) $ \(i :: Int) -> text $ "int" <> (T.pack $ show i) - get ("param-test" "static") $ + get ("param-test" "static") $ text "static" subcomponent "/subcomponent" $ do get "foo" $ text "foo"