content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  module Web.Users.TestSpec
      ( makeUsersSpec )
  where
  
  import Web.Users.Types
  
  import Control.Concurrent (threadDelay)
  import Control.Monad
  import Test.Hspec
  import qualified Data.Text as T
  
  mkUser :: T.Text -> T.Text -> User
  mkUser name email =
      User
      { u_name = name
      , u_email = email
      , u_password = makePassword "1234"
      , u_active = False
      }
  
  assertRight :: Show a => IO (Either a b) -> (b -> IO ()) -> IO ()
  assertRight val action =
      do r <- val
         case r of
           Right v -> action v
           Left err -> expectationFailure (show err)
  
  assertLeft :: IO (Either a b) -> String -> (a -> IO ()) -> IO ()
  assertLeft val msg action =
      do r <- val
         case r of
           Right _ -> expectationFailure msg
           Left v -> action v
  
  assertJust :: IO (Maybe a) -> String -> (a -> IO ()) -> IO ()
  assertJust val msg action =
      do r <- val
         case r of
           Nothing -> expectationFailure msg
           Just v -> action v
  
  makeUsersSpec :: forall b. UserStorageBackend b => b -> Spec
  makeUsersSpec backend =
      before_ (initUserBackend backend) $
      after_ (destroyUserBackend backend) $
      do describe "core user management" $
             do it "should create valid users" $
                   assertRight (createUser backend userA) $ const (return ())
                it "should not allow duplicates" $
                   assertRight (createUser backend userB) $ \_ ->
                       do assertLeft (createUser backend (mkUser "foo2" "bar2@baz.com"))
                                         "succeeded to create foo2 bar2 again" $ \err ->
                              err `shouldBe` UsernameAndEmailAlreadyTaken
                          assertLeft (createUser backend (mkUser "foo2" "asdas@baz.com"))
                                         "succeeded to create foo2 with different email again" $ \err ->
                              err `shouldBe` UsernameAlreadyTaken
                          assertLeft (createUser backend (mkUser "asdas" "bar2@baz.com"))
                                         "succeeded to create different user with same email" $ \err ->
                              err `shouldBe` EmailAlreadyTaken
                          assertLeft (createUser backend (mkUser "asdas" "Bar2@baz.com"))
                             "succeeded to create different user with different email capitalisation" $ \err ->
                              err `shouldBe` EmailAlreadyTaken
                it "list and count should be correct" $
                   assertRight (createUser backend userA) $ \userId1 ->
                   assertRight (createUser backend userB) $ \userId2 ->
                   do allUsers <- listUsers backend (Just (0,10)) (SortAsc UserFieldId)
                      unless ((userId1, hidePassword userA) `elem` allUsers && (userId2, hidePassword userB) `elem` allUsers)
                             (expectationFailure $ "create users not in user list:" ++ show allUsers)
                      countUsers backend `shouldReturn` 2
                it "sorting should work" $
                   assertRight (createUser backend userA) $ \_ ->
                   assertRight (createUser backend userB) $ \_ ->
                   assertRight (createUser backend userC) $ \userId3 ->
                   do allUsers <- listUsers backend Nothing (SortAsc UserFieldName)
                      head allUsers `shouldBe` (userId3, hidePassword userC)
                it "updating and loading users should work" $
                   assertRight (createUser backend userA) $ \userIdA ->
                   assertRight (createUser backend userB) $ \_ ->
                       do assertRight (updateUser backend userIdA (\user -> user { u_name = "changed" })) $ const (return ())
                          assertLeft (updateUser backend userIdA (\user -> user { u_name = "foo2" }))
                                         "succeeded to set username to already used username" $ \err ->
                              err `shouldBe` UsernameAlreadyExists
                          assertLeft (updateUser backend userIdA (\user -> user { u_email = "bar2@baz.com" }))
                                         "succeeded to set email to already used email" $ \err ->
                              err `shouldBe` EmailAlreadyExists
                          userA' <- getUserById backend userIdA
                          userA' `shouldBe`
                                 (Just $ (hidePassword userA)
                                  { u_name = "changed"
                                  })
                          userIdA' <- getUserIdByName backend "changed"
                          userIdA' `shouldBe` Just userIdA
                it "deleting users should work" $
                   assertRight (createUser backend userA) $ \userIdA ->
                   assertRight (createUser backend userB) $ \userIdB ->
                       do deleteUser backend userIdA
                          (allUsers :: [(UserId b, User)]) <-
                            listUsers backend Nothing (SortAsc UserFieldId)
                          map fst allUsers `shouldBe` [userIdB]
                          getUserById backend userIdA `shouldReturn` (Nothing :: Maybe User)
                it "reusing a deleted users name should work" $
                   assertRight (createUser backend userA) $ \userIdA ->
                       do deleteUser backend userIdA
                          assertRight (createUser backend userA) $ const (return ())
         describe "initialisation" $
             it "calling initUserBackend multiple times should not result in errors" $
                assertRight (createUser backend userA) $ \userIdA ->
                do initUserBackend backend
                   userA' <- getUserById backend userIdA
                   userA' `shouldBe` (Just $ hidePassword userA)
         describe "authentification" $
             do it "auth as valid user with username should work" $
                   withAuthedUser $ const (return ())
                it "auth as valid user with email should work" $
                   withAuthedUser' "bar@baz.com" "1234" 500 0 $ const (return ())
                it "auth with invalid credentials should fail" $
                   assertRight (createUser backend userA) $ \_ ->
                   do authUser backend "foo" (PasswordPlain "aaaa") 500 `shouldReturn` Nothing
                      authUser backend "foo" (PasswordPlain "123") 500 `shouldReturn` Nothing
                      authUser backend "bar@baz.com" (PasswordPlain "123") 500 `shouldReturn` Nothing
                      authUser backend "bar@baz.com' OR 1 = 1 --" (PasswordPlain "123") 500 `shouldReturn` Nothing
                      authUser backend "bar@baz.com' OR 1 = 1; --" (PasswordPlain  "' OR 1 = 1; --") 500 `shouldReturn` Nothing
                it "sessionless auth with valid userdata should work" $
                   assertRight (createUser backend userA) $ \userIdA ->
                   do withAuthUser backend "bar@baz.com" ((== "bar@baz.com") . u_email)
                        (return . (== userIdA)) `shouldReturn` Just True
                      withAuthUser backend "bar@baz.com" ((== "bar@baz.com") . u_email)
                        (return . (/= userIdA)) `shouldReturn` Just False
                it "sessionless auth with invalid userdata should fail" $
                   assertRight (createUser backend userA) $ \userIdA ->
                      withAuthUser backend "bar@baz.com" ((/= "bar@baz.com") . u_email)
                        (return . (/= userIdA)) `shouldReturn` Nothing
                it "forcing a session works" $
                   assertRight (createUser backend userA) $ \userIdA ->
                   assertJust (createSession backend userIdA 500) "session id missing" $ \_ -> return ()
                it "destroy session should really remove the session" $
                   withAuthedUser $ \(sessionId, _) ->
                       do destroySession backend sessionId
                          verifySession backend sessionId 0 `shouldReturn` (Nothing :: Maybe (UserId b))
                it "sessions should time out 1" $
                   withAuthedUserT 1 0 $ \(sessionId, _) ->
                   do threadDelay (seconds 1)
                      housekeepBackend backend
                      verifySession backend sessionId 0 `shouldReturn` (Nothing :: Maybe (UserId b))
                it "sessions should time out 2" $
                   withAuthedUserT 1 1 $ \(sessionId, _) ->
                   do threadDelay (seconds 2)
                      verifySession backend sessionId 0 `shouldReturn` (Nothing :: Maybe (UserId b))
         describe "password reset" $
            do it "generates a valid token for a user" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do token <- requestPasswordReset backend userIdA 500
                         verifyPasswordResetToken backend token `shouldReturn` (Just (hidePassword userA) :: Maybe User)
               it "a valid token should reset the password" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- old login
                         token <- requestPasswordReset backend userIdA 500
                         housekeepBackend backend
                         verifyPasswordResetToken backend token `shouldReturn` (Just (hidePassword userA) :: Maybe User)
                         assertRight (applyNewPassword backend token $ makePassword "foobar") $ const $ return ()
                         withAuthedUserNoCreate "foo" "foobar" 500 0 userIdA $ const (return ()) -- new login
               it "expired tokens should not do any harm" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- old login
                         token <- requestPasswordReset backend userIdA 1
                         threadDelay (seconds 1)
                         verifyPasswordResetToken backend token `shouldReturn` (Nothing :: Maybe User)
                         assertLeft (applyNewPassword backend token $ makePassword "foobar")
                                        "Reset password with expired token" $ const $ return ()
                         withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- still old login
               it "invalid tokens should not do any harm" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- old login
                         let token = PasswordResetToken "Foooooooo!!!!"
                         verifyPasswordResetToken backend token `shouldReturn` (Nothing :: Maybe User)
                         assertLeft (applyNewPassword backend token $ makePassword "foobar")
                                        "Reset password with random token" $ const $ return ()
                         withAuthedUserNoCreate "foo" "1234" 500 0 userIdA $ const (return ()) -- still old login
         describe "user activation" $
            do it "activates a user with a valid activation token" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do token <- requestActivationToken backend userIdA 500
                         housekeepBackend backend
                         assertRight (activateUser backend token) $ const $ return ()
                         userA' <- getUserById backend userIdA
                         userA' `shouldBe`
                                    (Just $ (hidePassword userA)
                                     { u_active = True
                                     })
               it "does not allow expired tokens to activate a user" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do token <- requestActivationToken backend userIdA 1
                         threadDelay (seconds 1)
                         assertLeft (activateUser backend token) "expired token activated user" $ const $ return ()
                         userA' <- getUserById backend userIdA
                         userA' `shouldBe`
                                    (Just $ (hidePassword userA)
                                     { u_active = False
                                     })
               it "does not allow invalid tokens to activate a user" $
                  assertRight (createUser backend userA) $ \userIdA ->
                      do let token = ActivationToken "aaaasdlasdkaklasdlkasjdl"
                         assertLeft (activateUser backend token) "invalid token activated user" $ const $ return ()
                         userA' <- getUserById backend userIdA
                         userA' `shouldBe`
                                    (Just $ (hidePassword userA)
                                     { u_active = False
                                     })
      where
        seconds x = x * 1000000
        userA = mkUser "foo" "bar@baz.com"
        userB = mkUser "foo2" "bar2@baz.com"
        userC = mkUser "alex" "aaaa@bbbbbb.com"
        withAuthedUser = withAuthedUser' "foo" "1234" 500 0
        withAuthedUserT = withAuthedUser' "foo" "1234"
        withAuthedUser' username pass sTime extTime action =
            assertRight (createUser backend userA) $ \userIdA ->
            withAuthedUserNoCreate username pass sTime extTime userIdA action
        withAuthedUserNoCreate username pass sTime extTime userIdA action =
            do mAuthRes <- authUser backend username (PasswordPlain pass) sTime
               case mAuthRes of
                 Nothing ->
                     expectationFailure $ "Can not authenticate as user " ++ show username
                 Just sessionId ->
                     do verifySession backend sessionId extTime `shouldReturn` Just userIdA
                        action (sessionId, userIdA)
  