[more improvements to pushups demo Jeremy Shaw **20090911222301 Ignore-this: e844fe690235d3f57588c25e3637386c ] hunk ./examples/Pushups.hs 38 -import Happstack.Server (Conf(port, validator), FilterMonad, ServerMonad, ServerPartT, Response, WebMonad, RqData, ToMessage, dir, look, lookPairs, lookRead, nullConf, nullDir, path, simpleHTTP, toResponse, seeOther, withDataFn) +import Happstack.Server (Conf(port, validator), FilterMonad, ServerMonad, ServerPartT, Response, WebMonad, RqData, ToMessage, dir, look, lookPairs, lookRead, nullConf, nullDir, path, simpleHTTP, toResponse, seeOther, withDataFn, ok) hunk ./examples/Pushups.hs 45 -import HacketeriaConfig (facebookConfig) +import FeatsOfStrengthConfig (facebookConfig) hunk ./examples/Pushups.hs 62 +-- TODO: handle improper redirect when you click 'add it' + hunk ./examples/Pushups.hs 83 +authorize :: (XMLGenerator m, EmbedAsChild m c) => FacebookConfig -> c -> XMLGenT m (HSX.XML m) +authorize config c = + <% c %> + +loginSP :: + ( XMLGenerator m + , MonadPlus m + , ServerMonad m + , HasFacebookConfig m + ) + => m (HSX.XML m) +loginSP = + unXMLGenT $ + dir "login" $ + do config <- askFacebookConfig + let key = unApiKey (apiKey config) + next = uriToString id (canvasURL config) "" + uri = "http://www.facebook.com/login.php?v=1.0&api_key=" ++ key ++"&next=" ++ next ++ "&canvas=" + + hunk ./examples/Pushups.hs 293 -$(mkMethods ''State ['addParticipants, 'addScore, 'addInvitees, 'addInviteRequest, 'askChallengeById, 'bongWannabes, 'createChallenge, 'friendsChallenges, 'allChallenges]) +usersChallenges :: User -> Query State Challenges +usersChallenges user = + do cs <- challenges <$> ask + return $ (cs @= user) + +$(mkMethods ''State ['addParticipants, 'addScore, 'addInvitees, 'addInviteRequest, 'askChallengeById, 'bongWannabes, 'createChallenge, 'friendsChallenges, 'allChallenges, 'usersChallenges]) hunk ./examples/Pushups.hs 312 + + Homepage + Create a New Contest + Join a Contest + hunk ./examples/Pushups.hs 319 +

hunk ./examples/Pushups.hs 321 - + hunk ./examples/Pushups.hs 325 +

hunk ./examples/Pushups.hs 340 - appTemplate "Pushup Challenge" $ -

-

Welcome to The Pushup Challenge

-

Challenge your friends and see who can do the most pushups this month!

- <% renderForm "score" ((canvasURLS config) "score/submit") scoreForm %> - <% friendsChallengesFBML %> -
+ user <- askUser + challenges <- query (UsersChallenges user) + if IxSet.null challenges + then appTemplate "Feats of Strength" $ +
+

Challenge your friends to feats of strength.

+
+ else appTemplate "Feats of Strength" $ +
+

Update Your Score

+ <% renderForm "score" ((canvasURLS config) "score/submit") scoreForm %> +

Current Standings

+ <% challengesFBML challenges %> +
hunk ./examples/Pushups.hs 373 - else do user <- askUser + else challengesFBML availChallenges +{- + do user <- askUser hunk ./examples/Pushups.hs 387 +-} +challengesFBML :: + ( MonadIO m + , XMLGenerator m + , HasFacebookConfig m + , HasUser m + , HasSessionKey m + ) + => Challenges -> XMLGenT m (HSX.XML m) +challengesFBML challenges = + do user <- askUser + config <- askFacebookConfig + eInfo <- callMethod (Users.GetStandardInfo [user] [Users.UID .. Users.ProxiedEmail]) + case eInfo of + (Left err) ->
Error calling Users.getStandardInfo: <% show err %>
+ (Right [info]) -> + let tz = fromMaybe utc (Users.timeZone info) in + + (Right info) -> +
Error calling Users.getStandardInfo: <% show info %>
hunk ./examples/Pushups.hs 447 +joinSP :: + ( XMLGenerator m + , MonadIO m + , MonadPlus m + , ServerMonad m + , HasUser m + , HasSessionKey m + , HasFacebookConfig m + ) + => m (HSX.XML m) +joinSP = + dir "join" $ + do config <- askFacebookConfig + appTemplate "Feats of Strength" friendsChallengesFBML + hunk ./examples/Pushups.hs 684 - => TimeZone -> Form [XMLGenT x (HSX.XML x)] v (TimeOfDay, TimeZone) -timePicker defaultTZ = + => Maybe TimeOfDay -> TimeZone -> Form [XMLGenT x (HSX.XML x)] v (TimeOfDay, TimeZone) +timePicker mTime defaultTZ = hunk ./examples/Pushups.hs 688 - hour = (select $ map (\n -> (n, show n)) [1..12]) `check` (required "hour") - minute = (select $ map (\n -> (n, show n)) [0..59]) `check` (required "minute") - ampm = select [(False, "AM"), (True, "PM")] `check` (required "AM/PM") + hour = (select (flip mod 12 . todHour <$> mTime) $ map (\n -> (n, show n)) [1..12]) `check` (required "hour") + minute = (select (todMin <$> mTime) $ map (\n -> (n, show n)) [0..59]) `check` (required "minute") + ampm = (select ((>= 12) . todHour <$> mTime) $ [(False, "AM"), (True, "PM")]) `check` (required "AM/PM") hunk ./examples/Pushups.hs 697 - => Day -> Day -> Form [XMLGenT x (HSX.XML x)] v Day -dayPicker earliest latest = + => Maybe Day -> Day -> Day -> Form [XMLGenT x (HSX.XML x)] v Day +dayPicker defaultDay earliest latest = hunk ./examples/Pushups.hs 701 - year = (select $ map (\n -> (n, show n)) [eYear..lYear]) `check` (required "year") - month = (select $ map (\n -> (n, fst $ (months defaultTimeLocale)!!(n - 1))) [1 .. 12]) `check` (required "month") - day = (select $ map (\n -> (n, show n)) [1..31]) `check` (required "day") + (dYear, dMonth, dDay) = + case defaultDay of + Nothing -> (Nothing, Nothing, Nothing) + (Just ld) -> + let (y,m,d)= toGregorian ld + in (Just y, Just m, Just d) + year = (select dYear $ map (\n -> (n, show n)) [eYear..lYear]) `check` (required "year") + month = (select dMonth $ map (\n -> (n, fst $ (months defaultTimeLocale)!!(n - 1))) [1 .. 12]) `check` (required "month") + day = (select dDay $ map (\n -> (n, show n)) [1..31]) `check` (required "day") hunk ./examples/Pushups.hs 727 - => ZonedTime -> ZonedTime -> TimeZone -> Form [XMLGenT x (HSX.XML x)] v ZonedTime -zonedTimePicker earliest latest defaultTZ = - ((,) <$> dayPicker (localDay (zonedTimeToLocalTime earliest)) (localDay (zonedTimeToLocalTime latest)) - <*> timePicker defaultTZ) + => Maybe ZonedTime -> ZonedTime -> ZonedTime -> TimeZone -> Form [XMLGenT x (HSX.XML x)] v ZonedTime +zonedTimePicker defaultZonedTime earliest latest defaultTZ = + ((,) <$> dayPicker (localDay . zonedTimeToLocalTime <$> defaultZonedTime) (localDay (zonedTimeToLocalTime earliest)) (localDay (zonedTimeToLocalTime latest)) + <*> ((xml $ [ at ]) *> timePicker (localTimeOfDay . zonedTimeToLocalTime <$> defaultZonedTime) defaultTZ)) hunk ./examples/Pushups.hs 748 - do (ChallengeForm <$> (label "Start Date: " *> zonedTimePicker earliest latest tz <* br) - <*> (label "End Date: " *> zonedTimePicker earliest latest tz <* br) + do (ChallengeForm <$> ((label "Start Date:") `fset` ["class" := "date-label"] *> zonedTimePicker (Just earliest) earliest latest tz <* br) + <*> ((label "End Date:") `fset` ["class" := "date-label"] *> zonedTimePicker (Just nextMonth) earliest latest tz <* br) hunk ./examples/Pushups.hs 753 + nextMonth = + let (ZonedTime (LocalTime day tod) tz) = earliest + in (ZonedTime (LocalTime (addGregorianMonthsRollOver 1 day) tod) tz) hunk ./examples/Pushups.hs 757 - label str = xml $ [] + label str = xml $ [
] hunk ./examples/Pushups.hs 930 + , joinSP hunk ./examples/Pushups.hs 933 + , toResponse <$> loginSP hunk ./examples/Pushups.hs 936 - appTemplate "Hello"

This app is about pushups. You can add it here.

+ appTemplate "Hello"

This app is about pushups. Click here to add it.

hunk ./examples/Pushups.hs 1134 + .date-label + { + width: 10em; + }