QueryForm.hs 4.71 KB
Newer Older
1
{-# LANGUAGE FlexibleContexts  #-}
2
{-# LANGUAGE LambdaCase        #-}
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
{-# 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(..)
20
  , Slot(..)
21 22 23
  , queryForm
  , showDate
  , showTime
24 25 26 27 28 29 30
  , getLocationById
  , parseLocationField
  , idApptLength
  , idTimeFmt
  , idTzLabel
  , idLocation
  , idSlot
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
  ) 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

53 54 55 56 57 58 59
newtype Slot = Slot { slotLocal :: LocalTime }
  deriving Show

instance PathPiece Slot where
  toPathPiece = tshow . slotLocal
  fromPathPiece t = Slot <$> readMay t

60 61 62 63 64
data QueryForm = QueryForm
  { queryApptLength :: Int
  , queryTimeFmt    :: TimeFmt
  , queryTzLabel    :: TZLabelW
  , queryLocation   :: Location
65
  , querySlot       :: Maybe Slot
66 67
  } deriving (Show)

68 69 70 71 72 73 74 75 76 77 78 79
idApptLength :: Text
idTimeFmt    :: Text
idTzLabel    :: Text
idLocation   :: Text
idSlot       :: Text

idApptLength = "len"
idTimeFmt    = "fmt"
idTzLabel    = "tz"
idLocation   = "loc"
idSlot       = "slot"

80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
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)
        ]
    }

110 111 112 113 114 115 116 117 118 119 120 121 122 123
getLocationById :: Text -> Handler (Maybe Location)
getLocationById i = do
  find ((== i) . locId) . appLocations . appSettings <$> getYesod

parseLocationField :: [Text] -> [FileInfo] -> Handler (Either (SomeMessage App) (Maybe Location))
parseLocationField [] _ =
  return $ Left $ SomeMessage $ MsgInputNotFound "location"
parseLocationField (txt:_) _ =
  getLocationById txt >>= return . \case
  Nothing  -> Left $ SomeMessage $ MsgInvalidEntry txt
  Just loc -> Right $ Just loc

locationChoiceField :: Field Handler Location
locationChoiceField = Field {..}
124
  where
125 126
    fieldEnctype = UrlEncoded
    fieldParse = parseLocationField
127 128 129 130 131 132 133 134 135 136 137 138
    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}
              |]
139

140 141 142 143 144 145 146 147 148

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)
149
      (qs idApptLength)
150
      (headMay appApptLengthsMinutes)
151 152 153 154
  (fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs idTimeFmt) (Just def)
  (locRes, locView) <- mreq locationChoiceField (qs idLocation) (headMay appLocations)
  (slotRes, _) <- mopt textField (qs idSlot) Nothing
  (tzRes, _) <- mreq hiddenField (qs idTzLabel) (Just appDefaultTimeZone)
155
  let q =
156 157
        QueryForm <$> lenRes <*> fmtRes <*> tzRes <*> locRes <*>
        ((>>= fromPathPiece) <$> slotRes)
158 159 160 161 162 163 164 165 166 167 168 169
      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