Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Code cleanup.

  • Loading branch information...
commit c6dd44679c508411c85aba6101d3dc035d163cec 1 parent 0ab3c14
@mightybyte mightybyte authored
View
5 examples/App.hs
@@ -20,7 +20,6 @@ import Snap.Snaplet.Session.Backends.CookieSession
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Handlers
import Snap.Snaplet.Auth.Backends.JsonFile
-import Snap.Snaplet.Auth.Types (BackendError(..))
import Text.Templating.Heist
data App = App
@@ -54,15 +53,17 @@ sessionTest = withSession session $ do
, ("csrf", liftHeist $ textSplice csrf) ]
+newUserH :: Handler App v ()
newUserH = do
renderWithSplices "registerUser" []
+registerH :: Handler b (AuthManager b) ()
registerH = do
res <- try $ registerUser "login" "password"
case res of
Left (e :: BackendError) ->
writeText $ T.concat ["Caught error: " , (T.pack . show) e]
- Right r -> writeText "Done"
+ Right _ -> writeText "Done"
------------------------------------------------------------------------------
-- |
View
43 src/Snap/Snaplet/Auth.hs
@@ -51,13 +51,13 @@ module Snap.Snaplet.Auth
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.Serialize hiding (get)
import Data.Time
-import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Text.Encoding (decodeUtf8)
import Data.Text (Text)
+import Web.ClientSession
import Snap.Core
import Snap.Snaplet
@@ -84,9 +84,9 @@ createUser
:: Text -- Username
-> ByteString -- Password
-> Handler b (AuthManager b) AuthUser
-createUser unm pass = do
+createUser unm pwd = do
(AuthManager r _ _ _ _ _ _ _) <- get
- liftIO $ AM.createUser r unm pass
+ liftIO $ AM.createUser r unm pwd
------------------------------------------------------------------------------
@@ -98,7 +98,7 @@ loginByUsername
-> Handler b (AuthManager b) (Either AuthFailure AuthUser)
loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
loginByUsername unm pwd rm = do
- AuthManager r s _ _ cn rp sk _ <- get
+ AuthManager r _ _ _ cn rp sk _ <- get
au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
case au of
Nothing -> return $ Left UserNotFound
@@ -121,7 +121,7 @@ loginByUsername unm pwd rm = do
-- | Remember user from the remember token if possible and perform login
loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
loginByRememberToken = do
- mgr@(AuthManager r _ _ _ rc rp sk _) <- get
+ (AuthManager r _ _ _ rc rp sk _) <- get
token <- getRememberToken sk rc rp
au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
case au of
@@ -146,7 +146,7 @@ currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
currentUser = cacheOrLookup f
where
f = do
- mgr@(AuthManager r s _ _ _ _ _ _) <- get
+ (AuthManager r s _ _ _ _ _ _) <- get
uid <- withTop s getSessionUserId
case uid of
Nothing -> loginByRememberToken
@@ -213,7 +213,6 @@ markAuthFail u = do
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
markAuthSuccess u = do
(AuthManager r _ _ _ _ _ _ _) <- get
- now <- liftIO getCurrentTime
incLoginCtr u >>= updateIp >>= updateLoginTS
>>= resetFailCtr >>= liftIO . save r
where
@@ -258,16 +257,16 @@ checkPasswordAndLogin u pw =
else return . Left $ LockedOut x
Nothing -> auth u
where
- auth u =
- case authenticatePassword u pw of
+ auth user =
+ case authenticatePassword user pw of
Just e -> do
- markAuthFail u
+ markAuthFail user
return $ Left e
Nothing -> do
- forceLogin u
- modify (\mgr -> mgr { activeUser = Just u })
- u' <- markAuthSuccess u
- return $ Right u'
+ forceLogin user
+ modify (\mgr -> mgr { activeUser = Just user })
+ user' <- markAuthSuccess user
+ return $ Right user'
------------------------------------------------------------------------------
@@ -297,12 +296,24 @@ forceLogin u = do
------------------------------------------------------------------------------
+getRememberToken :: (Serialize t, MonadSnap m)
+ => Key
+ -> ByteString
+ -> Maybe Int
+ -> m (Maybe t)
getRememberToken sk rc rp = getSecureCookie rc sk rp
+setRememberToken :: (Serialize t, MonadSnap m)
+ => Key
+ -> ByteString
+ -> Maybe Int
+ -> t
+ -> m ()
setRememberToken sk rc rp token = setSecureCookie rc sk rp token
+forgetRememberToken :: MonadSnap m => ByteString -> m ()
forgetRememberToken rc = expireCookie rc (Just "/")
View
7 src/Snap/Snaplet/Auth/AuthManager.hs
@@ -19,16 +19,9 @@ module Snap.Snaplet.Auth.AuthManager
) 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
View
44 src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -18,7 +18,7 @@ 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, fromJust, isJust)
+import Data.Maybe (fromJust, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Lens.Lazy
@@ -50,14 +50,14 @@ initJsonFileAuthManager s l db =
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
+ backend = jsonMgr
+ , session = l
+ , activeUser = Nothing
+ , minPasswdLen = asMinPasswdLen s
+ , rememberCookieName = asRememberCookieName s
+ , rememberPeriod = asRememberPeriod s
+ , siteKey = key
+ , lockout = asLockout s
}
@@ -98,18 +98,19 @@ 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 -- the actual datastore
- , loginCache :: LoginUserCache -- fast lookup for login field
- , tokenCache :: RemTokenUserCache -- fast lookup for remember tokens
- , uidCounter :: Int -- user id counter
+ uidCache :: UserIdCache -- the actual datastore
+ , loginCache :: LoginUserCache -- fast lookup for login field
+ , tokenCache :: RemTokenUserCache -- fast lookup for remember tokens
+ , uidCounter :: Int -- user id counter
}
+defUserCache :: UserCache
defUserCache = UserCache {
- uidCache = HM.empty
- , loginCache = HM.empty
- , tokenCache = HM.empty
- , uidCounter = 0
+ uidCache = HM.empty
+ , loginCache = HM.empty
+ , tokenCache = HM.empty
+ , uidCounter = 0
}
@@ -130,8 +131,8 @@ loadUserCache fp = do
data JsonFileAuthManager = JsonFileAuthManager {
- memcache :: TVar UserCache
- , dbfile :: FilePath
+ memcache :: TVar UserCache
+ , dbfile :: FilePath
}
@@ -172,7 +173,7 @@ instance IAuthBackend JsonFileAuthManager where
let uid' = UserId . showT $ uidCounter cache + 1
let u' = u { userUpdatedAt = Just now, userId = Just uid' }
return $ cache {
- uidCache = HM.insert uid' u' $ uidCache cache
+ uidCache = HM.insert uid' u' $ uidCache cache
, loginCache = HM.insert (userLogin u') uid' $ loginCache cache
, tokenCache = case userRememberToken u' of
Nothing -> tokenCache cache
@@ -240,11 +241,13 @@ instance IAuthBackend JsonFileAuthManager where
where getUid = HM.lookup token (tokenCache cache)
+withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache mgr f = atomically $ do
cache <- readTVar $ memcache mgr
return $ f cache
+getUser :: UserCache -> UserId -> Maybe AuthUser
getUser cache uid = HM.lookup uid (uidCache cache)
@@ -321,4 +324,5 @@ instance FromJSON Password where
parseJSON = fmap Encrypted . parseJSON
+showT :: Int -> Text
showT = T.pack . show
View
10 src/Snap/Snaplet/Auth/Handlers.hs
@@ -20,17 +20,12 @@ module Snap.Snaplet.Auth.Handlers
import Control.Monad.CatchIO (throw)
import Control.Monad.State
-import Crypto.PasswordStore
import Data.ByteString (ByteString)
import Data.Lens.Lazy
import Data.Text.Encoding (decodeUtf8)
-import Data.Text (Text)
-import Data.Time
import Snap.Core
import Snap.Snaplet.Auth
-import Snap.Snaplet.Auth.AuthManager (AuthManager(..))
-import Snap.Snaplet.Auth.Types
import Snap.Snaplet
@@ -41,13 +36,12 @@ registerUser
-> ByteString -- Password field
-> Handler b (AuthManager b) AuthUser
registerUser lf pf = do
- (AuthManager r _ _ _ _ _ _ _) <- get
l <- fmap decodeUtf8 `fmap` getParam lf
p <- getParam pf
case liftM2 (,) l p of
Nothing -> throw PasswordMissing
- Just (lgn, pass) -> do
- createUser lgn pass
+ Just (lgn, pwd) -> do
+ createUser lgn pwd
------------------------------------------------------------------------------
View
10 src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -17,21 +17,11 @@ module Snap.Snaplet.Auth.SpliceHelpers
, ifLoggedOut
) where
-import Control.Monad.CatchIO (throw)
-import Control.Monad.State
-import Crypto.PasswordStore
-import Data.ByteString (ByteString)
import Data.Lens.Lazy
-import Data.Text.Encoding (decodeUtf8)
-import Data.Text (Text)
-import Data.Time
import qualified Text.XmlHtml as X
import Text.Templating.Heist
-import Snap.Core
import Snap.Snaplet.Auth
-import Snap.Snaplet.Auth.AuthManager (AuthManager(..))
-import Snap.Snaplet.Auth.Types
import Snap.Snaplet
import Snap.Snaplet.Heist
View
6 src/Snap/Snaplet/Auth/Types.hs
@@ -7,20 +7,14 @@ module Snap.Snaplet.Auth.Types 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 Crypto.PasswordStore
-import Web.ClientSession
-
-import Snap.Snaplet
-import Snap.Snaplet.Session
------------------------------------------------------------------------------
View
2  test/suite/Blackbox/Common.hs
@@ -1,7 +1,5 @@
module Blackbox.Common where
-import Control.Monad.Trans
-import Data.Configurator
import qualified Data.Text as T
import Snap.Core
import Snap.Snaplet
View
3  test/suite/Blackbox/EmbeddedSnaplet.hs
@@ -15,9 +15,6 @@ import Control.Monad.State
import Data.Lens.Lazy
import Data.Lens.Template
import qualified Data.Text as T
-import Snap.Http.Server.Config
-import Snap.Core
-import Snap.Util.FileServe
import System.FilePath.Posix
import Snap.Snaplet
View
11 test/suite/Snap/Snaplet/Internal/LensT/Tests.hs
@@ -4,7 +4,6 @@ module Snap.Snaplet.Internal.LensT.Tests (tests) where
import Control.Applicative
import Control.Category
-import Control.Exception
import Control.Monad.Identity
import Control.Monad.State.Strict
import Data.Lens.Template
@@ -43,6 +42,7 @@ defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3
------------------------------------------------------------------------------
+tests :: Test
tests = testGroup "Snap.Snaplet.Internal.LensT"
[ testfmap
, testApplicative
@@ -59,8 +59,8 @@ testfmap = testCase "lensed/fmap" $ do
let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)
- assertEqual "fmap2" 12 y
- assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'
+ assertEqual "fmap2" (12 :: Int) y
+ assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s'
return ()
where
@@ -117,8 +117,3 @@ testMonadState = testCase "lens/MonadState" $ do
with sub0 $ put $ a+1
-eat :: SomeException -> IO ()
-eat _ = return ()
-
-qqq = defaultMainWithArgs [tests] ["--plain"] `catch` eat
-
View
10 test/suite/Snap/Snaplet/Internal/RST/Tests.hs
@@ -7,22 +7,14 @@ module Snap.Snaplet.Internal.RST.Tests
( tests ) where
import Control.Applicative
-import Control.Category
-import Control.Exception
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
-import Data.ByteString.Char8 (ByteString)
-import Data.Lens.Template
-import Data.List
-import Data.Word
import Prelude hiding (catch, (.))
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding (Test, path)
-import Test.QuickCheck
-import Test.QuickCheck.Monadic
import Snap.Snaplet.Internal.RST
@@ -71,5 +63,5 @@ rstAlt2 :: Maybe (Int, Int)
rstAlt2 = runRST (addEnv >> ((return 5) <|> empty)) 1 0
rstFail :: Maybe Int
-rstFail = evalRST (fail "foo") 0 0
+rstFail = evalRST (fail "foo") (0 :: Int) (0 :: Int)
View
55 test/suite/Snap/Snaplet/Internal/Tests.hs
@@ -8,28 +8,22 @@ module Snap.Snaplet.Internal.Tests
import Control.Monad
import Control.Monad.Trans
-import Data.ByteString.Char8 (ByteString)
+import Data.ByteString (ByteString)
import Data.Lens.Template
import Data.List
-import Data.Word
+import Data.Text
import Prelude hiding (catch, (.))
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
-import Test.QuickCheck
-import Test.QuickCheck.Monadic
import Snap.Snaplet.Internal.Initializer
import Snap.Snaplet.Internal.Types
-data Foo = Foo
- { fooVal :: Int
- }
+data Foo = Foo Int
-data Bar = Bar
- { barVal :: Int
- }
+data Bar = Bar Int
data App = App
@@ -39,15 +33,17 @@ data App = App
makeLens ''App
-showConfig c = do
- putStrLn "SnapletConfig:"
- print $ _scAncestry c
- print $ _scFilePath c
- print $ _scId c
- print $ _scDescription c
- print $ _scRouteContext c
- putStrLn ""
-
+--showConfig :: SnapletConfig -> IO ()
+--showConfig c = do
+-- putStrLn "SnapletConfig:"
+-- print $ _scAncestry c
+-- print $ _scFilePath c
+-- print $ _scId c
+-- print $ _scDescription c
+-- print $ _scRouteContext c
+-- putStrLn ""
+
+assertGet :: (MonadIO m, Eq a) => String -> m a -> a -> m ()
assertGet name getter val = do
v <- getter
-- When I add these three lines I get a strange error from GHC:
@@ -57,12 +53,16 @@ assertGet name getter val = do
-- liftIO $ putStrLn $ "{--- "++(show val)++" ---}"
liftIO $ assertBool name $ v == val
-configAssertions pre (a,f,n,d,r) = do
- assertGet (pre++"ancestry") getSnapletAncestry a
- assertGet (pre++"file path") getSnapletFilePath f
- assertGet (pre++"name") getSnapletName n
- assertGet (pre++"description") getSnapletDescription d
- assertGet (pre++"route context") getSnapletRootURL r
+configAssertions :: (MonadSnaplet m, MonadIO (m b v))
+ => [Char]
+ -> ([Text], FilePath, Maybe Text, Text, ByteString)
+ -> m b v ()
+configAssertions prefix (a,f,n,d,r) = do
+ assertGet (prefix++"ancestry") getSnapletAncestry a
+ assertGet (prefix++"file path") getSnapletFilePath f
+ assertGet (prefix++"name") getSnapletName n
+ assertGet (prefix++"description") getSnapletDescription d
+ assertGet (prefix++"route context") getSnapletRootURL r
appInit :: SnapletInit App App
appInit = makeSnaplet "app" "Test application" Nothing $ do
@@ -72,18 +72,21 @@ appInit = makeSnaplet "app" "Test application" Nothing $ do
b <- nestSnaplet "bar" bar $ barInit
return $ App f b
+fooInit :: SnapletInit b Foo
fooInit = makeSnaplet "foo" "Foo Snaplet" Nothing $ do
configAssertions "foo "
(["app"], "snaplets/foo", Just "foo", "Foo Snaplet", "foo")
return $ Foo 42
+barInit :: SnapletInit b Bar
barInit = makeSnaplet "bar" "Bar Snaplet" Nothing $ do
configAssertions "bar "
(["app"], "snaplets/bar", Just "bar", "Bar Snaplet", "bar")
return $ Bar 2
+initTest :: IO ()
initTest = do
- (out,handler,cleanup) <- runSnaplet appInit
+ (out,_,_) <- runSnaplet appInit
if out == "aoeu" then putStrLn "Something really strange" else return ()
tests :: Test
Please sign in to comment.
Something went wrong with that request. Please try again.