Browse files

Added SnapletInit type to provide type-system enforced guarantees tha…

…t the

user is correctly using nestSnaplet and makeSnaplet.
  • Loading branch information...
1 parent bab2579 commit 1e75145b9ed74d93dfdf06630688e5aae68505b6 @mightybyte mightybyte committed Jul 27, 2011
View
1 src/Snap/Snaplet.hs
@@ -66,6 +66,7 @@ module Snap.Snaplet
-- * Initializer
-- $initializer
, Initializer
+ , SnapletInit
, nestSnaplet
, nameSnaplet
View
2 src/Snap/Snaplet/HeistNoClass.hs
@@ -184,7 +184,7 @@ bindSnapletSplices l splices =
------------------------------------------------------------------------------
-- | The 'Initializer' for 'Heist'.
heistInit :: FilePath
- -> Initializer b e (Snaplet (Heist b))
+ -> SnapletInit b (Heist b)
heistInit templateDir =
makeSnaplet "heist" "" Nothing $ liftIO $ do
(cacheFunc, cts) <- mkCacheTag
View
21 src/Snap/Snaplet/Internal/Initializer.hs
@@ -174,10 +174,10 @@ makeSnaplet :: Text
-- value to Nothing doesn't preclude the snaplet from having files in
-- in the filesystem, it just means that they won't be copied there
-- automatically.
- -> Initializer b e a
+ -> Initializer b e e
-- ^ Snaplet initializer.
- -> Initializer b e (Snaplet a)
-makeSnaplet snapletId desc origFilesystemDir m = do
+ -> SnapletInit b e
+makeSnaplet snapletId desc origFilesystemDir m = SnapletInit $ do
modifyCfg $ \c -> if isNothing $ _scId c
then setL scId (Just snapletId) c else c
sid <- iGets (T.unpack . fromJust . _scId . _curConfig)
@@ -228,10 +228,12 @@ bracketInit m = do
nestSnaplet :: ByteString
-- ^ The root url for all the snaplet's routes. An empty string
-- gives the routes the same root as the parent snaplet's routes.
- -> Initializer b e (Snaplet a)
+ -> (e :-> Snaplet s)
+ -- ^ Lens identifying the snaplet
+ -> SnapletInit b s
-- ^ The initializer function for the subsnaplet.
- -> Initializer b e (Snaplet a)
-nestSnaplet rte snaplet = bracketInit $ do
+ -> Initializer b e (Snaplet s)
+nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do
curId <- iGets (_scId . _curConfig)
modifyCfg (modL scAncestry (fromJust curId:))
modifyCfg (modL scId (const Nothing))
@@ -249,10 +251,11 @@ nestSnaplet rte snaplet = bracketInit $ do
-- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@
nameSnaplet :: Text
-- ^ The snaplet name
- -> Initializer b e (Snaplet a)
+ -> SnapletInit b e
-- ^ The snaplet initializer function
- -> Initializer b e (Snaplet a)
-nameSnaplet nm m = modifyCfg (setL scId (Just nm)) >> m
+ -> SnapletInit b e
+nameSnaplet nm (SnapletInit m) = SnapletInit $
+ modifyCfg (setL scId (Just nm)) >> m
------------------------------------------------------------------------------
View
6 src/Snap/Snaplet/Internal/Types.hs
@@ -287,6 +287,12 @@ instance MonadSnaplet Initializer where
------------------------------------------------------------------------------
+-- | Opaque newtype which gives us compile-time guarantees that the user is
+-- using makeSnaplet and nestSnaplet correctly.
+newtype SnapletInit b e = SnapletInit (Initializer b e (Snaplet e))
+
+
+------------------------------------------------------------------------------
-- | Information needed to reload a site. Instead of having snaplets define
-- their own reload actions, we store the original site initializer and use it
-- instead.
View
12 src/Snap/Snaplet/Session/Backends/CookieSession.hs
@@ -5,10 +5,7 @@ module Snap.Snaplet.Session.Backends.CookieSession
( initCookieSessionManager ) where
-import Control.Arrow
-import Control.Exception
import Control.Monad.Reader
-import Control.Monad.State
import Data.ByteString (ByteString)
import Data.Generics
import Data.HashMap.Strict (HashMap)
@@ -17,7 +14,6 @@ import Data.Hashable (Hashable)
import Data.Serialize (Serialize)
import qualified Data.Serialize as S
import Data.Text (Text)
-import qualified Data.Text.Encoding as T
import Web.ClientSession
import Snap.Types (Snap)
@@ -32,9 +28,9 @@ type Session = HashMap Text Text
-- | This is what the 'Payload' will be for the CookieSession backend
-data CookieSession = CookieSession {
- csCSRFToken :: Text
- , csSession :: Session
+data CookieSession = CookieSession
+ { csCSRFToken :: Text
+ , csSession :: Session
} deriving (Eq, Show)
@@ -91,7 +87,7 @@ initCookieSessionManager
:: FilePath -- ^ Path to site-wide encryption key
-> ByteString -- ^ Session cookie name
-> Maybe Int -- ^ Session time-out (replay attack protection)
- -> Initializer b e (Snaplet SessionManager)
+ -> SnapletInit b SessionManager
initCookieSessionManager fp cn to =
makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies."
Nothing $ liftIO $ do
View
8 test/suite/Snap/Snaplet/App.hs
@@ -45,11 +45,11 @@ routeWithConfig = do
val <- liftIO $ lookup cfg "topConfigField"
writeText $ "routeWithConfig: " `T.append` fromJust val
-app :: Initializer App App (Snaplet App)
+app :: SnapletInit App App
app = makeSnaplet "app" "Test application" Nothing $ do
- hs <- nestSnaplet "heist" $ heistInit "templates"
- fs <- nestSnaplet "foo" $ fooInit
- bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit
+ hs <- nestSnaplet "heist" heist $ heistInit "templates"
+ fs <- nestSnaplet "foo" foo fooInit
+ bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit
addSplices
[("appsplice", liftHeist $ textSplice "contents of the app splice")]
addRoutes [ ("/hello", writeText "hello world")
View
4 test/suite/Snap/Snaplet/BarSnaplet.hs
@@ -17,8 +17,8 @@ import Text.Templating.Heist
data BarSnaplet = BarSnaplet { barField :: String }
-barInit :: HasHeist b e
- => Initializer b e (Snaplet BarSnaplet)
+barInit :: HasHeist b b
+ => SnapletInit b BarSnaplet
barInit = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do
config <- getSnapletConfig
addTemplates ""
View
2 test/suite/Snap/Snaplet/FooSnaplet.hs
@@ -16,7 +16,7 @@ import Text.Templating.Heist
data FooSnaplet = FooSnaplet { fooField :: String }
-fooInit :: HasHeist b e => Initializer b e (Snaplet FooSnaplet)
+fooInit :: HasHeist b FooSnaplet => SnapletInit b FooSnaplet
fooInit = makeSnaplet "foosnaplet" "A demonstration snaplet called foo." Nothing $ do
config <- getSnapletConfig
addTemplates "foo"

0 comments on commit 1e75145

Please sign in to comment.