[Implemented login, logout and register in demo program. Some minor changes in the library to accomodate this. bjorn@bringert.net**20060419212022] { hunk ./Session/Operations.hs 2 -module Session.Operations (startSession, endSession, +module Session.Operations (newSession, deleteSession, hunk ./Session/Operations.hs 8 +import Data.FunctorM (fmapM) +import Data.Maybe (isJust) hunk ./Session/Operations.hs 25 -startSession :: Database -> Maybe UserID -> IO Session -startSession db muid = transaction db $ +newSession :: Database -> Maybe UserID -> IO Session +newSession db muid = transaction db $ hunk ./Session/Operations.hs 42 --- | Ends a session by removinging it from the database. -endSession :: Database -> SessionID -> IO () -endSession db sid = +-- | Ends a session by removing it from the database. +deleteSession :: Database -> SessionID -> IO () +deleteSession db sid = hunk ./Session/Operations.hs 51 --- 'Nothing' is returned. If the sessions does not exist, +-- 'Nothing' is returned. If the session does not exist, hunk ./Session/Operations.hs 53 -getSession :: Database -> SessionID -> IO (Maybe Session) -getSession db sid = - transaction db (findSession db sid >>= maybe (return Nothing) endExpired) +getSession :: Database + -> Maybe UserID -- ^ If this is not 'Nothing', the session + -- user will be set to be the given 'UserID'. + -> SessionID -- ^ The ID of the session to get. + -> IO (Maybe Session) +getSession db muid sid = + transaction db (findSession db sid + >>= maybe (return Nothing) endExpired + >>= fmapM updateUser) hunk ./Session/Operations.hs 66 - endSession db sid + deleteSession db sid hunk ./Session/Operations.hs 69 + updateUser sess | isJust muid && muid /= sessionUser sess + = do + setUser db sid muid + return $ sess { sessionUser = muid } + | otherwise = return sess hunk ./Session/Operations.hs 84 +-- * Formatting session IDs +-- + + + +-- hunk ./Session/Operations.hs 106 - sid <- randomIO + sid <- randomRIO (0,maxBound) hunk ./Session/Operations.hs 130 + +setUser :: Database -> SessionID -> Maybe UserID -> IO () +setUser db sid muid = + update db S.sessions (\r -> r!S.sessionid .==. constant sid) + (\r -> S.userid <<- muid) hunk ./examples/DBConnect.hs 8 -import Database.HaskellDB.HSQL.SQLite3 (driver) +import Database.HaskellDB.HSQL.SQLite3 hunk ./examples/demo.hs 5 --- import Text.XHtml +import Text.XHtml hiding (start) + +import Control.Exception +import Control.Monad hunk ./examples/demo.hs 17 -import Database.HaskellDB +import Database.HaskellDB (Database) + +-- +-- * CGI utilities +-- + +getManyInputs :: [String] -> CGI (Maybe [String]) +getManyInputs = liftM sequence . mapM getInput + +cgiErrorHandler :: Exception -> CGI CGIResult +cgiErrorHandler e = + do + setHeader "Status" "500" + logCGI (show e) + output $ unlines ["", + "500 Internal Server Error", + "", + "

Internal Server Error

", + "

" ++ show e ++ "

", + ""] + +-- +-- * XHTML utilities +-- + +hlink :: HTML a => URL -> a -> Html +hlink u b = anchor ! [href u] << b + +mkHtml :: (HTML a,HTML b) => a -> b -> Html +mkHtml hdr bdy = (header << hdr) +++ (body << bdy) + + +-- +-- * Session stuff +-- hunk ./examples/demo.hs 55 + +sessionCookieName :: String +sessionCookieName = "session" + +loadSession :: Database -> Maybe UserID -> CGI (Maybe Session) +loadSession db muid = + do msi <- readCookie sessionCookieName + maybe (return Nothing) (liftIO . getSession db muid) msi + +startSession :: Database -> Maybe UserID -> CGI Session +startSession db muid = + do s <- liftIO $ newSession db muid + setCookie $ newCookie sessionCookieName (show (sessionID s)) + return s + +loadOrStartSession :: Database -> Maybe UserID -> CGI Session +loadOrStartSession db muid = + loadSession db muid >>= maybe (startSession db muid) return + +-- +-- * User / session actions +-- + +data UserAction = Login Username Password + | Logout + | Register Username Password + | NoAction hunk ./examples/demo.hs 83 -loadSession db = +getUserAction :: CGI UserAction +getUserAction = hunk ./examples/demo.hs 86 - msi <- readCookie sessionCookieName - logCGI (show msi) - ms <- maybe (return Nothing) (liftIO . getSession db) msi - case ms of - Nothing -> - do - s <- liftIO $ startSession db Nothing - setCookie $ newCookie sessionCookieName (show (sessionID s)) - return s - Just s -> return s - where sessionCookieName = "session" + ma <- getInput "user_action" + case ma of + Nothing -> return NoAction + Just "login" -> liftM (uncurry Login) getCreds + Just "logout" -> return Logout + Just "register" -> liftM (uncurry Register) getCreds + Just x -> fail $ "Unknown user_action: " ++ x + where getCreds = do + is <- getManyInputs ["username","password"] + case is of + Just [u,p] -> return (u,p) + _ -> fail $ "Username/password not given" + +start :: Database -> UserAction -> CGI Session +start db (Login u p) = + do muid <- liftIO $ authenticate db u p + loadOrStartSession db muid +start db Logout = + do ms <- loadSession db Nothing + maybe (return ()) (liftIO . deleteSession db . sessionID) ms + startSession db Nothing +start db (Register u p) = + do muid <- liftIO $ addUser db u p + case muid of + Nothing -> fail $ "Couldn't register user " ++ u + Just uid -> loadOrStartSession db (Just uid) +start db NoAction = loadOrStartSession db Nothing + +main :: IO () +main = runCGI cgiMain + +cgiMain :: CGI CGIResult +cgiMain = handleExceptionCGI (dbConnect dbMain) cgiErrorHandler hunk ./examples/demo.hs 123 - sess <- loadSession db - setHeader "Content-type" "text/plain" + a <- getUserAction + sess <- start db a hunk ./examples/demo.hs 126 - output $ unlines ["Session ID: " ++ show (sessionID sess), - "User ID: " ++ maybe "N/A" show (sessionUser sess), - "Username: " ++ name] + let page = mkPage sess name + output $ renderHtml page + + +loginForm :: Html +loginForm = + form ! [method "post"] + << [hidden "user_action" "login", + thediv << (thespan << "Username: " +++ textfield "username"), + thediv << (thespan << "Password: " +++ password "password"), + thediv << [submit "submit" "Login"]] + +addUserForm :: Html +addUserForm = + form ! [method "post"] + << [hidden "user_action" "register", + thediv << (thespan << "Username: " +++ textfield "username"), + thediv << (thespan << "Password: " +++ password "password"), + thediv << [submit "submit" "Register"]] hunk ./examples/demo.hs 146 -cgiMain :: CGI CGIResult -cgiMain = handleExceptionCGI (dbConnect dbMain) (output . show) +logoutLink :: Html +logoutLink = hlink "?user_action=logout" << "Log out" hunk ./examples/demo.hs 149 -main :: IO () -main = runCGI cgiMain +mkPage :: Session -> Username -> Html +mkPage sess name = mkHtml hdr bdy + where + hdr :: [Html] + hdr = [thetitle << "Session / User demo"] + bdy = [p << ("Session ID: " ++ show (sessionID sess)), + p << ("User ID: " ++ maybe "N/A" show (sessionUser sess)), + p << ("Username: " ++ name), + hr, + h2 << "Log in", + thediv << loginForm, + hr, + h2 << "Register", + thediv << addUserForm, + hr, + h2 << "Log out", + thediv << logoutLink] }