Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

[0.10] Done type refactoring as discussed in issue #30 #47

Merged
merged 3 commits into from

2 participants

@adinapoli

All tests pass. I needed to add the either dependency, see in the code why.

Please review carefully before merging.

A.

@adinapoli adinapoli commented on the diff
snap.cabal
@@ -154,6 +154,7 @@ Library
data-lens >= 2.0.1 && < 2.11,
data-lens-template >= 2.1 && < 2.2,
dlist >= 0.5 && < 0.6,
+ either >=3.0.2 && < 3.0.5,

We need this to use hoistEither, which is pretty damn useful in the loginUser function.

@mightybyte Owner

Actually, I don't think we need either. You can just import Control.Error from the errors package. It's really just a re-export of what's in the either package, but it allows us to avoid explicitly depending on either and having to concern ourselves with version bounds.

I have to check, because ghc complained when I tried to use hoistEither. If the dependency is automatically handled by errors just as well, I'll update the build manifest :)

@mightybyte Owner

Also, this version bound is too tight. Typically, with versions of the form a.b.c.d, our default behavior is to use "< a.(b+1)" as our upper bound, because that's the bound that the PVP allows to break the existing API.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@adinapoli adinapoli commented on the diff
src/Snap/Snaplet/Auth.hs
@@ -43,7 +43,6 @@ module Snap.Snaplet.Auth
, UserId(..)
, Password(..)
, AuthFailure(..)
- , BackendError(..)

I choose to use AuthFailure as the universal error type, it seemed more specific to me.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@adinapoli adinapoli commented on the diff
src/Snap/Snaplet/Auth/Handlers.hs
@@ -443,12 +438,12 @@ loginUser unf pwdf remf loginFail loginSucc =
do field <- MaybeT $ return remf
value <- MaybeT $ getParam field
return $ value == "1")
-
-
- password <- maybe (throwError PasswordMissing) return mbPassword
- username <- maybe (fail "Username is missing") return mbUsername
- ErrorT $ loginByUsername username (ClearText password) remember
-
+
+
+ password <- maybe (rightZ $ Left PasswordMissing) return mbPassword
+ username <- maybe (rightZ $ Left UsernameMissing) return mbUsername
+ loginStatus <- loginByUsername username (ClearText password) remember
+ return $ hoistEither loginStatus

Thanks to hoistEither we can write a very lean function, and still use runEitherT to do the conditional evaluation trick.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@adinapoli adinapoli commented on the diff
src/Snap/Snaplet/Auth/Types.hs
((11 lines not shown))
| LockedOut UTCTime -- ^ Locked out until given time
- | AuthError String
- deriving (Read, Show, Ord, Eq, Typeable)
+ | PasswordMissing
+ | UsernameMissing

I've choosen such a name to align with the PasswordMissing type

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@adinapoli adinapoli commented on the diff
src/Snap/Snaplet/Auth/Types.hs
((20 lines not shown))
-instance Error AuthFailure where
- strMsg = AuthError
+instance Show AuthFailure where
+ show (AuthError s) = s
+ show (BackendError) = "Failed to store data in the backend."
+ show (DuplicateLogin) = "This login already exists in the backend."
+ show (EncryptedPassword) = "Cannot login with encrypted password."
+ show (IncorrectPassword) = "The password provided was not valid."
+ show (LockedOut time) = "The login is locked out until " ++ show time
+ show (PasswordMissing) = "No password provided."
+ show (UsernameMissing) = "No username provided."
+ show (UserNotFound) = "User not found in the backend."
+

I'm neither good to write meaningful description nor mother tongue, so please improve :)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@adinapoli adinapoli commented on the diff
test/snap-testsuite.cabal
@@ -26,6 +26,7 @@ Executable snap-testsuite
directory,
directory-tree >= 0.10 && < 0.11,
dlist >= 0.5 && < 0.6,
+ either >= 3.0.2 && < 3.0.5,

Too strict? Maybe we can relax it a bit.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@adinapoli adinapoli commented on the diff
test/suite/TestSuite.hs
@@ -51,7 +51,6 @@ main = do
where tests = mutuallyExclusive $
testGroup "snap" [ internalServerTests
- , authTests

Since this was only a placeholder not pointing to a "real" test, I removed it.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
@mightybyte mightybyte merged commit 8cec19f into snapframework:0.10
@mightybyte mightybyte commented on the diff
src/Snap/Snaplet/Auth/Handlers.hs
@@ -443,12 +438,12 @@ loginUser unf pwdf remf loginFail loginSucc =
do field <- MaybeT $ return remf
value <- MaybeT $ getParam field
return $ value == "1")
-
-
- password <- maybe (throwError PasswordMissing) return mbPassword
- username <- maybe (fail "Username is missing") return mbUsername
- ErrorT $ loginByUsername username (ClearText password) remember
-
+
+
+ password <- maybe (rightZ $ Left PasswordMissing) return mbPassword
@mightybyte Owner

The use of rightZ here is incorrect. We shouldn't ever fail with mzero in this function. It should always end up running one of the supplied success or failure handlers.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
View
1  snap.cabal
@@ -154,6 +154,7 @@ Library
data-lens >= 2.0.1 && < 2.11,
data-lens-template >= 2.1 && < 2.2,
dlist >= 0.5 && < 0.6,
+ either >=3.0.2 && < 3.0.5,

We need this to use hoistEither, which is pretty damn useful in the loginUser function.

@mightybyte Owner

Actually, I don't think we need either. You can just import Control.Error from the errors package. It's really just a re-export of what's in the either package, but it allows us to avoid explicitly depending on either and having to concern ourselves with version bounds.

I have to check, because ghc complained when I tried to use hoistEither. If the dependency is automatically handled by errors just as well, I'll update the build manifest :)

@mightybyte Owner

Also, this version bound is too tight. Typically, with versions of the form a.b.c.d, our default behavior is to use "< a.(b+1)" as our upper bound, because that's the bound that the PVP allows to break the existing API.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
errors >= 1.3 && < 1.4,
filepath >= 1.1 && < 1.4,
hashable >= 1.1 && < 1.2,
View
1  src/Snap/Snaplet/Auth.hs
@@ -43,7 +43,6 @@ module Snap.Snaplet.Auth
, UserId(..)
, Password(..)
, AuthFailure(..)
- , BackendError(..)

I choose to use AuthFailure as the universal error type, it seemed more specific to me.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
, Role(..)
-- * Other Utilities
View
4 src/Snap/Snaplet/Auth/AuthManager.hs
@@ -38,7 +38,7 @@ buildAuthUser :: IAuthBackend r =>
r -- ^ An auth backend
-> Text -- ^ Username
-> ByteString -- ^ Password
- -> IO AuthUser
+ -> IO (Either AuthFailure AuthUser)
buildAuthUser r unm pass = do
now <- getCurrentTime
let au = defAuthUser {
@@ -60,7 +60,7 @@ class IAuthBackend r where
-- 'AuthUser' already exists in the database, then that user's information
-- should be updated. If it does not exist, then a new user should be
-- created.
- save :: r -> AuthUser -> IO AuthUser
+ save :: r -> AuthUser -> IO (Either AuthFailure AuthUser)
lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)
lookupByLogin :: r -> Text -> IO (Maybe AuthUser)
lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)
View
15 src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -149,7 +149,9 @@ data JsonFileAuthManager = JsonFileAuthManager {
------------------------------------------------------------------------------
-jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO AuthUser
+jsonFileSave :: JsonFileAuthManager
+ -> AuthUser
+ -> IO (Either AuthFailure AuthUser)
jsonFileSave mgr u = do
now <- getCurrentTime
oldByLogin <- lookupByLogin mgr (userLogin u)
@@ -169,17 +171,17 @@ jsonFileSave mgr u = do
return $! Right $! (cache', u')
case res of
- Left e -> throw e
+ Left e -> return $! Left BackendError
Right (cache', u') -> do
dumpToDisk cache'
- return $! u'
+ return $! Right u'
where
--------------------------------------------------------------------------
create :: UserCache
-> UTCTime
-> (Maybe AuthUser)
- -> STM (Either BackendError (UserCache, AuthUser))
+ -> STM (Either AuthFailure (UserCache, AuthUser))
create cache now old = do
case old of
Just _ -> return $! Left DuplicateLogin
@@ -202,11 +204,10 @@ jsonFileSave mgr u = do
update :: UserCache
-> UTCTime
-> (Maybe AuthUser)
- -> STM (Either BackendError (UserCache, AuthUser))
+ -> STM (Either AuthFailure (UserCache, AuthUser))
update cache now old =
case old of
- Nothing -> return $! Left $
- BackendError "User not found; should never happen"
+ Nothing -> return $! Left UserNotFound
Just x -> do
let oldLogin = userLogin x
let oldToken = userRememberToken x
View
55 src/Snap/Snaplet/Auth/Handlers.hs
@@ -11,13 +11,10 @@ module Snap.Snaplet.Auth.Handlers where
------------------------------------------------------------------------------
import Control.Applicative
-import Control.Monad.CatchIO (throw)
+import Control.Error
import Control.Monad.State
-import Control.Monad.Trans.Error
-import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.Lens.Lazy
-import Data.Maybe (fromMaybe, isJust)
import Data.Serialize hiding (get)
import Data.Time
import Data.Text.Encoding (decodeUtf8)
@@ -44,12 +41,10 @@ import Snap.Snaplet.Session
--
createUser :: Text -- ^ Username
-> ByteString -- ^ Password
- -> Handler b (AuthManager b) (Either String AuthUser)
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
createUser unm pwd
- | null $ strip unm = return $ Left "Username cannot be empty"
- | otherwise = withBackend $ \r -> do
- u <- liftIO $ buildAuthUser r unm pwd
- return $ Right u
+ | null $ strip unm = return $ Left UsernameMissing
+ | otherwise = withBackend $ \r -> liftIO $ buildAuthUser r unm pwd
------------------------------------------------------------------------------
@@ -68,8 +63,7 @@ loginByUsername :: ByteString -- ^ Username/login for user
-> Password -- ^ Should be ClearText
-> Bool -- ^ Set remember token?
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-loginByUsername _ (Encrypted _) _ =
- error "Cannot login with encrypted password"
+loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword
loginByUsername unm pwd shouldRemember = do
sk <- gets siteKey
cn <- gets rememberCookieName
@@ -164,12 +158,10 @@ isLoggedIn = isJust <$> currentUser
--
-- May throw a 'BackendError' if something goes wrong.
--
-saveUser :: AuthUser -> Handler b (AuthManager b) (Either String AuthUser)
+saveUser :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
saveUser u
- | null $ userLogin u = return $ Left "Username cannot be empty"
- | otherwise = withBackend $ \r -> do
- savedUser <- liftIO $ save r u
- return $ Right savedUser
+ | null $ userLogin u = return $ Left UsernameMissing
+ | otherwise = withBackend $ \r -> liftIO $ save r u
------------------------------------------------------------------------------
@@ -190,7 +182,8 @@ destroyUser u = withBackend $ liftIO . flip destroy u
--
-- This will save the user to the backend.
--
-markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
+markAuthFail :: AuthUser
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthFail u = withBackend $ \r -> do
lo <- gets lockout
incFailCtr u >>= checkLockout lo >>= liftIO . save r
@@ -219,7 +212,8 @@ markAuthFail u = withBackend $ \r -> do
--
-- This will save the user to the backend.
--
-markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
+markAuthSuccess :: AuthUser
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
markAuthSuccess u = withBackend $ \r ->
incLoginCtr u >>=
updateIp >>=
@@ -276,6 +270,7 @@ checkPasswordAndLogin u pw =
Nothing -> auth u
where
+ auth :: AuthUser -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
auth user =
case authenticatePassword user pw of
Just e -> do
@@ -285,8 +280,7 @@ checkPasswordAndLogin u pw =
Nothing -> do
forceLogin user
modify (\mgr -> mgr { activeUser = Just user })
- user' <- markAuthSuccess user
- return $ Right user'
+ markAuthSuccess user
------------------------------------------------------------------------------
@@ -401,12 +395,12 @@ cacheOrLookup f = do
registerUser
:: ByteString -- ^ Login field
-> ByteString -- ^ Password field
- -> Handler b (AuthManager b) (Either String AuthUser)
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
registerUser lf pf = do
l <- fmap decodeUtf8 <$> getParam lf
p <- getParam pf
case liftM2 (,) l p of
- Nothing -> throw PasswordMissing
+ Nothing -> return $ Left PasswordMissing
Just (lgn, pwd) -> createUser lgn pwd
@@ -432,8 +426,9 @@ loginUser
-> Handler b (AuthManager b) ()
-- ^ Upon success
-> Handler b (AuthManager b) ()
-loginUser unf pwdf remf loginFail loginSucc =
- runErrorT go >>= either loginFail (const loginSucc)
+loginUser unf pwdf remf loginFail loginSucc = do
+ res <- go
+ runEitherT res >>= either loginFail (const loginSucc)
where
go = do
mbUsername <- getParam unf
@@ -443,12 +438,12 @@ loginUser unf pwdf remf loginFail loginSucc =
do field <- MaybeT $ return remf
value <- MaybeT $ getParam field
return $ value == "1")
-
-
- password <- maybe (throwError PasswordMissing) return mbPassword
- username <- maybe (fail "Username is missing") return mbUsername
- ErrorT $ loginByUsername username (ClearText password) remember
-
+
+
+ password <- maybe (rightZ $ Left PasswordMissing) return mbPassword
@mightybyte Owner

The use of rightZ here is incorrect. We shouldn't ever fail with mzero in this function. It should always end up running one of the supplied success or failure handlers.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+ username <- maybe (rightZ $ Left UsernameMissing) return mbUsername
+ loginStatus <- loginByUsername username (ClearText password) remember
+ return $ hoistEither loginStatus

Thanks to hoistEither we can write a very lean function, and still use runEitherT to do the conditional evaluation trick.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
------------------------------------------------------------------------------
-- | Simple handler to log the user out. Deletes user from session.
View
34 src/Snap/Snaplet/Auth/Types.hs
@@ -77,17 +77,29 @@ checkPassword _ _ =
-- They may provide useful information to the developer, although it is
-- generally not advisable to show the user the exact details about why login
-- failed.
-data AuthFailure = UserNotFound
+data AuthFailure = AuthError String
+ | BackendError
+ | DuplicateLogin
+ | EncryptedPassword
| IncorrectPassword
- | PasswordMissing
| LockedOut UTCTime -- ^ Locked out until given time
- | AuthError String
- deriving (Read, Show, Ord, Eq, Typeable)
+ | PasswordMissing
+ | UsernameMissing

I've choosen such a name to align with the PasswordMissing type

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+ | UserNotFound
+ deriving (Read, Ord, Eq, Typeable)
-instance Exception AuthFailure
-instance Error AuthFailure where
- strMsg = AuthError
+instance Show AuthFailure where
+ show (AuthError s) = s
+ show (BackendError) = "Failed to store data in the backend."
+ show (DuplicateLogin) = "This login already exists in the backend."
+ show (EncryptedPassword) = "Cannot login with encrypted password."
+ show (IncorrectPassword) = "The password provided was not valid."
+ show (LockedOut time) = "The login is locked out until " ++ show time
+ show (PasswordMissing) = "No password provided."
+ show (UsernameMissing) = "No username provided."
+ show (UserNotFound) = "User not found in the backend."
+

I'm neither good to write meaningful description nor mother tongue, so please improve :)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
------------------------------------------------------------------------------
-- | Internal representation of a 'User'. By convention, we demand that the
@@ -230,14 +242,6 @@ authSettingsFromConfig = do
return $ (pw . rc . rp . lo . sk) defAuthSettings
-------------------------------------------------------------------------------
-data BackendError = DuplicateLogin
- | BackendError String
- deriving (Eq,Show,Read,Typeable)
-
-instance Exception BackendError
-
-
--------------------
-- JSON Instances --
--------------------
View
1  test/snap-testsuite.cabal
@@ -26,6 +26,7 @@ Executable snap-testsuite
directory,
directory-tree >= 0.10 && < 0.11,
dlist >= 0.5 && < 0.6,
+ either >= 3.0.2 && < 3.0.5,

Too strict? Maybe we can relax it a bit.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
errors >= 1.3.1 && < 1.4,
filepath,
hashable >= 1.1,
View
4 test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs
@@ -13,10 +13,6 @@ import Test.HUnit hiding (Test, path)
import Snap.Snaplet.Auth.Handlers
-
-
-
-
------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Snap.Snaplet.Auth.Handlers"
View
1  test/suite/TestSuite.hs
@@ -51,7 +51,6 @@ main = do
where tests = mutuallyExclusive $
testGroup "snap" [ internalServerTests
- , authTests

Since this was only a placeholder not pointing to a "real" test, I removed it.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
, testDefault
, testBarebones
, testTutorial
Something went wrong with that request. Please try again.