diff --git a/devel.cfg b/devel.cfg new file mode 100644 index 00000000..652d50a5 --- /dev/null +++ b/devel.cfg @@ -0,0 +1,5 @@ +minPasswordLen = 20 +rememberCookie = "myCookie" +rememberPeriod = 500000 +lockout = [10,100000] +siteKey = "my_site_key.txt" \ No newline at end of file diff --git a/runTestsAndCoverage.sh b/runTestsAndCoverage.sh index ffee7f70..bcaa7cc1 100755 --- a/runTestsAndCoverage.sh +++ b/runTestsAndCoverage.sh @@ -49,6 +49,8 @@ Snap.TestCommon Snap.Snaplet.Test.App Snap.Snaplet.Test.Tests Snap.Snaplet.Auth.SpliceTests +Snap.Snaplet.Auth.Types.Tests +Snap.Snaplet.Config.App Snap.Snaplet.Config.Tests ' diff --git a/snap.cabal b/snap.cabal index f0120c16..190064eb 100644 --- a/snap.cabal +++ b/snap.cabal @@ -233,6 +233,7 @@ Test-suite testsuite build-depends: aeson >= 0.6 && < 0.8, + async, attoparsec >= 0.10 && < 0.13, base >= 4.4 && < 5, blaze-builder, @@ -242,6 +243,7 @@ Test-suite testsuite comonad >= 1.1 && < 4.3, configurator >= 0.1 && < 0.3, containers >= 0.3 && < 0.6, + deepseq, directory >= 1.0 && < 1.3, directory-tree >= 0.11 && < 0.13, dlist >= 0.5 && < 0.8, diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs index e745951e..50a2fec5 100644 --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -18,7 +18,7 @@ import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable) import Data.Time import Data.Text (Text) -import Data.Text.Encoding +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable import Snap.Snaplet diff --git a/test/suite/Snap/Snaplet/Auth/App.hs b/test/suite/Snap/Snaplet/Auth/App.hs index 7197a76d..7420afff 100644 --- a/test/suite/Snap/Snaplet/Auth/App.hs +++ b/test/suite/Snap/Snaplet/Auth/App.hs @@ -9,6 +9,7 @@ module Snap.Snaplet.Auth.App , heist , authInit , appInit + , appInit' ) where @@ -28,6 +29,7 @@ import Snap.Snaplet.Auth.Backends.JsonFile import Snap.Snaplet.Session.Backends.CookieSession import Snap.Snaplet.Heist + ------------------------------------------------------------------------------ data App = App { _sess :: Snaplet SessionManager @@ -39,14 +41,17 @@ $(makeLenses ''App) instance HasHeist App where heistLens = subSnaplet heist + +------------------------------------------------------------------------------ compiledSplices :: Splices (C.Splice (Handler App App)) compiledSplices = do "userSplice" #! C.withSplices C.runChildren userCSplices $ lift $ maybe pass return =<< with auth currentUser + ------------------------------------------------------------------------------ -appInit :: SnapletInit App App -appInit = makeSnaplet "app" "Test application" Nothing $ do +appInit' :: Bool -> SnapletInit App App +appInit' useConfigFile = makeSnaplet "app" "Test application" Nothing $ do h <- nestSnaplet "heist" heist $ heistInit' @@ -57,7 +62,11 @@ appInit = makeSnaplet "app" "Test application" Nothing $ do s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" (Just 3600) - a <- nestSnaplet "auth" auth authInit + authSettings <- if useConfigFile + then authSettingsFromConfig + else return defAuthSettings + + a <- nestSnaplet "auth" auth $ authInit authSettings addAuthSplices h auth @@ -65,7 +74,12 @@ appInit = makeSnaplet "app" "Test application" Nothing $ do ------------------------------------------------------------------------------ -authInit :: SnapletInit App (AuthManager App) -authInit = initJsonFileAuthManager - defAuthSettings { asLockout = Just (3, 1) } +appInit :: SnapletInit App App +appInit = appInit' False + + +------------------------------------------------------------------------------ +authInit :: AuthSettings -> SnapletInit App (AuthManager App) +authInit settings = initJsonFileAuthManager + settings { asLockout = Just (3, 1) } sess "users.json" diff --git a/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs b/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs index 700d7df8..8785bd9a 100644 --- a/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs +++ b/test/suite/Snap/Snaplet/Auth/Handlers/Tests.hs @@ -28,7 +28,9 @@ tests :: Test tests = testGroup "Snap.Snaplet.Auth.Handlers" [mutuallyExclusive $ testGroup "createUser tests" [ testCreateUserGood + , testWithCfgFile , testCreateUserTimely + , testCreateUserWithRole , testCreateEmptyUser , testCreateDupUser , testUsernameExists @@ -87,6 +89,17 @@ testCreateUserGood = testCase "createUser good params" assertGoodUser failMsg = "createUser failed: Couldn't create a new user." +------------------------------------------------------------------------------ +testWithCfgFile :: Test +testWithCfgFile = testCase "createUser with config file settings" assertCfg + where + assertCfg :: Assertion + assertCfg = withTemporaryFile "users.json" $ do + let hdl = with auth $ createUser "foo" "foo" + res <- runHandler Nothing (ST.get "" Map.empty) hdl (appInit' True) + either (assertFailure . show) ST.assertSuccess res + + ------------------------------------------------------------------------------ testCreateUserTimely :: Test testCreateUserTimely = testCase "createUser good updatedAt" assertCreateTimely @@ -106,6 +119,27 @@ testCreateUserTimely = testCase "createUser good updatedAt" assertCreateTimely failMsg = "createUser: userUpdatedAt, userCreatetAt times not set" +------------------------------------------------------------------------------ +testCreateUserWithRole :: Test +testCreateUserWithRole = testCase "createUser with role" assertUserRole + where + assertUserRole :: Assertion + assertUserRole = withTemporaryFile "users.json" $ do + let hdl = with auth $ runMaybeT $ do + u <- hushT $ EitherT $ createUser "foo" "foo" + _ <- hushT $ EitherT $ + saveUser $ u {userRoles = [Role "admin",Role "user"]} + hushT $ EitherT $ + loginByUsername "foo" (ClearText "foo") False + res <- evalHandler Nothing (ST.get "" Map.empty) hdl appInit + case res of + Left e -> assertFailure $ show e + Right Nothing -> assertFailure "Failed saved user lookup" + Right (Just usr) -> assertEqual "Roles don't match expectation" + [Role "admin",Role "user"] + (userRoles usr) + + ------------------------------------------------------------------------------ testCreateEmptyUser :: Test testCreateEmptyUser = testCase "createUser empty username" assertEmptyUser diff --git a/test/suite/Snap/Snaplet/Auth/Tests.hs b/test/suite/Snap/Snaplet/Auth/Tests.hs index 1ca57c5a..b7826e65 100644 --- a/test/suite/Snap/Snaplet/Auth/Tests.hs +++ b/test/suite/Snap/Snaplet/Auth/Tests.hs @@ -9,6 +9,7 @@ module Snap.Snaplet.Auth.Tests ------------------------------------------------------------------------------ import Test.Framework import qualified Snap.Snaplet.Auth.Handlers.Tests +import qualified Snap.Snaplet.Auth.Types.Tests import qualified Snap.Snaplet.Auth.SpliceTests @@ -17,5 +18,6 @@ tests :: Test tests = testGroup "Snap.Snaplet.Auth" [ Snap.Snaplet.Auth.Handlers.Tests.tests , Snap.Snaplet.Auth.SpliceTests.tests + , Snap.Snaplet.Auth.Types.Tests.tests ] diff --git a/test/suite/Snap/Snaplet/Auth/Types/Tests.hs b/test/suite/Snap/Snaplet/Auth/Types/Tests.hs new file mode 100644 index 00000000..cf28e4b5 --- /dev/null +++ b/test/suite/Snap/Snaplet/Auth/Types/Tests.hs @@ -0,0 +1,184 @@ +module Snap.Snaplet.Auth.Types.Tests ( + tests + ) where + +------------------------------------------------------------------------------ +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time +import Data.Time.Clock +import GHC.Read +import Test.HUnit hiding (Test) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QCM +import Text.ParserCombinators.ReadPrec +------------------------------------------------------------------------------ +import Snap.Core +import qualified Snap.Test as ST +import Snap.Snaplet.Test +import Heist +import Snap.Snaplet.Auth +import Snap.Snaplet.Heist +import Snap.TestCommon + +------------------------------------------------------------------------------ +tests :: Test +tests = testGroup "Auth type tests" [ + testCase "Password serialization" dontSerializeClearText + , testCase "Fill in [] roles" deserializeDefaultRoles + , testCase "Fail deserialization" failDeserialize + , testProperty "AuthFailure show instances" authFailureShows + , testProperty "Encrypt agrees with password" encryptByteString + , testCase "Reject clear encrypted pw check" rejectCheckClearText + , testCase "Test Role Show instance" $ showTestCase (Role "a") + , testCase "Test Role Read instance" $ readTestCase (Role "a") + , testCase "Test Role Ord instance" $ + ordTestCase (Role "a") (Role "b") + , testCase "Test PW Show instance" $ + showTestCase (ClearText "pw") + , testCase "Test PW Read instance" $ + readTestCase (ClearText "pw") + , testCase "Test PW Ord instance" $ + ordTestCase (ClearText "a") (ClearText "b") + , testCase "Test AuthFailure Eq instance" $ + eqTestCase BackendError DuplicateLogin --TODO better as property + , testCase "Test AuthFailure Show instance" $ + showTestCase BackendError +-- , testCase "Test AuthFailure Read instance" $ +-- readTestCase BackendError -- TODO/NOTE: show . read isn't id for + , testCase "Test AuthFailure Ord instance" $ + ordTestCase BackendError DuplicateLogin + , testCase "Test UserId Show instance" $ + showTestCase (UserId "1") + , testCase "Test UserId Read instance" $ + readTestCase (UserId "2") + , testCase "Test AuthUser Show instance" $ + showTestCase defAuthUser + , testCase "Test AuthUser Eq instance" $ + eqTestCase defAuthUser defAuthUser + ] + + +------------------------------------------------------------------------------ +dontSerializeClearText :: Assertion +dontSerializeClearText = do + let s = encode (ClearText "passwordisnthamster") + r <- try $ s `deepseq` return s + case r of + Left e -> (e :: SomeException) `seq` return () + Right j -> assertFailure $ + "Failed to reject ClearText password serialization: " + ++ show j + + +------------------------------------------------------------------------------ +sampleUserJson :: T.Text -> T.Text -> T.Text +sampleUserJson reqPair optPair = T.intercalate "," [ + "{\"uid\":\"1\"" + , "\"login\":\"foo\"" + , "\"email\":\"test@example.com\"" + , "\"pw\":\"sha256|12|gz47sA0OvbVjos51OJRauQ==|Qe5aU2zAH0gIKHP68KrHJkvvwTvTAqA6UgA33BRpNEo=\"" + , reqPair + , "\"suspended_at\":null" + , "\"remember_token\":\"81160620ef9b64865980c2ab760fcf7f14c06e057cbe1e723cba884a9be05547\"" + , "\"login_count\":2" + , "\"failed_login_count\":1" + , "\"locked_until\":null" + , "\"current_login_at\":\"2014-06-24T14:43:51.241Z\"" + , "\"last_login_at\":null" + , "\"current_ip\":\"127.0.0.1\"" + , "\"last_ip\":null" + , "\"created_at\":\"2014-06-24T14:43:51.236Z\"" + , "\"updated_at\":\"2014-06-24T14:43:51.242Z\"" + , "\"reset_token\":null" + , "\"reset_requested_at\":null" + , optPair + , "\"meta\":{}}" + ] + + +------------------------------------------------------------------------------ +deserializeDefaultRoles :: Assertion +deserializeDefaultRoles = + either + (\e -> assertFailure $ "Failed user deserialization: " ++ e) + (\u -> assertEqual "Roles wasn't initialized to empty" [] (userRoles u)) + (eitherDecode . BSL.fromStrict . encodeUtf8 $ + sampleUserJson "\"activated_at\":null" "\"extra\":null") + + +------------------------------------------------------------------------------ +failDeserialize :: Assertion +failDeserialize = do + case decode . BSL.fromStrict . encodeUtf8 $ t of + Nothing -> return () + Just a -> assertFailure $ + "Expected deserialization failure, got authUser: " + ++ show (a :: AuthUser) + + where + t = T.replace "login" "loogin" $ + sampleUserJson "\"extra\":null" "\"extra2\":null" + + +------------------------------------------------------------------------------ +authFailureShows :: AuthFailure -> Bool +authFailureShows ae = length (show ae) > 0 + + +------------------------------------------------------------------------------ +instance Arbitrary AuthFailure where + arbitrary = do + s <- (arbitrary `suchThat` (( > 0 ) . length)) + tA <- arbitrary + tB <- arbitrary + let t = UTCTime + (ModifiedJulianDay tA) + (realToFrac (tB :: Double)) + oneof (map return [AuthError s, BackendError, DuplicateLogin + ,EncryptedPassword, IncorrectPassword, LockedOut t + ,PasswordMissing, UsernameMissing, UserNotFound]) + + +------------------------------------------------------------------------------ +encryptByteString :: Property +encryptByteString = QCM.monadicIO testStringEq + where + clearPw = BS.pack `liftM` (arbitrary `suchThat` ((>0) . length)) + testStringEq = QCM.forAllM clearPw $ \s -> do + ePW <- Encrypted `liftM` (QCM.run $ encrypt s) + ePW' <- QCM.run $ encryptPassword (ClearText s) + let cPW = ClearText s +{- QCM.assert $ (checkPassword cPW ePW + && checkPassword cPW cPW + && checkPassword ePW ePW') --TODO/NOTe: This fails. + Surpsising? + Encrypt twice and get two + different password hashes -} + QCM.assert $ (checkPassword cPW ePW + && checkPassword cPW (ClearText s)) + + +------------------------------------------------------------------------------ +rejectCheckClearText :: Assertion +rejectCheckClearText = do + let b = checkPassword (Encrypted "") (ClearText "") + r <- try $ b `seq` return b + case r of + Left e -> (e :: SomeException) `seq` return () + Right _ -> assertFailure + "checkPassword should not accept encripted-clear pair" + diff --git a/test/suite/Snap/Snaplet/Config/App.hs b/test/suite/Snap/Snaplet/Config/App.hs index 5fc876ca..84486f7d 100644 --- a/test/suite/Snap/Snaplet/Config/App.hs +++ b/test/suite/Snap/Snaplet/Config/App.hs @@ -4,15 +4,19 @@ module Snap.Snaplet.Config.App where ------------------------------------------------------------------------------ +import Control.Concurrent.Async import Control.Lens +import Control.Monad.IO.Class ------------------------------------------------------------------------------ import Heist import Snap.Core +import Snap.Http.Server.Config import Snap.Snaplet import Snap.Snaplet.Auth import Snap.Snaplet.Auth.Backends.JsonFile import Snap.Snaplet.Config import Snap.Snaplet.Heist +import Snap.Snaplet.Internal.Initializer import Snap.Snaplet.Session import Snap.Snaplet.Session.Backends.CookieSession @@ -24,6 +28,8 @@ data App = App { } $(makeLenses ''App) +instance HasHeist App where + heistLens = subSnaplet heist ------------------------------------------------------------------------------ appInit :: SnapletInit App App @@ -34,6 +40,11 @@ appInit = makeSnaplet "app" "Test application" Nothing $ do s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" (Just 3600) +-- liftIO $ print $ appOpts defaultConfig + cfg <- liftIO $ completeConfig =<< commandLineAppConfig defaultConfig :: Initializer App App (Config (Handler App App) AppConfig) --TODO doesn't seem to touch tests + + liftIO $ print cfg + return $ App h a s diff --git a/test/suite/Snap/Snaplet/Config/Tests.hs b/test/suite/Snap/Snaplet/Config/Tests.hs index 08a5a182..bb1e10c0 100644 --- a/test/suite/Snap/Snaplet/Config/Tests.hs +++ b/test/suite/Snap/Snaplet/Config/Tests.hs @@ -1,12 +1,27 @@ module Snap.Snaplet.Config.Tests where ------------------------------------------------------------------------------ +import Control.Concurrent +import Control.Concurrent.Async import Control.Monad +import qualified Data.ByteString.Char8 as BS +import qualified Data.Configurator.Types as C import Data.Function +import qualified Data.Map as Map import Data.Monoid import Data.Typeable +import System.Environment +import System.Process ------------------------------------------------------------------------------ +import Snap.Core +import Snap.Http.Server.Config +import Snap.Snaplet import Snap.Snaplet.Config +import Snap.Snaplet.Heist +import Snap.Snaplet.Config.App +import Snap.Snaplet.Internal.Initializer +import qualified Snap.Test as ST +import Snap.Snaplet.Test import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 @@ -21,6 +36,7 @@ configTests = testGroup "Snaplet Config" , testProperty "Monoid right identity" monoidRightIdentity , testProperty "Monoid associativity" monoidAssociativity , testCase "Verify Typeable instance" verTypeable +-- , testCase "Config options used" appConfigGetsToConfig ] newtype ArbAppConfig = ArbAppConfig { unArbAppConfig :: AppConfig } @@ -49,9 +65,25 @@ monoidAssociativity :: ArbAppConfig -> ArbAppConfig -> ArbAppConfig -> Bool monoidAssociativity a b c = (a <> b) <> c == a <> (b <> c) + ------------------------------------------------------------------------------ verTypeable :: Assertion verTypeable = assertEqual "Unexpected Typeable behavior" "Snap.Snaplet.Config.AppConfig" (tyConString . typeRepTyCon . typeOf $ (undefined :: AppConfig)) + + +------------------------------------------------------------------------------ +appConfigGetsToConfig :: Assertion +appConfigGetsToConfig = do + opts <- completeConfig =<< + commandLineAppConfig defaultConfig :: IO (Config Snap AppConfig) + a <- async . withArgs ["-p", "8001","-e","otherEnv"] $ + serveSnaplet opts appInit + threadDelay 500000 + cancel a + b <- async . withArgs ["--environment","devel"] $ serveSnaplet defaultConfig appInit + threadDelay 500000 + cancel b + --TODO - Don't just run the server to touch the config code. Check some values diff --git a/test/suite/Snap/TestCommon.hs b/test/suite/Snap/TestCommon.hs index 6c71ed89..537d28ac 100644 --- a/test/suite/Snap/TestCommon.hs +++ b/test/suite/Snap/TestCommon.hs @@ -2,8 +2,9 @@ module Snap.TestCommon where ------------------------------------------------------------------------------ import Control.Exception (try, SomeException) -import Test.HUnit (assertFailure) - +import GHC.Read +import Test.HUnit (Assertion, assertFailure, assertBool) +import Text.ParserCombinators.ReadPrec ------------------------------------------------------------------------------ expectException :: String -> IO a -> IO () @@ -11,4 +12,41 @@ expectException s m = do r <- try m case r of Left (e::SomeException) -> length (show e) `seq` return () - Right _ -> assertFailure s \ No newline at end of file + Right _ -> assertFailure s + + +------------------------------------------------------------------------------ +showTestCase :: Show a => a -> Assertion +showTestCase a = assertBool "Show instance failed" $ + ((showsPrec 5 a) "" == show a) + && (showList [a]) "" == "[" ++ show a ++ "]" + + +------------------------------------------------------------------------------ +readTestCase :: (Eq a, Show a, Read a) => a -> Assertion +readTestCase a = assertBool "Read instance failed" $ + ( ((readsPrec 1) (show a)) == ([(a,"")])) + && ((readList ("[" ++ show a ++ "]")) == [([a],"")]) + && ((readPrec_to_S (readPrec) 5) (show a) == [(a,"")]) + && ((readPrec_to_S (readListPrec) 5) ("[" ++ show a ++ "]") + == [([a],"")]) + + +------------------------------------------------------------------------------ +ordTestCase :: (Eq a, Ord a) => a -> a -> Assertion +ordTestCase a b = assertBool "Ord instance failed" $ + low <= high + && (if low /= high + then low < high && compare low high == LT && high > low + else low == high && compare low high == EQ) + where + low = min a b + high = max a b + + +------------------------------------------------------------------------------ +eqTestCase :: (Eq a) => a -> a -> Assertion +eqTestCase a b = assertBool "Eq instance failed" $ + if a == b + then (a /= b) == False + else (a /= b) == True diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs index c44d2596..214b62a1 100644 --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -63,6 +63,9 @@ main = do , Snap.Snaplet.Heist.Tests.heistTests , Snap.Snaplet.Config.Tests.configTests + , Snap.Snaplet.Internal.RST.Tests.tests + , Snap.Snaplet.Internal.LensT.Tests.tests + , Snap.Snaplet.Internal.Lensed.Tests.tests ]