Permalink
Browse files

More code cleanup

  - remove a couple of performance-dangerous uses of /dev/urandom

  - code prettification

  - bump master to 0.7.1
  • Loading branch information...
1 parent 635004f commit 1e3cfe3c2df8884e6bde01fcbd22827b9c03d6b8 @gregorycollins gregorycollins committed Dec 10, 2011
View
@@ -1,17 +1,19 @@
-*~
-dist/
-*.tix
-.hpc
-*.log
-*.prof
+#*#
+**/.DS_Store
*.hi
+*.log
*.o
+*.prof
*.swp
-#*#
+*.tix
+*~
.#*
.DS_Store
-**/.DS_Store
-docs/templates/out
+.hpc
cabal-dev/
-test/test-cabal-dev
+dist/
+docs/templates/out
sitekey.txt
+test/non-cabal-appdir
+test/test-cabal-dev
+test/test-snap-exe
View
@@ -1,5 +1,5 @@
name: snap
-version: 0.7
+version: 0.7.1
synopsis: Snap: A Haskell Web Framework: project starter executable and glue code library
description: Snap Framework project starter executable and glue code library
license: BSD3
@@ -115,7 +115,7 @@ Library
data-lens-template >= 2.1 && < 2.2,
filepath >= 1.1 && < 1.3,
hashable >= 1.1 && < 1.2,
- heist >= 0.7 && < 0.8,
+ heist >= 0.7 && < 0.9,
logict >= 0.4.2 && < 0.6,
mtl > 2.0 && < 2.1,
mwc-random >= 0.8 && < 0.11,
View
@@ -1,22 +1,21 @@
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-|
-
- This module contains all the central authentication functionality.
-
- It exports a number of high-level functions to be used directly in your
- application handlers.
-
- We also export a number of mid-level functions that should be helpful when
- you are integrating with another way of confirming the authentication of
- login requests.
-
--}
+------------------------------------------------------------------------------
+-- |
+--
+-- This module contains all the central authentication functionality.
+--
+-- It exports a number of high-level functions to be used directly in your
+-- application handlers.
+--
+-- We also export a number of mid-level functions that should be helpful when
+-- you are integrating with another way of confirming the authentication of
+-- login requests.
+--
module Snap.Snaplet.Auth
(
-
-- * Higher Level Handler Functions
createUser
, usernameExists
@@ -67,6 +66,7 @@ module Snap.Snaplet.Auth
)
where
+------------------------------------------------------------------------------
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Auth.Handlers
import Snap.Snaplet.Auth.SpliceHelpers
@@ -1,21 +1,21 @@
+------------------------------------------------------------------------------
+-- | Internal module exporting AuthManager implementation.
+--
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.Snaplet.Auth.AuthManager
-
-(
- -- * AuthManager Datatype
+ ( -- * AuthManager Datatype
AuthManager(..)
- -- * Backend Typeclass
- , IAuthBackend(..)
+ -- * Backend Typeclass
+ , IAuthBackend(..)
- -- * Context-free Operations
- , buildAuthUser
-
-) where
+ -- * Context-free Operations
+ , buildAuthUser
+ ) where
------------------------------------------------------------------------------
import Data.ByteString (ByteString)
@@ -26,8 +26,10 @@ import Web.ClientSession
import Snap.Snaplet
import Snap.Snaplet.Session
+import Snap.Snaplet.Session.Common
import Snap.Snaplet.Auth.Types
+
------------------------------------------------------------------------------
-- | Creates a new user from a username and password.
--
@@ -65,28 +67,31 @@ class IAuthBackend r where
------------------------------------------------------------------------------
-- | Abstract data type holding all necessary information for auth operation
data AuthManager b = forall r. IAuthBackend r => AuthManager {
- backend :: r
+ backend :: r
-- ^ Storage back-end
- , session :: Lens b (Snaplet SessionManager)
+ , session :: Lens b (Snaplet SessionManager)
-- ^ A lens pointer to a SessionManager
- , activeUser :: Maybe AuthUser
+ , activeUser :: Maybe AuthUser
-- ^ A per-request logged-in user cache
- , minPasswdLen :: Int
+ , minPasswdLen :: Int
-- ^ Password length range
- , rememberCookieName :: ByteString
+ , rememberCookieName :: ByteString
-- ^ Cookie name for the remember token
- , rememberPeriod :: Maybe Int
+ , rememberPeriod :: Maybe Int
-- ^ Remember period in seconds. Defaults to 2 weeks.
- , siteKey :: Key
+ , siteKey :: Key
-- ^ A unique encryption key used to encrypt remember cookie
- , lockout :: Maybe (Int, NominalDiffTime)
+ , lockout :: Maybe (Int, NominalDiffTime)
-- ^ Lockout after x tries, re-allow entry after y seconds
+
+ , randomNumberGenerator :: RNG
+ -- ^ Random number generator
}
@@ -32,6 +32,7 @@ import Snap.Snaplet
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Session
+import Snap.Snaplet.Session.Common
@@ -45,23 +46,25 @@ initJsonFileAuthManager :: AuthSettings
-> FilePath
-- ^ Where to store user data as JSON
-> SnapletInit b (AuthManager b)
-initJsonFileAuthManager s l db =
- makeSnaplet
- "JsonFileAuthManager"
- "A snaplet providing user authentication using a JSON-file backend"
- Nothing $ liftIO $ do
- key <- getKey (asSiteKey s)
- jsonMgr <- mkJsonAuthMgr db
- return $! AuthManager {
- backend = jsonMgr
- , session = l
- , activeUser = Nothing
- , minPasswdLen = asMinPasswdLen s
- , rememberCookieName = asRememberCookieName s
- , rememberPeriod = asRememberPeriod s
- , siteKey = key
- , lockout = asLockout s
- }
+initJsonFileAuthManager s l db = do
+ makeSnaplet
+ "JsonFileAuthManager"
+ "A snaplet providing user authentication using a JSON-file backend"
+ Nothing $ liftIO $ do
+ rng <- liftIO mkRNG
+ key <- getKey (asSiteKey s)
+ jsonMgr <- mkJsonAuthMgr db
+ return $! AuthManager {
+ backend = jsonMgr
+ , session = l
+ , activeUser = Nothing
+ , minPasswdLen = asMinPasswdLen s
+ , rememberCookieName = asRememberCookieName s
+ , rememberPeriod = asRememberPeriod s
+ , siteKey = key
+ , lockout = asLockout s
+ , randomNumberGenerator = rng
+ }
------------------------------------------------------------------------------
@@ -93,7 +93,9 @@ loginByUsername unm pwd shouldRemember = do
----------------------------------------------------------------------
matched user
| shouldRemember = do
- token <- liftIO $ randomToken 64
+ token <- gets randomNumberGenerator >>=
+ liftIO . randomToken 64
+
setRememberToken sk cn rp token
let user' = user {
@@ -151,7 +153,7 @@ currentUser = cacheOrLookup $ withBackend $ \r -> do
-- | Convenience wrapper around 'rememberUser' that returns a bool result
--
isLoggedIn :: Handler b (AuthManager b) Bool
-isLoggedIn = isJust `fmap` currentUser
+isLoggedIn = isJust <$> currentUser
------------------------------------------------------------------------------
@@ -223,7 +225,7 @@ markAuthSuccess u = withBackend $ \r ->
--------------------------------------------------------------------------
updateIp u' = do
- ip <- rqRemoteAddr `fmap` getRequest
+ ip <- rqRemoteAddr <$> getRequest
return $ u' { userLastLoginIp = userCurrentLoginIp u'
, userCurrentLoginIp = Just ip }
@@ -394,7 +396,7 @@ registerUser
-> ByteString -- ^ Password field
-> Handler b (AuthManager b) AuthUser
registerUser lf pf = do
- l <- fmap decodeUtf8 `fmap` getParam lf
+ l <- fmap decodeUtf8 <$> getParam lf
p <- getParam pf
case liftM2 (,) l p of
Nothing -> throw PasswordMissing
@@ -478,5 +480,5 @@ withBackend ::
-- ^ The function to run with the handler.
-> Handler b (AuthManager v) a
withBackend f = join $ do
- (AuthManager backend_ _ _ _ _ _ _ _) <- get
+ (AuthManager backend_ _ _ _ _ _ _ _ _) <- get
return $ f backend_
@@ -139,7 +139,7 @@ defAuthUser = AuthUser
-- clear-text; it will be encrypted into a 'Encrypted'.
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword au pass = do
- pw <- Encrypted `fmap` (makePassword pass defaultStrength)
+ pw <- Encrypted <$> makePassword pass defaultStrength
return $! au { userPassword = Just pw }
View
@@ -1,9 +1,7 @@
-{-|
-
-The Heist snaplet makes it easy to add Heist to your application and use it in
-other snaplets.
-
--}
+------------------------------------------------------------------------------
+-- | The Heist snaplet makes it easy to add Heist to your application and use
+-- it in other snaplets.
+--
module Snap.Snaplet.Heist
(
@@ -44,17 +42,20 @@ module Snap.Snaplet.Heist
, clearHeistCache
) where
+------------------------------------------------------------------------------
import Prelude hiding (id, (.))
import Data.ByteString (ByteString)
import Data.Lens.Lazy
import Data.Text (Text)
import Text.Templating.Heist
-
+------------------------------------------------------------------------------
import Snap.Snaplet
-
import qualified Snap.Snaplet.HeistNoClass as Unclassed
-import Snap.Snaplet.HeistNoClass (Heist, heistInit
- ,heistInit', clearHeistCache)
+import Snap.Snaplet.HeistNoClass ( Heist
+ , heistInit
+ , heistInit'
+ , clearHeistCache
+ )
------------------------------------------------------------------------------
Oops, something went wrong.

0 comments on commit 1e3cfe3

Please sign in to comment.