Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
B
bookme
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Christopher League
bookme
Commits
ed0bb11e
Commit
ed0bb11e
authored
May 31, 2018
by
Christopher League
🖥
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Export list on Foundation
parent
2339d123
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
64 additions
and
65 deletions
+64
-65
src/Foundation.hs
src/Foundation.hs
+20
-33
src/Settings.hs
src/Settings.hs
+28
-22
src/Settings/Auth.hs
src/Settings/Auth.hs
+16
-10
No files found.
src/Foundation.hs
View file @
ed0bb11e
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module
Foundation
where
module
Foundation
(
App
(
..
)
,
Handler
,
Widget
,
Form
,
Route
(
..
)
,
resourcesApp
,
unsafeHandler
)
where
import
qualified
Calendar
as
Cal
import
qualified
Control.Monad.Catch
as
MC
...
...
@@ -41,16 +48,6 @@ data App = App
-- 'appCacheExpiry'.
}
data
MenuItem
=
MenuItem
{
menuItemLabel
::
Text
,
menuItemRoute
::
Route
App
,
menuItemAccessCallback
::
Bool
}
data
MenuTypes
=
NavbarLeft
MenuItem
|
NavbarRight
MenuItem
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
...
...
@@ -85,10 +82,7 @@ addScriptL route cdn attrs =
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance
Yesod
App
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
where
instance
Yesod
App
where
approot
::
Approot
App
approot
=
ApprootRequest
$
\
app
req
->
...
...
@@ -219,10 +213,3 @@ instance HasHttpManager App where
unsafeHandler
::
App
->
Handler
a
->
IO
a
unsafeHandler
=
Unsafe
.
fakeHandlerGetLogger
appLogger
-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
src/Settings.hs
View file @
ed0bb11e
...
...
@@ -17,8 +17,9 @@ module Settings
,
TZLabelW
,
tzByLabel
,
Location
(
..
)
,
varGoogleClientId
,
varGoogleSecret
,
varGoogleRefreshToken
,
oauthClientFromEnv
,
compileTimeAppSettings
,
configSettingsYmlValue
,
widgetFile
...
...
@@ -39,21 +40,20 @@ import Data.Time.Zones.All (TZLabel, fromTZName, toTZName)
import
qualified
Data.Time.Zones.All
as
TZ
import
Data.Yaml
(
decodeEither'
)
import
Language.Haskell.TH.Syntax
(
Exp
,
Name
,
Q
)
import
Network.Google.Auth
(
ClientId
(
..
),
OAuthClient
(
..
),
Secret
(
..
))
import
Network.Wai.Handler.Warp
(
HostPreference
)
import
System.Environment
(
getEnv
)
import
Yesod.Default.Config2
(
applyEnvValue
,
configSettingsYml
)
import
Yesod.Default.Util
(
WidgetFileSettings
,
widgetFileNoReload
,
widgetFileReload
)
-- | Represent a location for an appointment
data
Location
=
Location
{
locId
::
Text
,
locSearch
::
Text
,
locDescr
::
Text
{
locId
::
Text
-- ^ Arbitrary identifier slug used as a path piece
,
locSearch
::
Text
-- ^ Search string, can be blank to allow all available slots
,
locDescr
::
Text
-- ^ Description of location
}
deriving
(
Show
,
Eq
)
-- | Construct locations, adding IDs like "locA", "locB".
makeLocs
::
[(
Text
,
Text
)]
->
[
Location
]
makeLocs
=
zipWith
mk
[
'A'
..
]
where
...
...
@@ -93,19 +93,29 @@ data AppSettings = AppSettings
,
appAnalytics
::
Maybe
Text
-- ^ Google Analytics code
,
appCredentials
::
Cal
.
Credentials
-- ^ Credentials needed for accessing the calendar
,
appDefaultTimeZone
::
TZLabelW
-- ^ Default time zone
,
appLocations
::
[
Location
]
,
appFreeCalendarId
::
Text
,
appBusyCalendarId
::
Text
-- ^ Available locations for appointments
,
appFreeCalendarId
::
Cal
.
CalendarId
-- ^ Calender specifying available time slots
,
appBusyCalendarId
::
Cal
.
CalendarId
-- ^ Calendar specifying busy times
,
appLookaheadWeeks
::
Int
-- ^ How far to look ahead when fetching calendar events
,
appApptLengthsMinutes
::
[
Int
]
-- ^ Valid lengths of appointments, in minutes
,
appCacheExpiry
::
NominalDiffTime
-- ^ Cached calendar data older than this will be refreshed
}
-- | Wrap a time zone label, so we can specify type classes.
newtype
TZLabelW
=
TZLabelW
{
unwrapTZLabel
::
TZLabel
}
deriving
(
Eq
,
Show
,
Read
)
}
deriving
(
Eq
,
Show
)
-- | Look up the time zone spec for given label.
tzByLabel
::
TZLabelW
->
TZ
tzByLabel
=
TZ
.
tzByLabel
.
unwrapTZLabel
...
...
@@ -163,8 +173,7 @@ widgetFileSettings = def
combineSettings
::
CombineSettings
combineSettings
=
def
-- The rest of this file contains settings which rarely need changing by a
-- user.
-- | Load a widget from files with or without dynamic reload.
widgetFile
::
String
->
Q
Exp
widgetFile
=
(
if
appReloadTemplates
compileTimeAppSettings
...
...
@@ -188,29 +197,26 @@ compileTimeAppSettings =
Error
e
->
error
e
Success
settings
->
settings
-- The following two functions can be used to combine multiple CSS or JS files
-- at compile time to decrease the number of http requests.
-- Sample usage (inside a Widget):
--
-- > $(combineStylesheets 'StaticR [style1_css, style2_css])
-- | Combine CSS files at compile time to decrease the number of HTTP
-- requests.
combineStylesheets
::
Name
->
[
Route
Static
]
->
Q
Exp
combineStylesheets
=
combineStylesheets'
(
appSkipCombining
compileTimeAppSettings
)
combineSettings
-- | Combine JS files at compile time to decrease the number of HTTP
-- requests.
combineScripts
::
Name
->
[
Route
Static
]
->
Q
Exp
combineScripts
=
combineScripts'
(
appSkipCombining
compileTimeAppSettings
)
combineSettings
-- | Environment variable used for Google client ID.
varGoogleClientId
::
IsString
s
=>
s
varGoogleClientId
=
"BOOKME_GOOGLE_ID"
-- | Environment variable used for Google client secret.
varGoogleSecret
::
IsString
s
=>
s
varGoogleSecret
=
"BOOKME_GOOGLE_SECRET"
-- | Environment variable used for Google refresh token.
varGoogleRefreshToken
::
IsString
s
=>
s
varGoogleRefreshToken
=
"BOOKME_GOOGLE_REFRESH"
oauthClientFromEnv
::
IO
OAuthClient
oauthClientFromEnv
=
OAuthClient
<$>
(
ClientId
.
pack
<$>
getEnv
varGoogleClientId
)
<*>
(
Secret
.
pack
<$>
getEnv
varGoogleSecret
)
src/Settings/Auth.hs
View file @
ed0bb11e
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module: Settings.Auth
Description:
TODO
Description:
Helper program to create Google refresh token
TODO
Given the client ID and secret, this program generates an oauth URL
and after approval, a refresh token.
-}
module
Settings.Auth
(
authorizeMain
)
where
import
qualified
Calendar
as
Cal
import
qualified
Calendar
as
Cal
import
Import
import
Network.Google
(
LogLevel
(
Error
),
newLogger
)
import
Network.Google
(
ClientId
(
..
),
LogLevel
(
Error
),
Secret
(
..
),
newLogger
)
import
Network.Google.AppsCalendar
(
calendarScope
)
import
Network.Google.Auth
(
Auth
(
..
),
Credentials
(
FromClient
),
OAuthCode
(
..
),
OAuthToken
(
..
),
OAuthClient
(
..
),
OAuthCode
(
..
),
OAuthToken
(
..
),
RefreshToken
(
..
),
exchange
,
formURL
)
import
Network.HTTP.Client.TLS
(
tlsManagerSettings
)
import
System.Environment
(
getEnv
)
oauthClientFromEnv
::
IO
OAuthClient
oauthClientFromEnv
=
OAuthClient
<$>
(
ClientId
.
pack
<$>
getEnv
varGoogleClientId
)
<*>
(
Secret
.
pack
<$>
getEnv
varGoogleSecret
)
authorizeMain
::
IO
()
authorizeMain
=
do
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment