Commits

Luke Plant committed 7c36141

First stab at login functionality (needs a lot more work)

Comments (0)

Files changed (6)

src/Blog/Links.hs

 categoryUrl c     = Settings.root_url ++ "categories/" ++ (C.slug c) ++ "/"
 aboutUrl          = Settings.root_url ++ "about/"
 feedsUrl          = Settings.root_url ++ "feeds/"
+loginUrl          = Settings.root_url ++ "login/"
+
+adminMenuUrl = undefined :: String

src/Blog/Routes.hs

          , "categories/" <+/> anyParam                //-> categoryView           $ []
          , "about/" <+/> empty                        //-> infoPageView "about"   $ []
          , "feeds/" <+/> empty                        //-> infoPageView "feeds"   $ []
+         , "login/" <+/> empty                        //-> loginView              $ []
          , "debug/" <+/> anyParam                     //-> debug                  $ []
          ]

src/Blog/Views.hs

 
 
 -- | View that shows a post as a static information page -- no comments etc.
+infoPageView :: String -> View
 infoPageView slug req = do
   cn <- connect
   Just post <- getPostBySlug cn slug
   return $ Just $ standardResponse $ infoPage post
 
+-- | View that displays a login form an handles logging in
+loginView :: View
+loginView req = do
+  cn <- connect
+  loginView' cn req
+
+-- | Testable version of loginView
+loginView' cn req =
+  case requestMethod req of
+    "POST" -> do
+      (loginData, loginErrors) <- validateLogin (getPOST req :: (String -> Maybe String)) cn
+      if Map.null loginErrors
+         then do
+           loginCookie <- createLoginCookie loginData
+           return $ Just $ (redirectResponse adminMenuUrl) `with` [ addCookie loginCookie ]
+         else
+           return $ Just $ standardResponse $ loginPage loginData loginErrors
+    _ -> do
+      return $ Just $ standardResponse $ loginPage emptyLoginData Map.empty
+
+-- TODO, dummy types so it can compile
+validateLogin = undefined
+createLoginCookie = undefined
+addCookie = undefined
+loginPage = undefined :: () -> Map.Map String String -> String
+emptyLoginData = undefined
+
+
 -- Utilities
 
 getPage req = (getGET req "p") `captureOrDefault` 1 :: Int

testsuite/Tests/Blog/Views.hs

+module Tests.Blog.Views where
+
+import Blog.Settings
+import Ella.TestUtils
+import Test.HUnit
+
+login_req1 = mkPostReq "/login/" [("username", "luke")
+                                 ,("password", "testpassword")
+                                 ]
+
+tests = test [ ]

testsuite/runtests.sh

 #!/bin/sh
 DIR=`dirname $0`
 rm $DIR/test.db 2> /dev/null
+sqlite3 $DIR/test.db < $DIR/../schema/install.sql
+sqlite3 $DIR/test.db < $DIR/testdata.sql
 runhaskell -i$DIR:$DIR/../src $DIR/Main.hs

testsuite/testdata.sql

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