Permalink
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...
adinapoli authored and mightybyte committed Sep 13, 2012
1 parent b107117 commit 1c8ad9bea476ddf51d609ba0f621de13fdde1bf2
View
@@ -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
@@ -6,7 +6,7 @@
<body>
<div id="content">
- <content/>
+ <apply-content/>
</div>
</body>
@@ -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
@@ -0,0 +1,2 @@
+fooSnapletField = "fooValue"
+
@@ -0,0 +1 @@
+foo template page
@@ -0,0 +1 @@
+Good template
@@ -3,6 +3,6 @@
<title>Example App</title>
</head>
<body>
-<content/>
+<apply-content/>
</body>
</html>
View
@@ -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.*,
@@ -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
@@ -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
@@ -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,12 +51,22 @@ 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 =

2 comments on commit 1c8ad9b

@nurpax

This comment has been minimized.

Show comment
Hide comment
@nurpax

nurpax Sep 25, 2012

Contributor

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?

Contributor

nurpax replied Sep 25, 2012

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

This comment has been minimized.

Show comment
Hide comment
@gregorycollins

gregorycollins Sep 25, 2012

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.

Member

gregorycollins replied Sep 25, 2012

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.