content: module Snap.Snaplet.Auth.Types.Tests (
    tests
    ) where
  
  ------------------------------------------------------------------------------
  import           Control.Exception                    (SomeException, evaluate, try)
  import           Control.Monad                        (liftM)
  import           Data.Aeson                           (decode, eitherDecode, encode)
  import qualified Data.ByteString                      as BS
  import qualified Data.ByteString.Lazy.Char8           as BSL
  import qualified Data.Text                            as T
  import           Data.Text.Encoding                   (encodeUtf8)
  import           Data.Time
  import           Test.Framework                       (Test, testGroup)
  import           Test.Framework.Providers.HUnit       (testCase)
  import           Test.Framework.Providers.QuickCheck2 (testProperty)
  import           Test.HUnit                           hiding (Test)
  import qualified Test.QuickCheck                      as QC
  import qualified Test.QuickCheck.Monadic              as QCM
  ------------------------------------------------------------------------------
  import qualified Snap.Snaplet.Auth                    as A
  import           Snap.TestCommon                      (eqTestCase, ordTestCase, readTestCase, showTestCase)
  
  
  ------------------------------------------------------------------------------
  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 (A.Role "a")
    , testCase     "Test Role Read instance"         $ readTestCase (A.Role "a")
    , testCase     "Test Role Ord  instance"         $
      ordTestCase (A.Role "a") (A.Role "b")
    , testCase     "Test PW Show instance"           $
      showTestCase (A.ClearText "pw")
    , testCase     "Test PW Read instance"           $
      readTestCase (A.ClearText "pw")
    , testCase     "Test PW Ord  instance"           $
      ordTestCase (A.ClearText "a") (A.ClearText "b")
    , testCase     "Test AuthFailure Eq instance"    $
      eqTestCase A.BackendError A.DuplicateLogin --TODO better as property
    , testCase     "Test AuthFailure Show instance"  $
      showTestCase A.BackendError
  --  , testCase     "Test AuthFailure Read instance"  $
  --    readTestCase BackendError -- TODO/NOTE: show . read isn't id for
    , testCase     "Test AuthFailure Ord instance"   $
      ordTestCase A.BackendError A.DuplicateLogin
    , testCase     "Test UserId Show instance"       $
      showTestCase (A.UserId "1")
    , testCase     "Test UserId Read instance"       $
      readTestCase (A.UserId "2")
    , testCase     "Test AuthUser Show instance"     $
      showTestCase A.defAuthUser
    , testCase     "Test AuthUser Eq instance"       $
      eqTestCase A.defAuthUser A.defAuthUser
    ]
  
  
  ------------------------------------------------------------------------------
  dontSerializeClearText :: Assertion
  dontSerializeClearText = do
    let s = encode (A.ClearText "passwordisnthamster")
    -- Take the length of the ByteString to force it completely, rather than
    -- using deepseq; BSL.ByteString lacked an NFData instance until
    -- bytestring-0.10.
    r <- try $ evaluate (BSL.length s) >> 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" [] (A.userRoles u))
    (eitherDecode . BSL.fromChunks . (:[]) . encodeUtf8 $
     sampleUserJson "\"activated_at\":null" "\"extra\":null")
  
  
  ------------------------------------------------------------------------------
  failDeserialize :: Assertion
  failDeserialize = do
    case decode . BSL.fromChunks . (:[]) . encodeUtf8 $ t of
      Nothing -> return ()
      Just a  -> assertFailure $
                 "Expected deserialization failure, got authUser: "
                 ++ show (a :: A.AuthUser)
  
    where
      t = T.replace "login" "loogin" $
          sampleUserJson "\"extra\":null" "\"extra2\":null"
  
  
  ------------------------------------------------------------------------------
  authFailureShows :: A.AuthFailure -> Bool
  authFailureShows ae = length (show ae) > 0
  
  
  ------------------------------------------------------------------------------
  instance QC.Arbitrary A.AuthFailure where
    arbitrary = do
      s <- (QC.arbitrary `QC.suchThat` (( > 0 ) . length))
      tA <- QC.arbitrary
      tB <- QC.arbitrary
      let t = UTCTime
              (ModifiedJulianDay tA)
              (realToFrac (tB :: Double))
      QC.oneof $ map return [A.AuthError s,       A.BackendError
                            ,A.DuplicateLogin,    A.EncryptedPassword
                            ,A.IncorrectPassword, A.LockedOut t
                            ,A.PasswordMissing,   A.UsernameMissing
                            ,A.UserNotFound
                            ]
  
  
  ------------------------------------------------------------------------------
  encryptByteString :: QC.Property
  encryptByteString = QCM.monadicIO testStringEq
    where
      clearPw = BS.pack `liftM` (QC.arbitrary `QC.suchThat` ((>0) . length))
      testStringEq = QCM.forAllM clearPw $ \s -> do
        ePW  <- A.Encrypted `liftM` (QCM.run $ A.encrypt s)
  
        let cPW  = A.ClearText s
  {-      ePW' <- QCM.run $ encryptPassword (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 $ (A.checkPassword cPW ePW
                      && A.checkPassword cPW (A.ClearText s))
  
  
  ------------------------------------------------------------------------------
  rejectCheckClearText :: Assertion
  rejectCheckClearText = do
    let b = A.checkPassword (A.Encrypted "") (A.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"
  
  