Time zone selector

config/routes

@@ -10,3 +10,4 @@
 /avail       AvailR    GET
 /book        BookR     GET  POST
 /final       FinalR    GET
+/clear       ClearR    GET

src/Calendar.hs

@@ -255,7 +255,7 @@ listUpcoming (GoogleCxt env) cid lookahead = do
     Google.runGoogle env $
     Google.send $ eventsList cid & elTimeMin .~ Just now & elTimeMax .~ Just end
   let es = SL.toSortedList $ mapMaybe simplifyEvent $ xs ^. eveItems
-  forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
+  --forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
   return es
 
 sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
@@ -320,7 +320,7 @@ listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
   availT <- async $ listUpcoming cxt cidAvail lookahead
   busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
   es <- availMinusBusy <$> waitAsync availT <*> waitAsync busyT
-  forM_ (SL.fromSortedList es) $ sayEvent "DIFF"
+  --forM_ (SL.fromSortedList es) $ sayEvent "DIFF"
   return es
 
 -- | Take a stream of available times and split them into slots exactly

src/Handlers.hs

@@ -20,6 +20,7 @@ module Handlers
   , getBookR
   , postBookR
   , getFinalR
+  , getClearR
   ) where
 
 import qualified BookingForm               as BF
@@ -116,6 +117,9 @@ getFinalR = do
             <p>#{tshow b}
             |]
 
+getClearR :: Handler Html
+getClearR = clearSession >> redirect HomeR
+
 -- These handlers embed files in the executable at compile time to avoid a
 -- runtime dependency, and for efficiency.
 getFaviconR :: Handler TypedContent

src/QueryForm.hs

+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
@@ -41,6 +42,7 @@ import           Control.Monad.Trans.Maybe
 import qualified Data.Time.Format          as TF
 import           Data.Time.LocalTime       (LocalTime)
 import           Import
+import qualified Data.Map as Map
 import           Text.Blaze                (ToMarkup (..))
 import           Text.Julius               (RawJS (..), ToJavascript (..))
 
@@ -207,13 +209,51 @@ locationChoiceField = Field {..}
       locs <- appLocations . appSettings <$> getYesod
       $(widgetFile "query-locations")
 
+zonesByContinent =
+  Map.fromList $ map continent $ groupAllOn fst $ map splitTz allZones
+  where
+    allZones :: [TZLabelW]
+    allZones = [minBound..maxBound]
+
+    splitTz :: TZLabelW -> (Text, Text)
+    splitTz = (id *** drop 1) . break (== '/') . toPathPiece
+
+    continent :: [(Text,Text)] -> (Text,[Text])
+    continent [] = error "zonesByContinent: Impossible"
+    continent ((x,y):xys) = (x, y : map snd xys)
+
+-- | Present time zone choices.
+tzSelectorField :: Field Handler TZLabelW
+tzSelectorField = Field {..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldParse (txt:_) _ = return $ Right $ fromPathPiece txt
+    fieldParse _ _ =  return $ Left $ SomeMessage $ MsgInvalidEntry "Timezone"
+    fieldView i name attrs val req = do
+      AppSettings{appDefaultTimeZone} <- appSettings <$> getYesod
+      let currentTz = toPathPiece $ either (const appDefaultTimeZone) id val
+          cityAttrs = [(asText "class", "tzsel " <> qControl)]
+      [whamlet|
+              <input type=hidden name=#{name} value=#{currentTz}>
+              <select name=#{name}-con *{attrs}>
+                $forall c <- Map.keys zonesByContinent
+                  <option value=#{c} :isPrefixOf c currentTz:selected>#{c}
+              $forall c <- Map.keys zonesByContinent
+                <select name=#{name}-#{c} :not(isPrefixOf c currentTz):style="display:none" *{cityAttrs}>
+                  $maybe xs <- lookup c zonesByContinent
+                    $forall x <- xs
+                      <option value=#{x} :isSuffixOf x currentTz:selected>#{x}
+              |]
+
+qControl :: Text
+qControl = "qcontrol"
+
 -- | The complete query form for the front page.
 queryForm ::
      Maybe QueryForm -> Html -> MForm Handler (FormResult QueryForm, Widget)
 queryForm qOpt extra = do
   AppSettings {..} <- appSettings <$> getYesod
-  qc <- newIdent
-  let qs n = "" {fsName = Just (qiName n), fsAttrs = [("class", qc)]}
+  let qs n = "" {fsName = Just (qiName n), fsAttrs = [("class", qControl)]}
   (lenRes, lenView) <-
     mreq
       (selectField apptLengthOptions)
@@ -229,9 +269,9 @@ queryForm qOpt extra = do
       locationChoiceField
       (qs idLocation)
       (queryLocation <$> qOpt <|> headMay appLocations)
-  (tzRes, _) <-
+  (tzRes, tzView) <-
     mreq
-      hiddenField
+      tzSelectorField
       (qs idTzLabel)
       (queryTzLabel <$> qOpt <|> Just appDefaultTimeZone)
   return

src/Settings.hs

 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
@@ -113,7 +114,7 @@ data AppSettings = AppSettings
 -- | Wrap a time zone label, so we can specify type classes.
 newtype TZLabelW = TZLabelW
   { unwrapTZLabel :: TZLabel
-  } deriving (Eq, Show)
+  } deriving (Eq, Show, Bounded, Enum)
 
 -- | Look up the time zone spec for given label.
 tzByLabel :: TZLabelW -> TZ

templates/query-form.hamlet

@@ -4,9 +4,12 @@
   ^{fvInput lenView}
   meeting times using
   ^{fvInput fmtView}
-  notation in
-  #{toPathPiece appDefaultTimeZone}
-  <input #tz .qc name=tz type=hidden
-         value=#{toPathPiece appDefaultTimeZone}>
-  time zone:
+  notation
+
+<p>
+  for the time zone
+  ^{fvInput tzView}
+    <a href=@{ClearR}>(Reset to defaults)</a>
+
+<p>
   ^{fvInput locView}

templates/query-form.julius

 $(function(){
-    $(".#{rawJS qc}").change(sendQuery);
+    $(".#{rawJS qControl}").change(juggleTimeZone);
     sendQuery();
 });
+function juggleTimeZone() {
+    if($(this).hasClass("tzsel") || $(this).attr("name") == "tz-con") {
+        var continent = $("select[name=tz-con]").val();
+        var citySel = "select[name=tz-"+continent+"]";
+        $(".tzsel").hide();
+        $(citySel).show();
+        $("input[name=tz]").val(continent + "/" + $(citySel).val());
+    }
+    sendQuery();
+}
 function gatherQueryParams() {
     return $.param({
         _hasdata: 1,