Skip to content

GitLab

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

Separate QueryForm module, with widget files

parent be1dc5dc
Hide whitespace changes
Inline Side-by-side
Showing with 212 additions and 172 deletions
src/Calendar.hs
View file @ ae8c5aa6
...@@ -180,13 +180,13 @@ listUpcoming (MockCxt d) cid _ = ...@@ -180,13 +180,13 @@ listUpcoming (MockCxt d) cid _ =
, ("busy3b", fwd 2, 1900, 2100) , ("busy3b", fwd 2, 1900, 2100)
] ]
free = free =
[ ("free1a", fwd 0, 1100, 1155) [ ("free1a" , fwd 0, 1100, 1155)
, ("free1b", fwd 0, 1300, 1450) , ("free1b #office", fwd 0, 1300, 1450)
, ("free1c", fwd 0, 1530, 1800) , ("free1c #office", fwd 0, 1530, 1800)
, ("free2a", fwd 1, 1200, 1600) , ("free2a #home" , fwd 1, 1200, 1600)
, ("free2b", fwd 1, 1700, 1800) , ("free2b #office", fwd 1, 1700, 1800)
, ("free3a", fwd 2, 1000, 1200) , ("free3a #office", fwd 2, 1000, 1200)
, ("free3b", fwd 2, 1500, 1930) , ("free3b #home" , fwd 2, 1500, 1930)
] ]
listUpcoming (GoogleCxt env) cid lookahead = do listUpcoming (GoogleCxt env) cid lookahead = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
......
src/Handler/Home.hs
View file @ ae8c5aa6
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
...@@ -10,184 +11,60 @@ ...@@ -10,184 +11,60 @@
module Handler.Home where module Handler.Home where
import qualified Calendar as Cal import qualified Calendar as Cal
import qualified Data.Time.Format as TF
import Import import Import
import Text.Julius (RawJS (..)) import Text.Julius (RawJS (..))
import Data.Time.LocalTime (LocalTime)
apptLengthOptions :: Handler (OptionList Int) import qualified QueryForm as QF
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)
getHomeR :: Handler Html getHomeR :: Handler Html
getHomeR getHomeR = do
-- Start (but don't wait for) refresh of calendar
= do
App {..} <- getYesod App {..} <- getYesod
-- Start refresh of calendar, but don't wait for result.
void $ async $ appGetCalendar Nothing void $ async $ appGetCalendar Nothing
(widget, enctype) <- generateFormPost queryForm (widget, enctype) <- generateFormPost QF.queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout $(widgetFile "step1") defaultLayout $(widgetFile "step1")
getAvailR :: Handler Html getAvailR :: Handler Html
getAvailR = do getAvailR =
((qr, _), _) <- runFormGet queryForm fst . fst <$> runFormGet QF.queryForm >>= \case
case qr of FormMissing -> invalidArgs ["missing"]
FormMissing -> invalidArgs ["missing"] FormFailure errs -> invalidArgs errs
FormFailure errs -> invalidArgs errs FormSuccess QF.QueryForm{..} -> do
FormSuccess q -> do App {appSettings = AppSettings {..}, ..} <- getYesod
App {appSettings = AppSettings {..}, ..} <- getYesod let tz = tzByLabel queryTzLabel
let tz = tzByLabel $ queryTzLabel q showT = QF.showTime queryTimeFmt . Cal.seStart
evs1 <- appGetCalendar Nothing showD = QF.showDate . Cal.seStart
let evs2 = Cal.partitionSlots (queryApptLength q) evs1 slotVal = tshow . Cal.seStart
let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2 avail <-
fmt = Cal.groupByDay .
if queryTimeFmt q == Time12h map (Cal.applyTz tz) .
then "%l:%M %p" Cal.partitionSlots queryApptLength .
else "%H:%M" filter (isInfixOf (locSearch queryLocation) . Cal.seSummary) <$>
showDate = TF.formatTime TF.defaultTimeLocale "%A %e %B" . Cal.seStart appGetCalendar Nothing
showTime e = withUrlRenderer
TF.formatTime TF.defaultTimeLocale fmt (Cal.seStart e) <> ": " <> [hamlet|
unpack (Cal.seSummary e) $if null avail
withUrlRenderer No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
[hamlet| $forall eachDay <- avail
$if null evs' $maybe firstSlot <- headMay eachDay
No appointments available in the next #{appLookaheadWeeks} weeks. <h4>#{showD firstSlot}
$forall day <- evs' <p .slot-choices>
$maybe firstSlot <- headMay day $forall eachSlot <- eachDay
<h4>#{showDate firstSlot} <button type=submit name=slot value=#{slotVal eachSlot} .btn.btn-default.btn-small>#{showT eachSlot}
<p .slot-choices> |]
$forall slot <- day
<button type=submit name=slot value="TBD" .btn.btn-default.btn-small>#{showTime slot}
|]
postConfirmR :: Handler Html postConfirmR :: Handler Html
postConfirmR = do 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 defaultLayout
[whamlet| [whamlet|
<p>OK? <p>OK?
<p> <p>
#{tshow qr} #{tshow qr}
|] <p>
#{tshow zz}
|]
src/Import/NoFoundation.hs
View file @ ae8c5aa6
{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}
module Import.NoFoundation module Import.NoFoundation
( module Import ( module Import
, pluralN
) where ) where
import Calendar as Import (CalendarContext, import Calendar as Import (CalendarContext,
...@@ -11,3 +12,7 @@ import Settings as Import ...@@ -11,3 +12,7 @@ import Settings as Import
import Settings.StaticFiles as Import import Settings.StaticFiles as Import
import Yesod.Core.Types as Import (loggerSet) import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import import Yesod.Default.Config2 as Import
pluralN :: Int -> Text -> Text -> Text
pluralN 1 x _ = "1 " <> x
pluralN n _ y = tshow n <> " " <> y
src/QueryForm.hs 0 → 100644
View file @ ae8c5aa6
{-# 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
stack.yaml
View file @ ae8c5aa6
...@@ -28,7 +28,7 @@ nix: ...@@ -28,7 +28,7 @@ nix:
# Build options # Build options
build: build:
haddock: true haddock: false
haddock-internal: true haddock-internal: true
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
......
templates/query-form.hamlet 0 → 100644
View file @ ae8c5aa6
#{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}
templates/query-form.julius 0 → 100644
View file @ ae8c5aa6
$(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