Permalink
Browse files

Get working with data-lens, fill out some undefineds

  • Loading branch information...
1 parent f2c55d0 commit a7a4510ca8e0fa7f0ea5f0c23fbce04c06270258 @ozataman ozataman committed Aug 14, 2011
View
@@ -16,11 +16,14 @@ import Snap.Snaplet
import Snap.Snaplet.Heist
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
+import Snap.Snaplet.Auth
+import Snap.Snaplet.Auth.Backends.JsonFile
import Text.Templating.Heist
data App = App
{ _heist :: Snaplet (Heist App)
, _session :: Snaplet SessionManager
+ , _auth :: Snaplet (AuthManager App)
}
type AppHandler = Handler App App
@@ -62,7 +65,9 @@ app = makeSnaplet "app" "An snaplet example application." Nothing $ do
, ("", with heist heistServe)
, ("", with heist $ serveDirectory "resources/doc")
]
- return $ App h s
+ a <- nestSnaplet "auth" auth $
+ initJsonFileAuthManager defAuthSettings session "config/user.json"
+ return $ App h s a
main :: IO ()
main = serveSnaplet defaultConfig app
View
@@ -92,6 +92,7 @@ Library
heist >= 0.6 && < 0.7,
mtl > 2.0 && < 2.1,
mwc-random >= 0.8,
+ pwstore-fast >= 2.2 && < 2.3,
regular >= 0.3,
safe >= 0.3,
snap-core >= 0.6 && < 0.7,
View
@@ -1,16 +1,27 @@
{-# LANGUAGE ExistentialQuantification #-}
-module Snap.Snaplet.Auth where
+module Snap.Snaplet.Auth
+ ( loginByUsername
+ , checkPasswordAndLogin
+ , forceLogin
+ , logout
+ , isLoggedIn
+ , AuthSettings(..)
+ , defAuthSettings
+ , AuthManager
+ )
+ where
import Control.Monad.State
import Crypto.PasswordStore
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import Data.Maybe (isJust)
import Data.Time
+import Data.Text.Encoding (decodeUtf8)
-import Snap.Snaplet.Auth.Types
import Snap.Snaplet
+import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Session
@@ -25,8 +36,14 @@ loginByUsername
:: ByteString -- ^ Username/login for user
-> Password -- ^ Should be ClearText
-> Bool -- ^ Set remember token?
- -> Handler b (AuthManager b) (Maybe AuthUser)
-loginByUsername = undefined
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
+loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
+loginByUsername unm pwd rm = do
+ (AuthManager r _ _ _ _ _ _ _) <- get
+ au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
+ case au of
+ Nothing -> return $ Left FindFailure
+ Just au' -> checkPasswordAndLogin au' pwd rm
------------------------------------------------------------------------------
@@ -35,8 +52,9 @@ rememberUser :: Handler b (AuthManager b) (Maybe AuthUser)
rememberUser = cacheOrLookup f
where
f = do
- mgr@(AuthManager r _ _ _ rc to _) <- get
+ mgr@(AuthManager r _ _ _ _ rc to _) <- get
uid <- undefined
+ fail "rememberUser is not implemented yet"
case uid of
Nothing -> return Nothing
Just uid' -> liftIO $ lookupByUserId r uid'
@@ -57,7 +75,7 @@ currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser = cacheOrLookup f
where
f = do
- mgr@(AuthManager r s _ _ _ _ _) <- get
+ mgr@(AuthManager r s _ _ _ _ _ _) <- get
uid <- withTop s getSessionUserId
case uid of
Nothing -> return Nothing
@@ -69,7 +87,7 @@ currentUser = cacheOrLookup f
isLoggedIn :: Handler b (AuthManager b) Bool
isLoggedIn = do
au <- currentUser
- return $ if isJust au then True else False
+ return $ isJust au
-- $midlevel
@@ -79,28 +97,31 @@ isLoggedIn = do
-- | Mutate an 'AuthUser', marking failed authentication now.
markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthFail u = do
- (AuthManager r _ _ _ _ _ _) <- get
+ (AuthManager r _ _ _ _ _ _ _) <- get
proc u >>= liftIO . save r
where
proc = incFailCtr >=> checkLockout
- incFailCtr = undefined
+ incFailCtr u' = return $ u'
+ { userFailedLoginCount = userFailedLoginCount u' + 1}
checkLockout = undefined
------------------------------------------------------------------------------
-- | Mutate an 'AuthUser', marking successful authentication now.
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthSuccess u = do
- (AuthManager r _ _ _ _ _ _) <- get
- proc u >>= liftIO . save r
+ (AuthManager r _ _ _ _ _ _ _) <- get
+ now <- liftIO getCurrentTime
+ incLoginCtr u >>= updateIp >>= updateLoginTS now >>=
+ setRememberToken >>= resetFailCtr >>= liftIO . save r
where
- proc = incLoginCtr >=> updateIp >=> updateLoginTS >=>
- setRememberToken >=> resetFailCtr
- incLoginCtr = undefined
- updateIp = undefined
- updateLoginTS = undefined
- setRememberToken = undefined
- resetFailCtr = undefined
+ incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
+ updateIp u' = undefined
+ updateLoginTS now u' = return $
+ u' { userCurrentLoginAt = Just now
+ , userLastLoginAt = userCurrentLoginAt u' }
+ setRememberToken u' = undefined
+ resetFailCtr u' = return $ u' { userFailedLoginCount = 0 }
------------------------------------------------------------------------------
@@ -127,7 +148,7 @@ checkPasswordAndLogin u pw remember =
markAuthFail u
return $ Left e
Nothing -> do
- forceLoginUser u remember
+ forceLogin u remember
modify (\mgr -> mgr { activeUser = Just u })
u' <- markAuthSuccess u
return $ Right u'
@@ -138,12 +159,12 @@ checkPasswordAndLogin u pw remember =
--
-- Meant to be used if you have other means of being sure that the person is
-- who she says she is.
-forceLoginUser
+forceLogin
:: AuthUser
-> Bool -- ^ Set remember cookie?
-> Handler b (AuthManager b) Bool
-forceLoginUser u rc = do
- AuthManager _ s _ _ _ _ _ <- get
+forceLogin u rc = do
+ AuthManager _ s _ _ _ _ _ _ <- get
case userId u of
Just x -> withTop s (setSessionUserId x) >> return True
Nothing -> return False
@@ -194,11 +215,12 @@ cacheOrLookup
-> Handler b (AuthManager b) (Maybe AuthUser)
cacheOrLookup f = do
au <- gets activeUser
- if isJust au then return au
- else do
- au' <- f
- modify (\mgr -> mgr { activeUser = au' })
- return au'
+ if isJust au
+ then return au
+ else do
+ au' <- f
+ modify (\mgr -> mgr { activeUser = au' })
+ return au'
@@ -8,33 +8,40 @@ import Control.Applicative
import Control.Monad.State
import Control.Concurrent.MVar
import Data.Aeson
+import qualified Data.Attoparsec as Atto
import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString as B
import qualified Data.Map as HM
import Data.Map (Map)
import Data.Maybe (isNothing)
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Record.Label
+import Data.Lens.Lazy
import Web.ClientSession
+import System.Directory
import Snap.Snaplet.Auth.Types
import Snap.Snaplet
import Snap.Snaplet.Session
-
+------------------------------------------------------------------------------
+-- | Initialize a JSON file backed 'AuthManager'
initJsonFileAuthManager
:: AuthSettings
- -> (b :-> Snaplet SessionManager)
+ -- ^ Authentication settings for your app
+ -> Lens b (Snaplet SessionManager)
+ -- ^ Lens into a 'SessionManager' auth snaplet will use
-> 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 <- (undefined :: IO JsonFileAuthManager)
+ jsonMgr <- mkJsonAuthMgr db
return $ AuthManager {
backend = jsonMgr
, session = l
@@ -47,47 +54,74 @@ initJsonFileAuthManager s l db =
}
+-- Load an existing datafile into memory cache
+mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager
+mkJsonAuthMgr fp = do
+ db <- loadUserCache fp
+ let db' = case db of
+ Left e -> error e
+ Right x -> x
+ cache <- newMVar db'
+ return $ JsonFileAuthManager {
+ memcache = cache
+ , dbfile = fp
+ }
+
+
type UserIdCache = Map UserId AuthUser
+
instance ToJSON UserIdCache where
toJSON m = toJSON $ HM.toList m
+
instance FromJSON UserIdCache where
parseJSON = fmap HM.fromList . parseJSON
+
type LoginUserCache = Map Text UserId
type RemTokenUserCache = Map Text UserId
+-- JSON user back-end stores the user data and indexes for login and token
+-- based logins.
data UserCache = UserCache {
- uidCache :: UserIdCache
- , loginCache :: LoginUserCache
- , tokenCache :: RemTokenUserCache
- , uidCounter :: Int
+ uidCache :: UserIdCache -- the actual datastore
+ , loginCache :: LoginUserCache -- fast lookup for login field
+ , tokenCache :: RemTokenUserCache -- fast lookup for remember tokens
+ , uidCounter :: Int -- user id counter
}
-instance ToJSON UserCache where
- toJSON uc = object
- [ "uidCache" .= uidCache uc
- , "loginCache" .= loginCache uc
- , "tokenCache" .= tokenCache uc
- , "uidCounter" .= uidCounter uc]
-instance FromJSON UserCache where
- parseJSON (Object v) =
- UserCache
- <$> v .: "uidCache"
- <*> v .: "loginCache"
- <*> v .: "tokenCache"
- <*> v .: "uidCounter"
+defUserCache = UserCache {
+ uidCache = HM.empty
+ , loginCache = HM.empty
+ , tokenCache = HM.empty
+ , uidCounter = 0
+}
+
+
+loadUserCache :: FilePath -> IO (Either String UserCache)
+loadUserCache fp = do
+ chk <- doesFileExist fp
+ case chk of
+ True -> do
+ d <- B.readFile fp
+ case Atto.parseOnly json d of
+ Left e -> return . Left $ "Can't open JSON auth backend. Error: " ++ e
+ Right v -> case fromJSON v of
+ Error e -> return . Left $ "Malformed JSON auth data store. Error: " ++ e
+ Success db -> return $ Right db
+ False -> do
+ putStrLn "User JSON datafile not found. Creating a new one."
+ return $ Right defUserCache
data JsonFileAuthManager = JsonFileAuthManager {
memcache :: MVar UserCache
, dbfile :: FilePath
- , reqcache :: Maybe AuthUser
}
@@ -133,7 +167,7 @@ instance IAuthBackend JsonFileAuthManager where
where uid = UserId . showT $ uidCounter cache
e = error "getLastUser failed. This should not happen."
- destroy = undefined
+ destroy = error "JsonFile: destroy is not yet implemented"
lookupByUserId mgr uid = withCache mgr f
where f cache = return $ getUser cache uid
@@ -150,9 +184,32 @@ instance IAuthBackend JsonFileAuthManager where
withCache mgr f = withMVar (memcache mgr) f
+
getUser cache uid = HM.lookup uid (uidCache cache)
+------------------------------------------------------------------------------
+-- JSON Instances
+--
+------------------------------------------------------------------------------
+
+
+instance ToJSON UserCache where
+ toJSON uc = object
+ [ "uidCache" .= uidCache uc
+ , "loginCache" .= loginCache uc
+ , "tokenCache" .= tokenCache uc
+ , "uidCounter" .= uidCounter uc]
+
+
+instance FromJSON UserCache where
+ parseJSON (Object v) =
+ UserCache
+ <$> v .: "uidCache"
+ <*> v .: "loginCache"
+ <*> v .: "tokenCache"
+ <*> v .: "uidCounter"
+
instance ToJSON AuthUser where
toJSON u = object
@@ -199,6 +256,7 @@ instance ToJSON Password where
toJSON (ClearText _) = error "ClearText passwords can't be serialized into JSON"
toJSON (Encrypted x) = toJSON x
+
instance FromJSON Password where
parseJSON = fmap Encrypted . parseJSON
Oops, something went wrong.

0 comments on commit a7a4510

Please sign in to comment.