Permalink
Browse files

Change Handler's MonadState instance to use state of v rather than Sn…

…aplet v.
  • Loading branch information...
1 parent 2d8045a commit d78734497585a3a608a9498a22b971184475a26f @mightybyte mightybyte committed Sep 29, 2011
View
@@ -85,7 +85,7 @@ createUser
-> ByteString -- Password
-> Handler b (AuthManager b) AuthUser
createUser unm pass = do
- (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
+ (AuthManager r _ _ _ _ _ _ _) <- get
liftIO $ AM.createUser r unm pass
@@ -98,7 +98,7 @@ loginByUsername
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
loginByUsername unm pwd rm = do
- AuthManager r s _ _ cn rp sk _ <- getSnapletState
+ AuthManager r s _ _ cn rp sk _ <- get
au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
case au of
Nothing -> return $ Left UserNotFound
@@ -121,7 +121,7 @@ loginByUsername unm pwd rm = do
-- | Remember user from the remember token if possible and perform login
loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
loginByRememberToken = do
- mgr@(AuthManager r _ _ _ rc rp sk _) <- getSnapletState
+ mgr@(AuthManager r _ _ _ rc rp sk _) <- get
token <- getRememberToken sk rc rp
au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
case au of
@@ -133,11 +133,11 @@ loginByRememberToken = do
-- | Logout the active user
logout :: Handler b (AuthManager b) ()
logout = do
- s <- getsSnapletState session
+ s <- gets session
withTop s $ withSession s removeSessionUserId
- AuthManager _ _ _ _ rc _ _ _ <- getSnapletState
+ AuthManager _ _ _ _ rc _ _ _ <- get
forgetRememberToken rc
- modifySnapletState (\mgr -> mgr { activeUser = Nothing } )
+ modify (\mgr -> mgr { activeUser = Nothing } )
------------------------------------------------------------------------------
@@ -146,7 +146,7 @@ currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser = cacheOrLookup f
where
f = do
- mgr@(AuthManager r s _ _ _ _ _ _) <- getSnapletState
+ mgr@(AuthManager r s _ _ _ _ _ _) <- get
uid <- withTop s getSessionUserId
case uid of
Nothing -> loginByRememberToken
@@ -165,7 +165,7 @@ isLoggedIn = isJust `fmap` currentUser
-- May throw a 'BackendError' if something goes wrong.
saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
saveUser u = do
- (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
+ (AuthManager r _ _ _ _ _ _ _) <- get
liftIO $ save r u
@@ -175,7 +175,7 @@ saveUser u = do
-- May throw a 'BackendError' if something goes wrong.
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser u = do
- (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
+ (AuthManager r _ _ _ _ _ _ _) <- get
liftIO $ destroy r u
@@ -191,7 +191,7 @@ destroyUser u = do
-- This will save the user to the backend.
markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthFail u = do
- (AuthManager r _ _ _ _ _ _ lo) <- getSnapletState
+ (AuthManager r _ _ _ _ _ _ lo) <- get
incFailCtr u >>= checkLockout lo >>= liftIO . save r
where
incFailCtr u' = return $ u'
@@ -212,7 +212,7 @@ markAuthFail u = do
-- This will save the user to the backend.
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthSuccess u = do
- (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
+ (AuthManager r _ _ _ _ _ _ _) <- get
now <- liftIO getCurrentTime
incLoginCtr u >>= updateIp >>= updateLoginTS
>>= resetFailCtr >>= liftIO . save r
@@ -265,7 +265,7 @@ checkPasswordAndLogin u pw =
return $ Left e
Nothing -> do
forceLogin u
- modifySnapletState (\mgr -> mgr { activeUser = Just u })
+ modify (\mgr -> mgr { activeUser = Just u })
u' <- markAuthSuccess u
return $ Right u'
@@ -280,7 +280,7 @@ forceLogin
-- ^ An existing user, somehow looked up from db
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forceLogin u = do
- AuthManager _ s _ _ _ _ _ _ <- getSnapletState
+ AuthManager _ s _ _ _ _ _ _ <- get
withSession s $ do
case userId u of
Just x -> do
@@ -350,12 +350,12 @@ cacheOrLookup
-- ^ Lookup action to perform if request local cache is empty
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup f = do
- au <- getsSnapletState activeUser
+ au <- gets activeUser
if isJust au
then return au
else do
au' <- f
- modifySnapletState (\mgr -> mgr { activeUser = au' })
+ modify (\mgr -> mgr { activeUser = au' })
return au'
@@ -41,7 +41,7 @@ registerUser
-> ByteString -- Password field
-> Handler b (AuthManager b) AuthUser
registerUser lf pf = do
- (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
+ (AuthManager r _ _ _ _ _ _ _) <- get
l <- fmap decodeUtf8 `fmap` getParam lf
p <- getParam pf
case liftM2 (,) l p of
@@ -1,6 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
module Snap.Snaplet.HeistNoClass
( Heist
, heistInit
@@ -138,15 +139,15 @@ liftWith :: (Lens (Snaplet b) (Snaplet v'))
liftWith l = liftHandler . withTop' l
-instance MonadState (Snaplet v) (SnapletHeist b v) where
+instance MonadState v (SnapletHeist b v) where
get = do
l <- ask
- b <- liftHandler get
- return $ getL l b
+ b <- liftHandler getSnapletState
+ return $ getL (snapletValue . l) b
put s = do
l <- ask
- b <- liftHandler get
- liftHandler $ put $ setL l s b
+ b <- liftHandler getSnapletState
+ liftHandler $ putSnapletState $ setL (snapletValue . l) s b
------------------------------------------------------------------------------
@@ -157,7 +158,7 @@ instance MonadSnaplet SnapletHeist where
withTop' l = withSS (const id) . with' l
getOpaqueConfig = do
l <- ask
- b <- liftHandler get
+ b <- liftHandler getSnapletState
return $ getL (snapletConfig . l) b
@@ -232,7 +233,7 @@ renderHelper :: Maybe MIMEType
-> ByteString
-> Handler b (Heist b) ()
renderHelper c t = do
- (Heist ts _) <- getSnapletState
+ (Heist ts _) <- get
withTop' id $ renderTemplate ts t >>= maybe pass serve
where
serve (b, mime) = do
@@ -270,10 +271,10 @@ heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> Handler b v a
-> Handler b v a
heistLocal' heist f m = do
- hs <- withTop' heist $ getSnapletState
- withTop' heist $ modifySnapletState $ changeTS f
+ hs <- withTop' heist get
+ withTop' heist $ modify $ changeTS f
res <- m
- withTop' heist $ putSnapletState hs
+ withTop' heist $ put hs
return res
@@ -4,6 +4,9 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
module Snap.Snaplet.Internal.Types where
@@ -220,44 +223,29 @@ newtype Handler b v a =
, MonadSnap)
-------------------------------------------------------------------------------
-instance MonadState (Snaplet v) (Handler b v) where
- get = Handler get
- put = Handler . put
+getSnapletState :: Handler b v (Snaplet v)
+getSnapletState = Handler get
-------------------------------------------------------------------------------
--- The following functions provide the equivalent of a (MonadState v) instance
--- for anything with a (MonadState (Snaplet v)) instance. If we put these in
--- MonadSnaplet, then we won't be able to write an instance for Initializer
--- because it's in the process of constructing the state. If we did it the
--- other way around, we wouldn't be able to define the (MonadState (Snaplet
--- v)) functions in terms of the (MonadState v) functions.
-------------------------------------------------------------------------------
+putSnapletState :: Snaplet v -> Handler b v ()
+putSnapletState = Handler . put
-------------------------------------------------------------------------------
--- | Gets the current snaplet's state.
-getSnapletState :: MonadState (Snaplet a) m => m a
-getSnapletState = liftM _snapletValue get
+modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v ()
+modifySnapletState f = do
+ s <- getSnapletState
+ putSnapletState (f s)
-------------------------------------------------------------------------------
--- | Modifies the current snaplet's state.
-modifySnapletState :: MonadState (Snaplet a) m => (a -> a) -> m ()
-modifySnapletState f = modify (modL snapletValue f)
+getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b
+getsSnapletState f = do
+ s <- getSnapletState
+ return (f s)
-------------------------------------------------------------------------------
--- | Puts the current snaplet's state.
-putSnapletState :: MonadState (Snaplet a) m => a -> m ()
-putSnapletState s = modifySnapletState (const s)
-
-
-------------------------------------------------------------------------------
--- | Gets the current snaplet's state.
-getsSnapletState :: MonadState (Snaplet a) m => (a -> b) -> m b
-getsSnapletState f = liftM (f . _snapletValue) get
+instance MonadState v (Handler b v) where
+ get = getsSnapletState _snapletValue
+ put v = modifySnapletState (setL snapletValue v)
instance MonadSnaplet Handler where
@@ -14,6 +14,7 @@ module Snap.Snaplet.Session
) where
+import Control.Monad.State
import Data.Lens.Lazy
import Data.Text (Text)
@@ -46,7 +47,7 @@ setInSession :: Text -> Text -> Handler b SessionManager ()
setInSession k v = do
SessionManager r <- loadSession
let r' = SM.insert k v r
- putSnapletState $ SessionManager r'
+ put $ SessionManager r'
-- | Get a key from the current session
@@ -61,14 +62,14 @@ deleteFromSession :: Text -> Handler b SessionManager ()
deleteFromSession k = do
SessionManager r <- loadSession
let r' = SM.delete k r
- putSnapletState $ SessionManager r'
+ put $ SessionManager r'
-- | Returns a CSRF Token unique to the current session
csrfToken :: Handler b SessionManager Text
csrfToken = do
mgr@(SessionManager r) <- loadSession
- putSnapletState mgr
+ put mgr
return $ SM.csrf r
@@ -84,21 +85,21 @@ resetSession :: Handler b SessionManager ()
resetSession = do
SessionManager r <- loadSession
r' <- liftSnap $ SM.reset r
- putSnapletState $ SessionManager r'
+ put $ SessionManager r'
-- | Touch the session so the timeout gets refreshed
touchSession :: Handler b SessionManager ()
touchSession = do
SessionManager r <- loadSession
let r' = SM.touch r
- putSnapletState $ SessionManager r'
+ put $ SessionManager r'
-- | Load the session into the manager
loadSession :: Handler b SessionManager SessionManager
loadSession = do
- SessionManager r <- getSnapletState
+ SessionManager r <- get
r' <- liftSnap $ load r
return $ SessionManager r'
@@ -11,6 +11,7 @@
module Blackbox.EmbeddedSnaplet where
import Prelude hiding ((.))
+import Control.Monad.State
import Data.Lens.Lazy
import Data.Lens.Template
import qualified Data.Text as T
@@ -56,6 +57,6 @@ embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do
embeddedSplice :: (Lens (Snaplet b) (Snaplet EmbeddedSnaplet))
-> SnapletHeist b v Template
embeddedSplice embeddedLens = do
- val <- liftWith embeddedLens $ getsSnapletState _embeddedVal
+ val <- liftWith embeddedLens $ gets _embeddedVal
liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)
@@ -37,5 +37,5 @@ fooInit = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."
return $ FooSnaplet "foo snaplet data string"
getFooField :: Handler b FooSnaplet String
-getFooField = getsSnapletState fooField
+getFooField = gets fooField
View
@@ -11,6 +11,7 @@
module Main where
import Prelude hiding ((.))
+import Control.Monad.State
import Data.Lens.Lazy
import Data.Lens.Template
import qualified Data.Text as T
@@ -53,7 +54,7 @@ fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do
fooSplice :: (Lens (Snaplet b) (Snaplet FooSnaplet))
-> SnapletHeist b v Template
fooSplice fooLens = do
- val <- liftWith fooLens $ getsSnapletState _fooVal
+ val <- liftWith fooLens $ gets _fooVal
liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)
------------------------------------------------------------------------------

0 comments on commit d787344

Please sign in to comment.