Commits

Luke Plant  committed d0082f6

Implemented setPassword/checkPassword and tests

  • Participants
  • Parent commits 01d5ecc

Comments (0)

Files changed (5)

         old-locale >= 1.0.0.0,
         MissingH >= 1.0.2,
         pandoc >= 1.1,
+        SHA >= 1.0.2,
         ella >= 0.1.2
   Main-is: BlogCgi.hs
   hs-source-dirs: src

File src/Blog/Model.hs

                   , getCategories
                   , getCategoriesBulk
                   , getPostsForCategory
+                  , setPassword
+                  , checkPassword
                   ) where
 
+import Data.Digest.Pure.SHA (showDigest, sha1)
 import Database.HDBC
 import Blog.DBUtils (makeSlugGeneric, pagedQuery, sqlInIds, getDbId)
-import Blog.Utils (regexReplace)
+import Blog.Utils (regexReplace, randomStr, split)
+import Ella.GenUtils (utf8)
 import qualified Blog.DB as DB
 import qualified Blog.Post as P
 import qualified Blog.Category as Ct
 getCommentByIdQuery      = "SELECT id, post_id, timestamp, name, email, text_raw, text_formatted, format_id FROM comments WHERE id = ?;"
 getCommentsForPostQuery  = "SELECT id, '',      timestamp, name, email, '',       text_formatted, ''        FROM comments WHERE post_id = ? ORDER BY timestamp ASC;"
 
+getPasswordForUsernameQuery = "SELECT password FROM users WHERE username = ?;"
+setPasswordForUsernameQuery = "UPDATE users SET password = ? WHERE username = ?;"
 
 ---- Constructors ----
 
   (res,_) <- pagedQuery cn (getRelatedPostsQuery ids) [ toSql $ P.uid post
                                                       , toSql $ P.timestamp post ] 1 7
   return $ map makePost res
+
+makePasswordHash password = do
+  salt <- randomStr 10
+  let digest = sha1 $ utf8 (salt ++ password)
+  return ("sha1:" ++ salt ++ ":" ++ (showDigest $ digest))
+
+checkPasswordHash salt hash password =
+    (showDigest $ sha1 $ utf8 (salt ++ password)) == hash
+
+-- | Checks that the password for a user is correct
+checkPassword :: (IConnection conn) =>
+                 conn -> String -> String -> IO Bool
+checkPassword cn username password = do
+  res <- quickQuery' cn getPasswordForUsernameQuery [ toSql username ]
+  if null res
+     then return False
+     else do
+         [[SqlString pwdData]] <- return res -- force pattern match
+         -- pwdData stores algo;salt;hash
+         ["sha1", salt, hash] <- return $ split pwdData ':'
+         return $ checkPasswordHash salt hash password
+
+-- | Sets the password for a user
+setPassword :: (IConnection conn) =>
+               conn -> String -> String -> IO ()
+setPassword cn username password = do
+  pwdHash <- makePasswordHash password
+  _ <- quickQuery' cn setPasswordForUsernameQuery [ toSql pwdHash
+                                                  , toSql username ]
+  commit cn
+  return ()

File testsuite/Main.hs

 import qualified Tests.Blog.DBUtils as DBUtils
 import qualified Tests.Blog.Formats as Formats
+import qualified Tests.Blog.Model as Model
 import Test.HUnit
 
 main = runTestTT (test [ "DBUtils tests" ~: DBUtils.tests
                        , "Format tests" ~: Formats.tests
+                       , "Model tests" ~: Model.tests
                        ])

File testsuite/Tests/Blog/Model.hs

+module Tests.Blog.Model where
+
+import Blog.Model
+import Database.HDBC
+import Control.Exception (bracket)
+import Test.HUnit
+import qualified Blog.DB as DB
+import qualified Tests.Blog.TestDB as TestDB
+
+
+withEmptyUsersTable = bracket (do
+                                cn <- TestDB.connect
+                                _ <- quickQuery' cn "DELETE FROM users;" []
+                                commit cn
+                                return cn)
+                               (\cn -> do
+                                    _ <- quickQuery' cn "DELETE FROM users;" []
+                                    commit cn
+                                    return ())
+
+testSetPassword = withEmptyUsersTable
+                  (\cn -> do
+                     res1 <- checkPassword cn "testuser" "testpassword"
+                     assertBool "Password check should fail with no user." (not res1)
+
+                     DB.doInsert cn "users" [ "username", "password"] [ toSql "testuser", toSql "sha1:foo:bar" ]
+
+                     setPassword cn "testuser" "testpassword"
+                     res3 <- checkPassword cn "testuser" "testpassword"
+                     assertBool "Password check should succeed" res3
+
+                     res4 <- checkPassword cn "testuser" "somethingelse"
+                     assertBool "Password check should fail with wrong password" (not res4)
+
+                  )
+
+tests = test [ "set password" ~: testSetPassword
+             ]

File testsuite/testdata.sql

-INSERT INTO users (username, password, superuser) VALUES ('luke', 'xxx', 1);