From f547469c4b1e16fa6715d7d10c226f16b5d3b0e2 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 23 Mar 2015 06:07:44 +0000 Subject: update sariulccgi.hs to use new monad --- src/Types/Classes.hs | 8 +++--- src/sariulccgi.hs | 81 ++++++++++++++++++++++++++-------------------------- 2 files changed, 45 insertions(+), 44 deletions(-) diff --git a/src/Types/Classes.hs b/src/Types/Classes.hs index bcf487c..529cf64 100644 --- a/src/Types/Classes.hs +++ b/src/Types/Classes.hs @@ -32,8 +32,8 @@ getModifier :: Class -> Float getModifier (Class (GradeFive m) _ _) = m getModifier (Class (GradeSix m) _ _) = m -updateScore :: ScoresList -> Class -> Int -> Int -> ScoresList -updateScore [] _ _ _ = [] -updateScore (s@(aClass, Score x y):ss) c p t +updateScore :: Class -> Int -> Int -> ScoresList -> ScoresList +updateScore _ _ _ [] = [] +updateScore c p t (s@(aClass, Score x y):ss) | c == aClass = (c, Score (x + (floor $ (fromIntegral p) * (getModifier aClass))) (y + t)):ss - | otherwise = s:updateScore ss c p t + | otherwise = s:updateScore c p t ss diff --git a/src/sariulccgi.hs b/src/sariulccgi.hs index e39a8ec..072c232 100644 --- a/src/sariulccgi.hs +++ b/src/sariulccgi.hs @@ -1,6 +1,5 @@ import Data.Text (strip, unpack, pack) import Network.CGI --- import Network.CGI.Monad import Text.XHtml import Utils.ScoresFile (readScoresFile,writeScoresFile) import Types.Classes @@ -13,15 +12,17 @@ import Control.Monad.Trans (lift) import Data.Maybe (fromMaybe) import Types.Session import Types.Clocks -import Control.Monad.Page +import Control.Monad.SariulClocks import Utils.Classes import Text.XHtml.Bootstrap import Control.Exception (onException) import Data.Char (isDigit) import Data.Maybe (fromJust) import Utils.Xhtml +import Network.URI +import System.FilePath (takeDirectory) -navBar :: Page Html +navBar :: SariulClocksCGI Html navBar = do currentClass <- liftM (currentClass) getSession return $ @@ -89,7 +90,7 @@ makeLeftClockButtons CountDownClock = br +++ (paragraph # "text-center" << timeB makeRightClockButtons :: Html makeRightClockButtons = primHtml $ "Start timer Reset timer " -clocks :: Page Html +clocks :: SariulClocksCGI Html clocks = do leftClockType <- liftM (currentClock) getSession let leftClockToggle = makeClockToggle leftClockType @@ -126,70 +127,70 @@ theDate = thediv # "container" << thediv # "row" , strAttr "class" "text-center"] << noHtml) +++ hr) --- forms :: Page Html --- forms = do --- let html = form #= "end_of_class_form" ! [strAttr "method" "POST"] << (input #= "class_points" ! [strAttr "name" "class_points", strAttr "type" "hidden", strAttr "value" ""] +++ input #= "class_time_wasted" ! [strAttr "name" "class_time_wasted", strAttr "type" "hidden", strAttr "value" ""]) --- return html - -makePage :: Page Html +makePage :: SariulClocksCGI Html makePage = do theNavBar <- navBar theClocks <- clocks theRankings <- rankings return (theNavBar +++ theClocks +++ theDate +++ theRankings) -cgiMain :: CGI CGIResult +cgiMain :: SariulClocksCGI CGIResult cgiMain = do -- preparatory IO: templating, scores file, time (for cookies) password <- (liftIO . readFile) "password" userPassword <- liftM (fromMaybe "") $ getInput "teachers_password" - htmlTemplate <- (liftIO . readFile) "html/main.html" - maybeScores <- liftIO readScoresFile - let scores = case maybeScores of - Just s -> s - _ -> zeroScores + let passwordPasses = (unpack . strip . pack) password == userPassword + htmlTemplate <- (liftIO . readFile) "html/main.html" clockTime <- liftIO getClockTime + scores <- readScoresFile - points <- liftM (fromMaybe "0") $ getInput "class_points" - timeWasted <- liftM (fromMaybe "0") $ getInput "class_time_wasted" - let points' = readInt points - let timeWasted' = readInt timeWasted - + points <- liftM (readInt . fromMaybe "0") $ getInput "class_points" + timeWasted <- liftM (readInt . fromMaybe "0") $ getInput "class_time_wasted" cookieClock <- liftM (fromMaybe 0) $ readCookie "clock_cookie" cookieClass <- liftM (parseClassCookie) $ getCookie "class_cookie" - let session = Session { currentClass = if points' /= 0 && userPassword == (unpack . strip . pack) password then Nothing else cookieClass - , currentClock = + putSession Session { currentClass = if passwordPasses then Nothing else cookieClass + , currentClock = case cookieClock of 0 -> CountDownClock - 1 -> CountUpClock} - - -- now do our CGI work + 1 -> CountUpClock } - -- TODO: use POST,REDIRECT,GET https://stackoverflow.com/questions/570015/how-do-i-reload-a-page-without-a-postdata-warning-in-javascript/570069#570069 + when passwordPasses $ modifyScores (updateScore (fromJust cookieClass) points timeWasted) - -- TODO: restore time wasting clock if password was wrong + selfURL <- liftM (takeDirectory . uriPath) requestURI + if passwordPasses + then do + -- TODO: use POST,REDIRECT,GET https://stackoverflow.com/questions/570015/how-do-i-reload-a-page-without-a-postdata-warning-in-javascript/570069#570069 + redirect selfURL + else do + page <- makePage - let scores' = - if points' /= 0 && userPassword == (unpack . strip . pack) password - then updateScore scores (fromJust cookieClass) points' timeWasted' - else scores + setCookie =<< liftM (makeClassCookie clockTime selfURL) getSession + setCookie =<< liftM (makeClockCookie clockTime selfURL) getSession + setCookie =<< liftM (makeSsCookie clockTime selfURL) getSession - let (newScores, newSession, html) = runPage makePage scores' session + shouldModify <- liftM (((/=) scores) . Just) getScores + when shouldModify writeScoresFile - setCookie $ makeClassCookie clockTime newSession - setCookie $ makeClockCookie clockTime newSession - setCookie $ makeSsCookie clockTime newSession + output $ templateInject htmlTemplate page - -- let html' = html +++ show points' +++ show timeWasted' + -- when (newScores /= scores) $ liftIO $ writeScoresFile newScores - when (newScores /= scores) $ liftIO $ writeScoresFile newScores +-- main = runCGI . handleErrors $ cgiMain - output $ templateInject htmlTemplate html +-- tempMain :: New.SariulClocksCGI CGIResult +-- tempMain = do +-- readScoresFile +-- session <- New.getSession +-- let session' = session { currentClass = lookupSariulClass 5 1} +-- New.putSession session' +-- page <- rankings +-- htmlTemplate <- (liftIO . readFile) "html/main.html" +-- output $ templateInject htmlTemplate page -main = runCGI . handleErrors $ cgiMain +main = runSariulClocksCGI cgiMain templateInject :: String -> Html -> String templateInject template body = templateBefore ++ (renderHtmlFragment body) ++ templateAfter -- cgit v1.2.3