Commit 31d061c1 authored by Christopher League's avatar Christopher League 🖥

Time zone selector

parent b5ab674f
......@@ -10,3 +10,4 @@
/avail AvailR GET
/book BookR GET POST
/final FinalR GET
/clear ClearR GET
......@@ -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
......
......@@ -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
......
{-# 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
......
{-# 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
......
......@@ -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}
$(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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment