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

Allow for mock calendar, POST to confirm page

parent c2faf31a
......@@ -7,6 +7,7 @@
/robots.txt RobotsR GET
/ HomeR GET POST
/confirm ConfirmR POST
/api/available AvailR GET
/cals CalListR GET
......
......@@ -19,6 +19,10 @@ locations:
- - ""
- Online via Google Hangout or phone
calendar-credentials:
client_id: "_env:BOOKME_GOOGLE_ID:mock"
client_secret: "_env:BOOKME_GOOGLE_SECRET:"
refresh_token: "_env:BOOKME_GOOGLE_REFRESH:"
free-calendar: _env:BOOKME_FREE_CAL:uhqg996jdq8gc8r8g1bee8clc8@group.calendar.google.com
busy-calendar: _env:BOOKME_BUSY_CAL:cleague@gmail.com
look-ahead-weeks: 4
......
......@@ -20,6 +20,7 @@ module Application
, handler
) where
import qualified Calendar as Cal
import Control.Lens ((.~), (<&>))
import Control.Monad.Logger (liftLoc)
import Control.Monad.Logger (defaultLoc)
......@@ -80,40 +81,14 @@ makeFoundation appSettings
then staticDevel
else static)
(appStaticDir appSettings)
OAuthClient {..} <- oauthClientFromEnv
token <- getEnv varGoogleRefreshToken
appGoogleCreds <-
either throwString return $
Google.fromJSONCredentials $
Js.encode $
object
[ "client_id" .= _clientId
, "client_secret" .= _clientSecret
, "refresh_token" .= token
]
let googleLogger level builder =
whenM (shouldLogIO partialApp "" lv) $
messageLoggerSource
partialApp
appLogger
defaultLoc
""
lv
(toLogStr (toLazyByteString builder))
where
appGoogleEnv = error "Accessing appGoogleEnv from googleLogger"
partialApp = App {..}
lv =
case level of
Google.Info -> LevelInfo
Google.Error -> LevelError
Google.Debug -> LevelDebug
Google.Trace -> LevelOther "trace"
appGoogleEnv <- return (error "TODO appGoogleEnv")
-- Google.newEnvWith appGoogleCreds googleLogger appHttpManager <&>
-- Google.envScopes .~
-- calendarScope
-- Return the foundation
let
logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv
where
partialApp = App{..}
appCalendarCxt = error "LOOP: Accessing appCalendarCxt from logFunc"
appCalendarCxt <- Cal.initialize logFunc appHttpManager (appCredentials appSettings)
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Calendar
( Credentials
, Scope
, Context
, initialize
, listCalendars
) where
import ClassyPrelude.Yesod
import Control.Lens ((.~), (<&>), (^.))
import Control.Monad.Logger (Loc, LogSource, LogStr, defaultLoc)
import Data.ByteString.Builder (toLazyByteString)
import Network.Google.AppsCalendar
import System.Log.FastLogger (toLogStr)
import qualified Data.Aeson as Js
import qualified Network.Google as Google
import qualified Network.Google.Auth as Google
import qualified Network.Google.Auth.ApplicationDefault as Google
type Scope = '[ "https://www.googleapis.com/auth/calendar"]
mockClientId :: Text
mockClientId = "mock"
data Credentials
= MockCreds
| GoogleCreds (Google.Credentials Scope)
instance Show Credentials where
show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>"
instance FromJSON Credentials where
parseJSON = Js.withObject "Credentials" $ \o ->
o .: "client_id" >>= \c ->
if c == mockClientId
then return MockCreds
else either fail (return . GoogleCreds) $
Google.fromJSONCredentials $ Js.encode o
data Context
= MockCxt
| GoogleCxt (Google.Env Scope)
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
initialize :: LogFunc -> Manager -> Credentials -> IO Context
initialize _ _ MockCreds = return MockCxt
initialize appLog manager (GoogleCreds creds) =
GoogleCxt <$>
(Google.newEnvWith creds gooLog manager <&> Google.envScopes .~ calendarScope)
where
gooLog level builder =
appLog defaultLoc "" lv (toLogStr (toLazyByteString builder))
where
lv = case level of
Google.Info -> LevelInfo
Google.Error -> LevelError
Google.Debug -> LevelDebug
Google.Trace -> LevelOther "trace"
listCalendars :: MonadResource m => Context -> m [Text]
listCalendars MockCxt = return []
listCalendars (GoogleCxt env) = do
xs <- Google.runGoogle env $ Google.send calendarListList
return $ mapMaybe (^. cleSummary) (xs ^. clItems)
......@@ -12,6 +12,7 @@
module Foundation where
import qualified Calendar as Cal
import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI
......@@ -34,15 +35,9 @@ data App = App
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appGoogleCreds :: Google.Credentials CalendarScope
, appGoogleEnv :: Google.Env CalendarScope
, appCalendarCxt :: Cal.Context
}
runGoogle :: Google.Google CalendarScope a -> HandlerFor App a
runGoogle action = do
env <- appGoogleEnv <$> getYesod
Google.runGoogle env action
data MenuItem = MenuItem
{ menuItemLabel :: Text
, menuItemRoute :: Route App
......
......@@ -9,6 +9,7 @@
module Handler.Home where
import qualified Calendar as Cal
import Control.Lens ((^.))
import Data.Time.Clock (addUTCTime)
import Data.Time.Zones (utcToLocalTimeTZ)
......@@ -86,9 +87,10 @@ timeFmtOptions = return $ OptionList
data QueryForm = QueryForm
{ queryApptLength :: ApptLength
, queryUseAmPm :: TimeFmt
, queryTimeFmt :: TimeFmt
, queryTzLabel :: TZLabelW
, queryLocation :: Location
, querySlot :: Maybe Text -- TBD
} deriving Show
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
......@@ -99,8 +101,9 @@ queryForm extra = do
(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)
(slotRes, _) <- mopt textField (qs "slot") Nothing
let
q = QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes
q = QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*> slotRes
widget = do
toWidget
[julius|
......@@ -136,20 +139,40 @@ queryForm extra = do
getHomeR :: Handler Html
getHomeR = do
(widget, enctype) <- generateFormGet' queryForm
(widget, enctype) <- generateFormPost queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout
$(widgetFile "step1")
getAvailR :: Handler Html
getAvailR = do
((q, _), _) <- runFormGet queryForm
((qr, _), _) <- runFormGet queryForm
let
FormSuccess q = qr -- TODO
ds = [1..4] :: [Int]
ts =
if queryTimeFmt q == Time12h
then ["11:00 AM", "12:00 PM", "1:00 PM", "2:30 PM"]
else ["11:00", "12:00", "13:00", "14:30"] :: [Text]
slotV d t = tshow d <> "/" <> t
withUrlRenderer
[hamlet|
<p>Hello, available
<pre>
#{tshow q}
$forall d <- ds
<h4>Day #{tshow d}
$forall t <- ts
<button type=submit name=slot value="#{slotV d t}" .btn.btn-default.btn-small>#{t}
|]
postConfirmR :: Handler Html
postConfirmR = do
((qr, _), _) <- runFormPost queryForm
defaultLayout
[whamlet|
<p>OK?
<p>
#{tshow qr}
|]
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
......@@ -210,16 +233,15 @@ commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
getCalListR :: Handler Html
getCalListR = do
AppSettings {..} <- appSettings <$> getYesod
(AppSettings{..}, cxt) <- (appSettings &&& appCalendarCxt) <$> getYesod
endUTC <- liftIO $ addUTCTime appLookahead <$> getCurrentTime
let endLocal = utcToLocalTimeTZ (tzByLabel appDefaultTimeZone) endUTC
xs <- runGoogle $ Google.send calendarListList
xs <- Cal.listCalendars cxt
defaultLayout
[whamlet|
<h2>Hello calendar
<pre>#{show endLocal}
<ol>
$forall itemOpt <- xs ^. clItems
$maybe item <- itemOpt ^. cleSummary
<li>#{item}
$forall x <- xs
<li>#{x}
|]
......@@ -12,6 +12,7 @@
-- declared in the Foundation.hs file.
module Settings where
import qualified Calendar as Cal
import ClassyPrelude.Yesod
import qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject,
......@@ -84,6 +85,7 @@ data AppSettings = AppSettings
-- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appCredentials :: Cal.Credentials
, appDefaultTimeZone :: TZLabelW
, appLocations :: [Location]
, appFreeCalendarId :: Text
......@@ -141,6 +143,7 @@ instance FromJSON AppSettings where
appLookahead <- (7*24*60*60*) <$> o .: "look-ahead-weeks"
appApptLengths <- o .: "appointment-lengths-minutes"
appDefaultApptLength <- o .: "default-appointment-length"
appCredentials <- o .: "calendar-credentials"
return AppSettings {..}
......@@ -213,8 +216,6 @@ varGoogleSecret = "BOOKME_GOOGLE_SECRET"
varGoogleRefreshToken :: IsString s => s
varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH"
type CalendarScope = '[ "https://www.googleapis.com/auth/calendar"]
oauthClientFromEnv :: IO OAuthClient
oauthClientFromEnv =
OAuthClient <$> (ClientId . pack <$> getEnv varGoogleClientId) <*>
......
......@@ -14,6 +14,7 @@ module Settings.Auth
( authorizeMain
) where
import qualified Calendar as Cal
import Import
import Network.Google (LogLevel (Error), newLogger)
import Network.Google.AppsCalendar (calendarScope)
......@@ -35,7 +36,7 @@ authorizeMain = do
formURL oac calendarScope <>
"\n\nThen run again with code as first argument.\n"
Just code -> do
let creds = FromClient oac (OAuthCode code) :: Credentials CalendarScope
let creds = FromClient oac (OAuthCode code) :: Credentials Cal.Scope
mgr <- newManagerSettings tlsManagerSettings
lgr <- newLogger Error stdout
auth <- exchange creds lgr mgr
......
......@@ -23,7 +23,7 @@ $newline never
<script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/js-cookie/2.0.3/js.cookie.min.js">
\<!-- Bootstrap-3.3.7 compiled and minified JavaScript -->
<script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha384-Tc5IQib027qvyjSMfHjOMaLkfuWVxZxUPnCJA7l2mCWNIpG9mGCD8wGNIcPD7Txa" crossorigin="anonymous">
<script src=@{StaticR css_bootstrap_css}>
<script>
/* The `defaultCsrfMiddleware` Middleware added in Foundation.hs adds a CSRF token to the request cookies. */
......
<h2>Book an appointment
^{widget}
<form enctype=#{enctype} method=POST action=@{ConfirmR}>
^{widget}
<p style="font-size:150%">
<div ##{idAvail} style="display:none">
<p ##{idSpinner} style="font-size:150%">
<span .glyphicon.glyphicon-off.fast-right-spinner>
<div ##{idAlert} .alert.alert-danger style="display:none" role=alert>
<p>
<b>Oops
// -*- js -*-
function sendQuery() {
$("##{rawJS idSpinner}").show();
$("##{rawJS idAvail}").hide();
var url = "@{AvailR}?" + gatherQueryParams();
$.ajax({
url: url,
success: function(data) {
console.log("SUCCESS", data)
$("##{rawJS idAvail}").html(data);
$("##{rawJS idAvail}").show();
},
error: function(data) {
console.log("ERROR", data)
$("##{rawJS idAlert}").html(data.statusText).show();
},
complete: function() {
$("##{rawJS idSpinner}").hide();
},
})
}
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