Browse files

Fixed issues #30 and #38, and add test

Modified createUser to check for empty usernames.
Fixed content tags in project template.
  • Loading branch information...
1 parent b107117 commit 1c8ad9bea476ddf51d609ba0f621de13fdde1bf2 @adinapoli adinapoli committed with mightybyte Sep 13, 2012
View
3 .gitignore
@@ -11,8 +11,9 @@
.DS_Store
.hpc
cabal-dev/
-dist/
+dist*/
docs/templates/out
sitekey.txt
+test/dist*
test/test-cabal-dev
test/test-snap-exe
View
2 project_template/default/snaplets/heist/templates/base.tpl
@@ -6,7 +6,7 @@
<body>
<div id="content">
- <content/>
+ <apply-content/>
</div>
</body>
View
29 src/Snap/Snaplet/Auth/Handlers.hs
@@ -43,8 +43,11 @@ import Snap.Snaplet.Session
--
createUser :: Text -- ^ Username
-> ByteString -- ^ Password
- -> Handler b (AuthManager b) AuthUser
-createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd)
+ -> Handler b (AuthManager b) (Either String AuthUser)
+createUser "" _ = return $ Left "Username cannot be empty"
+createUser unm pwd = withBackend $ \r -> do
+ u <- liftIO $ buildAuthUser r unm pwd
+ return $ Right u
------------------------------------------------------------------------------
@@ -159,8 +162,12 @@ isLoggedIn = isJust <$> currentUser
--
-- May throw a 'BackendError' if something goes wrong.
--
-saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
-saveUser u = withBackend $ liftIO . flip save u
+saveUser :: AuthUser -> Handler b (AuthManager b) (Either String AuthUser)
+saveUser u
+ | userLogin u == "" = return $ Left "Username cannot be empty"
+ | otherwise = withBackend $ \r -> do
+ savedUser <- liftIO $ save r u
+ return $ Right savedUser
------------------------------------------------------------------------------
@@ -290,7 +297,7 @@ forceLogin :: AuthUser -- ^ An existing user, somehow looked up from db
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forceLogin u = do
s <- gets session
- withSession s $ do
+ withSession s $
case userId u of
Just x -> do
withTop s (setSessionUserId x)
@@ -348,7 +355,7 @@ removeSessionUserId = deleteFromSession "__user_id"
getSessionUserId :: Handler b SessionManager (Maybe UserId)
getSessionUserId = do
uid <- getFromSession "__user_id"
- return $ uid >>= return . UserId
+ return $ liftM UserId uid
------------------------------------------------------------------------------
@@ -392,7 +399,7 @@ cacheOrLookup f = do
registerUser
:: ByteString -- ^ Login field
-> ByteString -- ^ Password field
- -> Handler b (AuthManager b) AuthUser
+ -> Handler b (AuthManager b) (Either String AuthUser)
registerUser lf pf = do
l <- fmap decodeUtf8 <$> getParam lf
p <- getParam pf
@@ -424,11 +431,11 @@ loginUser unf pwdf remf loginFail loginSucc =
go = do
mbUsername <- getParam unf
mbPassword <- getParam pwdf
- remember <- (runMaybeT $ do
- field <- MaybeT $ return remf
+ remember <- liftM (fromMaybe False)
+ (runMaybeT $
+ do field <- MaybeT $ return remf
value <- MaybeT $ getParam field
- return $ value == "1"
- ) >>= return . fromMaybe False
+ return $ value == "1")
password <- maybe (throwError PasswordMissing) return mbPassword
View
2 test/non-cabal-appdir/snaplets/foosnaplet/devel.cfg
@@ -0,0 +1,2 @@
+fooSnapletField = "fooValue"
+
View
1 test/non-cabal-appdir/snaplets/foosnaplet/templates/foopage.tpl
@@ -0,0 +1 @@
+foo template page
View
1 test/non-cabal-appdir/snaplets/heist/templates/good.tpl
@@ -0,0 +1 @@
+Good template
View
2 test/non-cabal-appdir/snaplets/heist/templates/page.tpl
@@ -3,6 +3,6 @@
<title>Example App</title>
</head>
<body>
-<content/>
+<apply-content/>
</body>
</html>
View
10 test/snap-testsuite.cabal
@@ -13,6 +13,7 @@ Executable snap-testsuite
MonadCatchIO-transformers >= 0.2 && < 0.4,
QuickCheck >= 2.3.0.2,
attoparsec >= 0.10 && <0.11,
+ aeson >= 0.6 && <0.7,
base >= 4 && < 5,
bytestring >= 0.9 && < 0.10,
cereal >= 0.3 && < 0.4,
@@ -29,11 +30,12 @@ Executable snap-testsuite
filepath,
hashable >= 1.1,
heist >= 0.10 && < 0.11,
- http-conduit >= 1.4 && < 1.5,
- http-types >= 0.6 && < 0.7,
+ http-conduit >= 1.4 && < 1.7,
+ http-types >= 0.6 && < 0.8,
mtl >= 2,
mwc-random >= 0.8,
process == 1.*,
+ pwstore-fast == 2.*,
snap-core >= 0.9 && < 0.10,
snap-server >= 0.9 && < 0.10,
syb >= 0.1,
@@ -156,8 +158,8 @@ Executable nesttest
filepath,
hashable >= 1.1,
heist >= 0.10 && < 0.11,
- http-conduit >= 1.4 && < 1.5,
- http-types >= 0.6 && < 0.7,
+ http-conduit >= 1.4 && < 1.7,
+ http-types >= 0.6 && < 0.8,
mtl >= 2,
mwc-random >= 0.8,
process == 1.*,
View
30 test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Snap.Snaplet.Auth.Handlers.Tests
+ ( tests ) where
+
+------------------------------------------------------------------------------
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+import Test.HUnit hiding (Test, path)
+
+------------------------------------------------------------------------------
+import Snap.Snaplet.Auth.Handlers
+
+
+
+
+
+
+------------------------------------------------------------------------------
+tests :: Test
+tests = testGroup "Snap.Snaplet.Auth.Handlers"
+ [testGroup "createUser tests"
+ [testCreateUserGood
+ ]
+ ]
+
+testCreateUserGood :: Test
+testCreateUserGood = testCase "Handlers/createUser" $
+ assertEqual "createUser with good parameters" True True
View
2 test/suite/Snap/Snaplet/Internal/RST/Tests.hs
@@ -16,7 +16,7 @@ import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding (Test, path)
-import Snap.Snaplet.Internal.RST
+import Snap.Snaplet.Internal.RST
tests :: Test
View
11 test/suite/TestSuite.hs
@@ -28,6 +28,7 @@ import qualified Snap.Snaplet.Internal.Lensed.Tests
import qualified Snap.Snaplet.Internal.LensT.Tests
import qualified Snap.Snaplet.Internal.RST.Tests
import qualified Snap.Snaplet.Internal.Tests
+import qualified Snap.Snaplet.Auth.Handlers.Tests
import Snap.TestCommon
import SafeCWD
@@ -50,13 +51,23 @@ main = do
where tests = mutuallyExclusive $
testGroup "snap" [ internalServerTests
+ , authTests
, testDefault
, testBarebones
, testTutorial
]
------------------------------------------------------------------------------
+authTests :: Test
+authTests =
+ mutuallyExclusive $
+ testGroup "auth tests"
+ [ Snap.Snaplet.Auth.Handlers.Tests.tests
+ ]
+
+
+------------------------------------------------------------------------------
internalServerTests :: Test
internalServerTests =
mutuallyExclusive $

2 comments on commit 1c8ad9b

@nurpax

I see that you're adding Either return type for createUser to return the error case for empty login/password.

createUser was previously potentially throwing DuplicateLogin exceptions in the case of duplicate logins error. Is the use of Either this way consistent with the previous error handling code? IOW, it looks inconsistent to mix both exceptions and Either this way. If you don't want to break the API, you perhaps add a new exception type for invalid login parameters?

@gregorycollins
Snap Framework member

This kind of code should prefer patterns like Either, and we shouldn't be throwing an exception from createUser either.

Re: API stability, Auth isn't yet widely used and I would prefer to make the API correct rather than freezing in a bad design.

Please sign in to comment.