Permalink
Browse files

Separate out AuthManager module, break out some functionality

  • Loading branch information...
1 parent b02bb12 commit bf7e64a8b2daddeaf5a2ce1bdd96523701e3993a @ozataman ozataman committed Sep 15, 2011
View
@@ -50,6 +50,7 @@ Library
Snap.Snaplet,
Snap.Snaplet.Heist,
Snap.Snaplet.Auth,
+ Snap.Snaplet.Auth.AuthManager,
Snap.Snaplet.Auth.Types,
Snap.Snaplet.Auth.Handlers,
Snap.Snaplet.Auth.Backends.JsonFile,
View
@@ -17,7 +17,7 @@
module Snap.Snaplet.Auth
(
- -- * Higher Level Functions
+ -- * Higher Level Handler Functions
createUser
, saveUser
, destroyUser
@@ -45,6 +45,7 @@ module Snap.Snaplet.Auth
-- * Other Utilities
, authenticatePassword
+ , setPassword
)
where
@@ -59,6 +60,8 @@ import Data.Text (Text)
import Snap.Core
import Snap.Snaplet
+import qualified Snap.Snaplet.Auth.AuthManager as AM
+import Snap.Snaplet.Auth.AuthManager (IAuthBackend(..), AuthManager(..))
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Common
@@ -81,16 +84,8 @@ createUser
-> ByteString -- Password
-> Handler b (AuthManager b) AuthUser
createUser unm pass = do
- mgr@(AuthManager r _ _ _ _ _ _ _) <- getSnapletState
- now <- liftIO getCurrentTime
- pw <- Encrypted `fmap` liftIO (makePassword pass 12)
- let au = defAuthUser {
- userLogin = unm
- , userPassword = Just pw
- , userCreatedAt = Just now
- , userUpdatedAt = Just now
- }
- liftIO $ save r au
+ (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
+ liftIO $ AM.createUser r unm pass
------------------------------------------------------------------------------
@@ -0,0 +1,109 @@
+
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Snap.Snaplet.Auth.AuthManager
+
+(
+ -- * AuthManager Datatype
+ AuthManager(..)
+
+ -- * Backend Typeclass
+ , IAuthBackend(..)
+
+ -- * Context-free Operations
+ , createUser
+
+) where
+
+
+import Control.Monad.CatchIO
+import Data.Aeson
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString (ByteString)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
+import Data.Lens.Lazy
+import Data.Time
+import Data.Typeable
+import Data.Text (Text)
+import Web.ClientSession
+
+import Snap.Snaplet
+import Snap.Snaplet.Session
+import Snap.Snaplet.Auth.Types
+
+------------------------------------------------------------------------------
+-- | Create a new user from just a username and password
+--
+-- May throw a "DuplicateLogin' if given username is not unique
+createUser
+ :: (IAuthBackend r)
+ => r
+ -- ^ An auth backend
+ -> Text
+ -- ^ Username
+ -> ByteString
+ -- ^ Password
+ -> IO AuthUser
+createUser r unm pass = do
+ now <- getCurrentTime
+ let au = defAuthUser {
+ userLogin = unm
+ , userPassword = Nothing
+ , userCreatedAt = Just now
+ , userUpdatedAt = Just now
+ }
+ au' <- setPassword au pass
+ save r au'
+
+
+------------------------------------------------------------------------------
+-- | All storage backends need to implement this typeclass
+--
+-- Backend operations may throw 'BackendError's
+class IAuthBackend r where
+
+ -- | Needs to create or update the given 'AuthUser' record
+ save :: r -> AuthUser -> IO AuthUser
+
+ lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)
+
+ lookupByLogin :: r -> Text -> IO (Maybe AuthUser)
+
+ lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)
+
+ destroy :: r -> AuthUser -> IO ()
+
+
+------------------------------------------------------------------------------
+-- | Abstract data type holding all necessary information for auth operation
+data AuthManager b = forall r. IAuthBackend r => AuthManager {
+ backend :: r
+ -- ^ Storage back-end
+
+ , session :: Lens b (Snaplet SessionManager)
+ -- ^ A lens pointer to a SessionManager
+
+ , activeUser :: Maybe AuthUser
+ -- ^ A per-request logged-in user cache
+
+ , minPasswdLen :: Int
+ -- ^ Password length range
+
+ , rememberCookieName :: ByteString
+ -- ^ Cookie name for the remember token
+
+ , rememberPeriod :: Maybe Int
+ -- ^ Remember period in seconds. Defaults to 2 weeks.
+
+ , siteKey :: Key
+ -- ^ A unique encryption key used to encrypt remember cookie
+
+ , lockout :: Maybe (Int, NominalDiffTime)
+ -- ^ Lockout after x tries, re-allow entry after y seconds
+ }
+
@@ -26,8 +26,9 @@ import Data.Time
import Web.ClientSession
import System.Directory
-import Snap.Snaplet.Auth.Types
import Snap.Snaplet
+import Snap.Snaplet.Auth.Types
+import Snap.Snaplet.Auth.AuthManager hiding (createUser)
import Snap.Snaplet.Session
@@ -28,6 +28,7 @@ import Data.Time
import Snap.Core
import Snap.Snaplet.Auth
+import Snap.Snaplet.Auth.AuthManager (AuthManager(..))
import Snap.Snaplet.Auth.Types
import Snap.Snaplet
@@ -103,6 +103,7 @@ data AuthUser = AuthUser
} deriving (Show,Eq)
+defAuthUser :: AuthUser
defAuthUser = AuthUser {
userId = Nothing
, userLogin = ""
@@ -125,11 +126,21 @@ defAuthUser = AuthUser {
------------------------------------------------------------------------------
+-- | Set a new password for the given user. Given password should be
+-- clear-text; it will be encrypted into a 'Encrypted'.
+setPassword :: AuthUser -> ByteString -> IO AuthUser
+setPassword au pass = do
+ pw <- Encrypted `fmap` (makePassword pass 12)
+ return $ au { userPassword = Just pw }
+
+
+------------------------------------------------------------------------------
-- | Authetication settings defined at initialization time
data AuthSettings = AuthSettings {
asMinPasswdLen :: Int
-- ^ Currently not used/checked
, asRememberCookieName :: ByteString
+ -- ^ Name of the desired remember cookie
, asRememberPeriod :: Maybe Int
-- ^ How long to remember when the option is used in rest of the API.
-- 'Nothing' means remember indefinitely.
@@ -148,36 +159,6 @@ defAuthSettings = AuthSettings {
}
-------------------------------------------------------------------------------
--- | Abstract data type holding all necessary information for auth operation
-data AuthManager b = forall r. IAuthBackend r => AuthManager {
- backend :: r
- -- ^ Storage back-end
-
- , session :: Lens b (Snaplet SessionManager)
- -- ^ A lens pointer to a SessionManager
-
- , activeUser :: Maybe AuthUser
- -- ^ A per-request logged-in user cache
-
- , minPasswdLen :: Int
- -- ^ Password length range
-
- , rememberCookieName :: ByteString
- -- ^ Cookie name for the remember token
-
- , rememberPeriod :: Maybe Int
- -- ^ Remember period in seconds. Defaults to 2 weeks.
-
- , siteKey :: Key
- -- ^ A unique encryption key used to encrypt remember cookie
-
- , lockout :: Maybe (Int, NominalDiffTime)
- -- ^ Lockout after x tries, re-allow entry after y seconds
- }
-
-
-
data BackendError =
DuplicateLogin
| BackendError String
@@ -186,22 +167,3 @@ data BackendError =
instance Exception BackendError
-
-------------------------------------------------------------------------------
--- | All storage backends need to implement this typeclass
---
--- Backend operations may throw 'BackendError's
-class IAuthBackend r where
-
- -- | Needs to create or update the given 'AuthUser' record
- save :: r -> AuthUser -> IO AuthUser
-
- lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)
-
- lookupByLogin :: r -> Text -> IO (Maybe AuthUser)
-
- lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)
-
- destroy :: r -> AuthUser -> IO ()
-
-

0 comments on commit bf7e64a

Please sign in to comment.