Commit ae8c5aa6 authored by Christopher League's avatar Christopher League 🖥

Separate QueryForm module, with widget files

parent be1dc5dc
......@@ -180,13 +180,13 @@ listUpcoming (MockCxt d) cid _ =
, ("busy3b", fwd 2, 1900, 2100)
]
free =
[ ("free1a", fwd 0, 1100, 1155)
, ("free1b", fwd 0, 1300, 1450)
, ("free1c", fwd 0, 1530, 1800)
, ("free2a", fwd 1, 1200, 1600)
, ("free2b", fwd 1, 1700, 1800)
, ("free3a", fwd 2, 1000, 1200)
, ("free3b", fwd 2, 1500, 1930)
[ ("free1a" , fwd 0, 1100, 1155)
, ("free1b #office", fwd 0, 1300, 1450)
, ("free1c #office", fwd 0, 1530, 1800)
, ("free2a #home" , fwd 1, 1200, 1600)
, ("free2b #office", fwd 1, 1700, 1800)
, ("free3a #office", fwd 2, 1000, 1200)
, ("free3b #home" , fwd 2, 1500, 1930)
]
listUpcoming (GoogleCxt env) cid lookahead = do
now <- liftIO getCurrentTime
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -10,184 +11,60 @@
module Handler.Home where
import qualified Calendar as Cal
import qualified Data.Time.Format as TF
import Import
import Text.Julius (RawJS (..))
apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod
let toOption m =
Option
{ optionDisplay = tshow m <> " minute"
, optionInternalValue = m
, optionExternalValue = tshow m
}
okLength m =
if m `elem` lengths
then Just m
else Nothing
return $
OptionList
{ olOptions = map toOption lengths
, olReadExternal = fromPathPiece >=> okLength
}
locationField :: Field Handler Location
locationField = Field {..}
where
fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location"
fieldParse (txt:_) _ = do
locs <- appLocations . appSettings <$> getYesod
return $
case find ((== txt) . locId) locs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldView i _ attrs val _ = do
locs <- appLocations . appSettings <$> getYesod
[whamlet|
<div .form-group>
$forall loc <- locs
<div .radio>
<label>
<input ##{i}-#{locId loc}" name=#{i} type=radio
value=#{locId loc} :val == Right loc:checked
*{attrs}>
#{locDescr loc}
|]
fieldEnctype = UrlEncoded
data TimeFmt
= Time12h
| Time24h
deriving (Eq, Show, Enum, Bounded)
instance PathPiece TimeFmt where
toPathPiece Time12h = "12h"
toPathPiece Time24h = "24h"
fromPathPiece "12h" = Just Time12h
fromPathPiece "24h" = Just Time24h
fromPathPiece _ = Nothing
instance Default TimeFmt where
def = Time12h
timeFmtOptions :: Handler (OptionList TimeFmt)
timeFmtOptions =
return $
OptionList
{ olReadExternal = fromPathPiece
, olOptions =
[ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h)
, Option "24-hour" Time24h (toPathPiece Time24h)
]
}
data QueryForm = QueryForm
{ queryApptLength :: Int
, queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
, querySlot :: Maybe Text -- TBD
} deriving (Show)
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
queryForm extra = do
AppSettings {..} <- appSettings <$> getYesod
qc <- newIdent
let qs n = "" {fsName = Just n, fsId = Just n, fsAttrs = [("class", qc)]}
(lenRes, lenView) <-
mreq
(selectField apptLengthOptions)
(qs "len")
(headMay appApptLengthsMinutes)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
(locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
(slotRes, _) <- mopt textField (qs "slot") Nothing
let q =
QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*>
slotRes
widget = do
toWidget
[julius|
$(function(){
$(".#{rawJS qc}").change(sendQuery);
sendQuery();
});
function gatherQueryParams() {
return $.param({
_hasdata: 1,
tz: $("#tz").val(),
len: $("#len").val(),
fmt: $("#fmt").val(),
loc: $("input[name=loc]:checked").val(),
});
}
|]
[whamlet|
#{extra}
<p>
Show
^{fvInput lenView}
slots using
^{fvInput fmtView}
notation in
#{toPathPiece appDefaultTimeZone}
<input #tz .qc name=tz type=hidden
value=#{toPathPiece appDefaultTimeZone}>
time zone:
^{fvInput locView}
|]
return (q, widget)
import Data.Time.LocalTime (LocalTime)
import qualified QueryForm as QF
getHomeR :: Handler Html
getHomeR
-- Start (but don't wait for) refresh of calendar
= do
getHomeR = do
App {..} <- getYesod
-- Start refresh of calendar, but don't wait for result.
void $ async $ appGetCalendar Nothing
(widget, enctype) <- generateFormPost queryForm
(widget, enctype) <- generateFormPost QF.queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout $(widgetFile "step1")
getAvailR :: Handler Html
getAvailR = do
((qr, _), _) <- runFormGet queryForm
case qr of
getAvailR =
fst . fst <$> runFormGet QF.queryForm >>= \case
FormMissing -> invalidArgs ["missing"]
FormFailure errs -> invalidArgs errs
FormSuccess q -> do
FormSuccess QF.QueryForm{..} -> do
App {appSettings = AppSettings {..}, ..} <- getYesod
let tz = tzByLabel $ queryTzLabel q
evs1 <- appGetCalendar Nothing
let evs2 = Cal.partitionSlots (queryApptLength q) evs1
let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2
fmt =
if queryTimeFmt q == Time12h
then "%l:%M %p"
else "%H:%M"
showDate = TF.formatTime TF.defaultTimeLocale "%A %e %B" . Cal.seStart
showTime e =
TF.formatTime TF.defaultTimeLocale fmt (Cal.seStart e) <> ": " <>
unpack (Cal.seSummary e)
let tz = tzByLabel queryTzLabel
showT = QF.showTime queryTimeFmt . Cal.seStart
showD = QF.showDate . Cal.seStart
slotVal = tshow . Cal.seStart
avail <-
Cal.groupByDay .
map (Cal.applyTz tz) .
Cal.partitionSlots queryApptLength .
filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
appGetCalendar Nothing
withUrlRenderer
[hamlet|
$if null evs'
No appointments available in the next #{appLookaheadWeeks} weeks.
$forall day <- evs'
$maybe firstSlot <- headMay day
<h4>#{showDate firstSlot}
$if null avail
No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
$forall eachDay <- avail
$maybe firstSlot <- headMay eachDay
<h4>#{showD firstSlot}
<p .slot-choices>
$forall slot <- day
<button type=submit name=slot value="TBD" .btn.btn-default.btn-small>#{showTime slot}
$forall eachSlot <- eachDay
<button type=submit name=slot value=#{slotVal eachSlot} .btn.btn-default.btn-small>#{showT eachSlot}
|]
postConfirmR :: Handler Html
postConfirmR = do
((qr, _), _) <- runFormPost queryForm
((qr, _), _) <- runFormPost QF.queryForm
let zz :: Maybe LocalTime
zz = case qr of
FormSuccess QF.QueryForm{QF.querySlot = Just txt} -> readMay txt
defaultLayout
[whamlet|
<p>OK?
<p>
#{tshow qr}
<p>
#{tshow zz}
|]
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Import.NoFoundation
( module Import
, pluralN
) where
import Calendar as Import (CalendarContext,
......@@ -11,3 +12,7 @@ import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import
pluralN :: Int -> Text -> Text -> Text
pluralN 1 x _ = "1 " <> x
pluralN n _ y = tshow n <> " " <> y
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Module: QueryForm
Description: Form for front page, to query available times
Form for front page, to query available times. Consists of the
location, appointment length, time format, and time zone.
-}
module QueryForm
( QueryForm(..)
, TimeFmt(..)
, queryForm
, showDate
, showTime
) where
import qualified Data.Time.Format as TF
import Data.Time.LocalTime (LocalTime)
import Import
import Text.Julius (RawJS (..))
data TimeFmt
= Time12h
| Time24h
deriving (Eq, Show, Enum, Bounded)
instance PathPiece TimeFmt where
toPathPiece Time12h = "12h"
toPathPiece Time24h = "24h"
fromPathPiece "12h" = Just Time12h
fromPathPiece "24h" = Just Time24h
fromPathPiece _ = Nothing
instance Default TimeFmt where
def = Time12h
data QueryForm = QueryForm
{ queryApptLength :: Int
, queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
, querySlot :: Maybe Text -- TBD
} deriving (Show)
apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod
let toOption m =
Option
{ optionDisplay = tshow m <> " minute"
, optionInternalValue = m
, optionExternalValue = tshow m
}
okLength m =
if m `elem` lengths
then Just m
else Nothing
return $
OptionList
{ olOptions = map toOption lengths
, olReadExternal = fromPathPiece >=> okLength
}
timeFmtOptions :: Handler (OptionList TimeFmt)
timeFmtOptions =
return $
OptionList
{ olReadExternal = fromPathPiece
, olOptions =
[ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h)
, Option "24-hour" Time24h (toPathPiece Time24h)
]
}
locationField :: Field Handler Location
locationField = Field {..}
where
fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location"
fieldParse (txt:_) _ = do
locs <- appLocations . appSettings <$> getYesod
return $
case find ((== txt) . locId) locs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldView i _ attrs val _ = do
locs <- appLocations . appSettings <$> getYesod
[whamlet|
<div .form-group>
$forall loc <- locs
<div .radio>
<label>
<input ##{i}-#{locId loc}" name=#{i} type=radio
value=#{locId loc} :val == Right loc:checked
*{attrs}>
#{locDescr loc}
|]
fieldEnctype = UrlEncoded
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
queryForm extra = do
AppSettings {..} <- appSettings <$> getYesod
qc <- newIdent
let qs n = "" {fsName = Just n, fsId = Just n, fsAttrs = [("class", qc)]}
(lenRes, lenView) <-
mreq
(selectField apptLengthOptions)
(qs "len")
(headMay appApptLengthsMinutes)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
(locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
(slotRes, _) <- mopt textField (qs "slot") Nothing
let q =
QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*>
slotRes
widget = $(widgetFile "query-form")
return (q, widget)
showDate :: LocalTime -> String
showDate = TF.formatTime TF.defaultTimeLocale "%A %e %B"
timeFmt :: TimeFmt -> String
timeFmt Time12h = "%l:%M %p"
timeFmt Time24h = "%H:%M"
showTime :: TimeFmt -> LocalTime -> String
showTime = TF.formatTime TF.defaultTimeLocale . timeFmt
......@@ -28,7 +28,7 @@ nix:
# Build options
build:
haddock: true
haddock: false
haddock-internal: true
# Override default flag values for local packages and extra-deps
......
#{extra}
<p>
Show
^{fvInput lenView}
slots using
^{fvInput fmtView}
notation in
#{toPathPiece appDefaultTimeZone}
<input #tz .qc name=tz type=hidden
value=#{toPathPiece appDefaultTimeZone}>
time zone:
^{fvInput locView}
$(function(){
$(".#{rawJS qc}").change(sendQuery);
sendQuery();
});
function gatherQueryParams() {
return $.param({
_hasdata: 1,
tz: $("#tz").val(),
len: $("#len").val(),
fmt: $("#fmt").val(),
loc: $("input[name=loc]:checked").val(),
});
}
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