Separate QueryForm module, with widget files

src/Calendar.hs

@@ -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

src/Handler/Home.hs

 {-# 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
-    FormMissing -> invalidArgs ["missing"]
-    FormFailure errs -> invalidArgs errs
-    FormSuccess q -> 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)
-      withUrlRenderer
-        [hamlet|
-               $if null evs'
-                 No appointments available in the next #{appLookaheadWeeks} weeks.
-               $forall day <- evs'
-                 $maybe firstSlot <- headMay day
-                   <h4>#{showDate firstSlot}
-                   <p .slot-choices>
-                     $forall slot <- day
-                       <button type=submit name=slot value="TBD" .btn.btn-default.btn-small>#{showTime slot}
-                 |]
+getAvailR =
+  fst . fst <$> runFormGet QF.queryForm >>= \case
+  FormMissing -> invalidArgs ["missing"]
+  FormFailure errs -> invalidArgs errs
+  FormSuccess QF.QueryForm{..} -> do
+    App {appSettings = AppSettings {..}, ..} <- getYesod
+    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 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 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}
+            |]

src/Import/NoFoundation.hs

-{-# 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

src/QueryForm.hs

+{-# 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

@@ -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

templates/query-form.hamlet

+#{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

+$(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(),
+    });
+}