From 4c69657ef7f6c9119eb40c3ff8a9e982e77ac949 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Wed, 18 Mar 2015 05:44:37 +0000 Subject: first version of saving scores works! --- deploy.sh | 2 ++ src/Utils/ScoresFile.hs | 15 ++++++++++----- src/sariulclocks.hs | 46 +++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 53 insertions(+), 10 deletions(-) diff --git a/deploy.sh b/deploy.sh index d20fc16..ea7aea8 100755 --- a/deploy.sh +++ b/deploy.sh @@ -6,3 +6,5 @@ cabal build cp -RL assets/* dist/build/sariulclocks.cgi/sariulclocks.cgi $HOME/html/ # TODO: run strip on binary cp -RL ../schoolclock/sounds $HOME/html +mkdir -p $HOME/html/data +chmod 777 $HOME/html/data diff --git a/src/Utils/ScoresFile.hs b/src/Utils/ScoresFile.hs index 4028efa..2f496bf 100644 --- a/src/Utils/ScoresFile.hs +++ b/src/Utils/ScoresFile.hs @@ -13,6 +13,7 @@ import System.FilePath (takeExtension) import Control.Monad (liftM) import Data.List.Split (splitOn) import Data.Maybe (fromJust) +import System.FilePath (()) scoresToCSV :: ScoresList -> String scoresToCSV = unlines . foldr step [] @@ -21,27 +22,31 @@ scoresToCSV = unlines . foldr step [] (show theClass ++ "," ++ show x ++ "," ++ show y) : theLines -- no malformed CSV handling here yet! +-- this function currently doesn't work scoresFromCSV :: String -> ScoresList scoresFromCSV csv = foldr step [] (lines csv) where step line scores = (theClass, Score (read scoreString) (read timeString)) : scores where classString:scoreString:timeString:[] = splitOn "," line - theClass = fromJust $ lookupSariulClass ((head . read) classString) ((last . read) classString) + theClass = fromJust $ lookupSariulClass ((read . (:[]) . head) classString) ((read . (:[]) . last) classString) --- read to scores-XX.csv where XX is largest timestamp +-- read from scores-XX.csv where XX is largest timestamp readScoresFile :: IO (Maybe ScoresList) readScoresFile = do curDir <- getCurrentDirectory - filenames <- liftM (reverse . sort . filter isCSV) $ getDirectoryContents curDir + let dataDir = curDir "data" + filenames <- liftM (reverse . sort . filter isCSV) $ getDirectoryContents dataDir case filenames of [] -> return Nothing - _ -> Just . scoresFromCSV <$> readFile (head filenames) + _ -> Just . scoresFromCSV <$> readFile (dataDir head filenames) where isCSV path = takeExtension path == ".csv" -- writes to score-XX.csv where XX is unix timestamp: a simple-minded logging writeScoresFile :: ScoresList -> IO () writeScoresFile scores = do + curDir <- getCurrentDirectory + let dataDir = curDir "data" timestamp <- round <$> getPOSIXTime - let filename = "scores-" ++ show timestamp ++ ".csv" + let filename = dataDir ("scores-" ++ show timestamp ++ ".csv") writeFile filename (scoresToCSV scores) diff --git a/src/sariulclocks.hs b/src/sariulclocks.hs index 3bc55a2..6514b6c 100644 --- a/src/sariulclocks.hs +++ b/src/sariulclocks.hs @@ -7,7 +7,7 @@ import Types.Scores import Data.Classes import Data.List.Split (splitOn) import System.Time (getClockTime, CalendarTime, toCalendarTime) -import Control.Monad (liftM) +import Control.Monad (liftM, when) import Control.Monad.Trans (lift) import Data.Maybe (fromMaybe) import Types.Session @@ -15,6 +15,9 @@ import Types.Clocks import Control.Monad.Page import Utils.Classes import Text.XHtml.Bootstrap +import Control.Exception (onException) +import Data.Char (isDigit) +import Data.Maybe (fromJust) navBar :: Page Html navBar = do @@ -41,7 +44,7 @@ navBar = do lessonButtons :: Maybe Class -> Html lessonButtons Nothing = bsButton "start-lesson" "btn btn-info" "Start lesson" - +++ bsButton "end-of-week" "btn btn-info" "End of week" + +++ bsButton "end-of-week" "btn btn-default" "End of week" lessonButtons (Just _) = bsButton "end-lesson" "btn btn-info" "End lesson" +++ bsButton "lucky-number" "btn btn-danger" "Lucky number" @@ -111,12 +114,18 @@ 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 = do theNavBar <- navBar theClocks <- clocks theRankings <- rankings - return (theNavBar +++ theClocks +++ theDate +++ theRankings) + theForms <- forms + return (theNavBar +++ theClocks +++ theDate +++ theRankings +++ theForms) cgiMain :: CGI CGIResult cgiMain = do @@ -130,9 +139,15 @@ cgiMain = do clockTime <- liftIO getClockTime + points <- liftM (fromMaybe "0") $ getInput "class_points" + timeWasted <- liftM (fromMaybe "0") $ getInput "class_time_wasted" + let points' = readInt points + let timeWasted' = readInt timeWasted + cookieClock <- liftM (fromMaybe 0) $ readCookie "clock_cookie" cookieClass <- liftM (parseClassCookie) $ getCookie "class_cookie" - let session = Session { currentClass = cookieClass + + let session = Session { currentClass = if points' /= 0 then Nothing else cookieClass , currentClock = case cookieClock of 0 -> CountDownClock @@ -140,11 +155,25 @@ cgiMain = do -- now do our CGI work - let (newScores, newSession, html) = runPage makePage scores session + -- TODO: password! read it from a file + + -- TODO: so that can input password without it being echoed, + -- unhide the form + + let scores' = + if points' /= 0 + then updateScore scores (fromJust cookieClass) points' timeWasted' + else scores + + let (newScores, newSession, html) = runPage makePage scores' session setCookie $ makeClassCookie clockTime newSession setCookie $ makeClockCookie clockTime newSession + -- let html' = html +++ show points' +++ show timeWasted' + + when (newScores /= scores) $ liftIO $ writeScoresFile newScores + output $ templateInject htmlTemplate html main = runCGI . handleErrors $ cgiMain @@ -153,3 +182,10 @@ templateInject :: String -> Html -> String templateInject template body = templateBefore ++ (renderHtmlFragment body) ++ templateAfter where (templateBefore:templateAfter:_) = splitOn "BODY_HERE" template + +readInt :: String -> Int +readInt string = if null string' + then 0 + else read string' + where + string' = filter isDigit string -- cgit v1.2.3