Commits

Luke Plant  committed fdfdfa4

Implemented login form

  • Participants
  • Parent commits 22b4c04

Comments (0)

Files changed (4)

File src/Blog/Forms.hs

 where
 
 import Blog.Formats (Format(..), getFormatter)
+import Blog.Model (checkPassword)
 import Blog.Utils (getTimestamp)
 import Control.Monad (liftM)
 import Data.Maybe (fromJust)
 emptyLoginData = Map.fromList [("username", "")
                               ,("password", "")]
 
+validateLogin postedData cn = do
+  -- TODO - validation on field lengths
+    let username = postedData "username" `captureOrDefault` ""
+    let password = postedData "password" `captureOrDefault` ""
+    let loginData = Map.fromList [ ("username", username)
+                                 , ("password", password)]
+    let errors = (if null username
+                  then [("username", "Please enter a user name")]
+                  else [])
+                 ++
+                 (if null password
+                  then [("password", "Please enter a password")]
+                  else [])
+    if null errors
+       then do
+         passwordCheck <- checkPassword cn username password
+         if passwordCheck
+            then return (loginData, Map.empty)
+            else return (loginData, Map.fromList [("password", "Password not correct.")])
+       else do
+         return (loginData, Map.fromList errors)

File src/Blog/Links.hs

 feedsUrl          = Settings.root_url ++ "feeds/"
 loginUrl          = Settings.root_url ++ "login/"
 
-adminMenuUrl = undefined :: String
+adminMenuUrl      = Settings.root_url ++ "admin/"

File src/Blog/Templates.hs

              }
 
 
+loginPage :: Map.Map String String -> Map.Map String String -> Html
 loginPage loginData loginErrors =
     page $ defaultPageVars
              { pcontent = (h1 << "Login")
              }
 
 loginForm loginData loginErrors =
+    (if not $ Map.null loginErrors
+        then (thediv ! [theclass "validationerror"]
+              << unordList (Map.elems loginErrors))
+        else noHtml)
+    +++
     form ! [ method "post", action ""]
     << (simpleTable [] [] [ [ toHtml $ makeLabel "User name:" usernameWidget
                             , toHtml $ setVal (fromJust $ Map.lookup "username" loginData) usernameWidget

File src/Blog/Views.hs

 -- which has pure functions that generally return Html.
 
 import Blog.DB (connect)
-import Blog.Forms (CommentStage(..), validateComment, emptyComment, emptyLoginData)
+import Blog.Forms (CommentStage(..), validateComment, emptyComment, emptyLoginData, validateLogin)
 import Blog.Links
 import Blog.Model
 import Blog.Templates
 loginView' cn req =
   case requestMethod req of
     "POST" -> do
-      (loginData, loginErrors) <- validateLogin (getPOST req :: (String -> Maybe String)) cn
+      (loginData, loginErrors) <- validateLogin (getPOST req) cn
       if Map.null loginErrors
          then do
            ts <- getTimestamp
     _ -> do
       return $ Just $ standardResponse $ loginPage emptyLoginData Map.empty
 
-validateLogin = undefined -- TODO
-
 standardCookie = Cookie { cookieName = ""
                         , cookieValue = ""
                         , cookieExpires = Nothing
                         , cookieSecure = False
                         }
 
--- | Generate a hash that is used to verify a 'session' cookie.
-loginHash = undefined -- TODO
 
 createLoginCookies loginData timestamp =
   let username = fromJust $ Map.lookup "username" loginData
      , standardCookie { cookieName = "timestamp"
                       , cookieValue = show timestamp }
      , standardCookie { cookieName = "hash"
-                      , cookieValue = loginHash username password timestamp }
+                      , cookieValue = "TODO - sign the cookie" }
      ]