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

Start on AJAX response to query

parent ad628cfe
......@@ -3,5 +3,6 @@
(haskell-process-args-cabal-repl . ("-ferror-spans -fno-diagnostics-show-caret -fshow-loaded-modules"))
(haskell-process-args-stack-ghci . ("--ghc-options=-ferror-spans" "--ghc-options=-fno-diagnostics-show-caret" "--ghc-options=-fshow-loaded-modules"))
))
(shakespeare-hamlet-mode . ((electric-indent-mode . nil)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
-- By default this file is used by `parseRoutesFile` in Foundation.hs
-- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers
/static StaticR Static appStatic
/static StaticR Static appStatic
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/cals CalListR GET
/ HomeR GET POST
/api/available AvailR GET
/cals CalListR GET
/comments CommentR POST
/comments CommentR POST
......@@ -11,6 +11,8 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
#approot: "_env:APPROOT:http://localhost:3000"
time-zone: _env:BOOKME_TIME_ZONE:America/New_York
appointment-lengths-minutes: [15, 20, 25]
default-appointment-length: 15
locations:
- - "#office"
- At LIU Brooklyn (usually H700)
......
......@@ -4,6 +4,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
......@@ -71,6 +72,7 @@ makeFoundation appSettings
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
= do
verifySettings appSettings
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
......@@ -107,10 +109,10 @@ makeFoundation appSettings
Google.Error -> LevelError
Google.Debug -> LevelDebug
Google.Trace -> LevelOther "trace"
appGoogleEnv <-
Google.newEnvWith appGoogleCreds googleLogger appHttpManager <&>
Google.envScopes .~
calendarScope
appGoogleEnv <- return (error "TODO appGoogleEnv")
-- Google.newEnvWith appGoogleCreds googleLogger appHttpManager <&>
-- Google.envScopes .~
-- calendarScope
-- Return the foundation
return App {..}
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Foundation where
......@@ -107,21 +109,6 @@ instance Yesod App
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, parents) <- breadcrumbs
-- Define the menu items of the header.
let menuItems =
[ NavbarLeft $
MenuItem
{ menuItemLabel = "Home"
, menuItemRoute = HomeR
, menuItemAccessCallback = True
}
]
let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
let navbarLeftFilteredMenuItems =
[x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
let navbarRightFilteredMenuItems =
[x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -11,7 +12,7 @@ module Handler.Home where
import Control.Lens ((^.))
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones (utcToLocalTimeTZ)
import Data.Time.Zones.All (tzByLabel, toTZName)
import Data.Time.Zones.All (toTZName)
import Import
import qualified Network.Google as Google
import Network.Google.AppsCalendar (calendarListList, clItems,
......@@ -20,38 +21,135 @@ import Text.Julius (RawJS (..))
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..),
renderBootstrap3)
data QueryForm = QueryForm
{ queryLocation :: Location
-- , queryTimeZone :: TZLabel
apptLengthOptions :: Handler (OptionList ApptLength)
apptLengthOptions = do
lengths <- appApptLengths . appSettings <$> getYesod
let
toOption a@(ApptLengthMinutes m) =
Option
{ optionDisplay = tshow m <> " minute"
, optionInternalValue = a
, optionExternalValue = tshow m
}
okLength m =
if len `elem` lengths then Just len else Nothing
where len = ApptLengthMinutes m
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 id name attrs val isReq = do
locs <- appLocations . appSettings <$> getYesod
[whamlet|
<div .form-group>
$forall loc <- locs
<div .radio>
<label>
<input id="#{id}-#{locId loc}" name=#{id} 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 = return $ OptionList
{ olReadExternal = fromPathPiece
, olOptions =
[ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h)
, Option "24-hour" Time24h (toPathPiece Time24h)
]
}
locationOptions :: Handler (OptionList Location)
locationOptions = do
locs <- appLocations . appSettings <$> getYesod
let
mkOpt loc@Location{..} = Option locDescr loc (tshow locId)
readOpt i = find ((== i) . locId) locs
return $ OptionList (map mkOpt locs) (readMay >=> readOpt)
data QueryForm = QueryForm
{ queryApptLength :: ApptLength
, queryUseAmPm :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
} deriving Show
queryForm :: Maybe QueryForm -> Form QueryForm
queryForm defaultQ =
renderBootstrap3 BootstrapBasicForm $
QueryForm <$> areq (radioField locationOptions) "Location" (queryLocation <$> defaultQ)
-- <*> areq (selectField _) "
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") (Just appDefaultApptLength)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
(locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
let
q = QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes
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 = do
AppSettings{..} <- appSettings <$> getYesod
let appLengths = [15, 20, 25] :: [Int]
defaultLength = 20
lengthRadios = zip appLengths (map (== defaultLength) appLengths)
let currentTz = decodeUtf8 (toTZName appDefaultTimeZone)
defaultQ = QueryForm <$> headMay appLocations
tzs = map (decodeUtf8 . toTZName) [minBound..maxBound]
(formWidget, formEnctype) <- generateFormPost $ queryForm defaultQ
(widget, enctype) <- generateFormGet' queryForm
defaultLayout
$(widgetFile "step1")
getAvailR :: Handler Html
getAvailR = do
((q, _), _) <- runFormGet queryForm
withUrlRenderer
[hamlet|
<p>Hello, available
<pre>
#{tshow q}
|]
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
......
......@@ -19,7 +19,9 @@ import Data.Aeson (Result (..), fromJSON, withObject,
import qualified Data.Aeson.Types as Js
import Data.FileEmbed (embedFile)
import Data.Time.Clock (NominalDiffTime)
import Data.Time.Zones.All (TZLabel, fromTZName)
import qualified Data.Time.Zones.All as TZ
import Data.Time.Zones (TZ)
import Data.Time.Zones.All (TZLabel, fromTZName, toTZName)
import Data.Yaml (decodeEither')
import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Google.Auth (OAuthClient(..), ClientId(..),
......@@ -31,15 +33,23 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload,
widgetFileReload)
-- | Represent the valid appointment lengths, in minutes.
newtype ApptLength =
ApptLengthMinutes Int
deriving (Eq, Ord, Show)
instance FromJSON ApptLength where
parseJSON s = ApptLengthMinutes <$> parseJSON s
data Location = Location
{ locId :: Int
{ locId :: Text
, locSearch :: Text
, locDescr :: Text
} deriving (Show, Eq)
makeLocs :: [(Text,Text)] -> [Location]
makeLocs = zipWith mk [1..]
where mk i (s,d) = Location i s d
makeLocs = zipWith mk ['A'..]
where mk c (s,d) = Location (snoc "loc" c) s d
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
......@@ -74,14 +84,21 @@ data AppSettings = AppSettings
-- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appDefaultTimeZone :: TZLabel
, appDefaultTimeZone :: TZLabelW
, appLocations :: [Location]
, appFreeCalendarId :: Text
, appBusyCalendarId :: Text
, appLookahead :: NominalDiffTime
, appApptLengths :: [ApptLength]
, appDefaultApptLength :: ApptLength
}
newtype TZLabelW = TZLabelW { unwrapTZLabel :: TZLabel }
newtype TZLabelW =
TZLabelW { unwrapTZLabel :: TZLabel }
deriving (Eq, Show, Read)
tzByLabel :: TZLabelW -> TZ
tzByLabel = TZ.tzByLabel . unwrapTZLabel
instance FromJSON TZLabelW where
parseJSON v =
......@@ -89,6 +106,10 @@ instance FromJSON TZLabelW where
Just tz -> return $ TZLabelW tz
Nothing -> Js.typeMismatch "TZLabel" v
instance PathPiece TZLabelW where
toPathPiece = toPathPiece . decodeUtf8 . toTZName . unwrapTZLabel
fromPathPiece = fmap TZLabelW . fromTZName . encodeUtf8
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev =
......@@ -113,14 +134,22 @@ instance FromJSON AppSettings where
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"
appDefaultTimeZone <- unwrapTZLabel <$> o .: "time-zone"
appDefaultTimeZone <- o .: "time-zone"
appLocations <- makeLocs <$> o .: "locations"
appFreeCalendarId <- o .: "free-calendar"
appBusyCalendarId <- o .: "busy-calendar"
appLookahead <- (7*24*60*60*) <$> o .: "look-ahead-weeks"
appApptLengths <- o .: "appointment-lengths-minutes"
appDefaultApptLength <- o .: "default-appointment-length"
return AppSettings {..}
-- | Run a consistency check for settings.
verifySettings :: MonadIO m => AppSettings -> m ()
verifySettings AppSettings{..} =
unless (appDefaultApptLength `elem` appApptLengths) $
throwString "invalid default-appointment-length"
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
......
......@@ -34,9 +34,6 @@
site's home screen in Routes file
<tt>config/routes
<li .list-group-item>
We can link to other handlers, like the <a href="@{CommentR}">Comment</a>.
<li .list-group-item>
The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
most of them are brought together by the <tt>defaultLayout</tt> function which #
......
<h2>Book an appointment
<p style="line-height:2.5">
Show
<select>
<option>15 minute
<option>20 minute
<option>25 minute
slots using
<select>
<option>12-hour (AM/PM)
<option>24-hour
notation in
#{currentTz}
time zone:
<div .form-group>
$forall loc <- appLocations
<div .radio>
<label>
<input name=meetloc type=radio value=#{locId loc}>#{locDescr loc}
^{widget}
<p style="font-size:150%">
<span .glyphicon.glyphicon-off.fast-right-spinner>
// -*- js -*-
function sendQuery() {
var url = "@{AvailR}?" + gatherQueryParams();
$.ajax({
url: url,
success: function(data) {
console.log("SUCCESS", data)
},
error: function(data) {
console.log("ERROR", data)
},
})
}
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