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

Export list on Foundation

parent 2339d123
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-}
module Foundation where module Foundation
( App(..)
, Handler
, Widget
, Form
, Route(..)
, resourcesApp
, unsafeHandler
) where
import qualified Calendar as Cal import qualified Calendar as Cal
import qualified Control.Monad.Catch as MC import qualified Control.Monad.Catch as MC
...@@ -41,16 +48,6 @@ data App = App ...@@ -41,16 +48,6 @@ data App = App
-- 'appCacheExpiry'. -- '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 -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers -- http://www.yesodweb.com/book/routing-and-handlers
...@@ -85,10 +82,7 @@ addScriptL route cdn attrs = ...@@ -85,10 +82,7 @@ addScriptL route cdn attrs =
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod App instance Yesod App where
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
where
approot :: Approot App approot :: Approot App
approot = approot =
ApprootRequest $ \app req -> ApprootRequest $ \app req ->
...@@ -219,10 +213,3 @@ instance HasHttpManager App where ...@@ -219,10 +213,3 @@ instance HasHttpManager App where
unsafeHandler :: App -> Handler a -> IO a unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger 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
...@@ -17,8 +17,9 @@ module Settings ...@@ -17,8 +17,9 @@ module Settings
, TZLabelW , TZLabelW
, tzByLabel , tzByLabel
, Location(..) , Location(..)
, varGoogleClientId
, varGoogleSecret
, varGoogleRefreshToken , varGoogleRefreshToken
, oauthClientFromEnv
, compileTimeAppSettings , compileTimeAppSettings
, configSettingsYmlValue , configSettingsYmlValue
, widgetFile , widgetFile
...@@ -39,21 +40,20 @@ import Data.Time.Zones.All (TZLabel, fromTZName, toTZName) ...@@ -39,21 +40,20 @@ import Data.Time.Zones.All (TZLabel, fromTZName, toTZName)
import qualified Data.Time.Zones.All as TZ import qualified Data.Time.Zones.All as TZ
import Data.Yaml (decodeEither') import Data.Yaml (decodeEither')
import Language.Haskell.TH.Syntax (Exp, Name, Q) import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Google.Auth (ClientId (..), OAuthClient (..),
Secret (..))
import Network.Wai.Handler.Warp (HostPreference) import Network.Wai.Handler.Warp (HostPreference)
import System.Environment (getEnv)
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings, import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload, widgetFileNoReload,
widgetFileReload) widgetFileReload)
-- | Represent a location for an appointment
data Location = Location data Location = Location
{ locId :: Text { locId :: Text -- ^ Arbitrary identifier slug used as a path piece
, locSearch :: Text , locSearch :: Text -- ^ Search string, can be blank to allow all available slots
, locDescr :: Text , locDescr :: Text -- ^ Description of location
} deriving (Show, Eq) } deriving (Show, Eq)
-- | Construct locations, adding IDs like "locA", "locB".
makeLocs :: [(Text, Text)] -> [Location] makeLocs :: [(Text, Text)] -> [Location]
makeLocs = zipWith mk ['A' ..] makeLocs = zipWith mk ['A' ..]
where where
...@@ -93,19 +93,29 @@ data AppSettings = AppSettings ...@@ -93,19 +93,29 @@ data AppSettings = AppSettings
, appAnalytics :: Maybe Text , appAnalytics :: Maybe Text
-- ^ Google Analytics code -- ^ Google Analytics code
, appCredentials :: Cal.Credentials , appCredentials :: Cal.Credentials
-- ^ Credentials needed for accessing the calendar
, appDefaultTimeZone :: TZLabelW , appDefaultTimeZone :: TZLabelW
-- ^ Default time zone
, appLocations :: [Location] , appLocations :: [Location]
, appFreeCalendarId :: Text -- ^ Available locations for appointments
, appBusyCalendarId :: Text , appFreeCalendarId :: Cal.CalendarId
-- ^ Calender specifying available time slots
, appBusyCalendarId :: Cal.CalendarId
-- ^ Calendar specifying busy times
, appLookaheadWeeks :: Int , appLookaheadWeeks :: Int
-- ^ How far to look ahead when fetching calendar events
, appApptLengthsMinutes :: [Int] , appApptLengthsMinutes :: [Int]
-- ^ Valid lengths of appointments, in minutes
, appCacheExpiry :: NominalDiffTime , 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 newtype TZLabelW = TZLabelW
{ unwrapTZLabel :: TZLabel { unwrapTZLabel :: TZLabel
} deriving (Eq, Show, Read) } deriving (Eq, Show)
-- | Look up the time zone spec for given label.
tzByLabel :: TZLabelW -> TZ tzByLabel :: TZLabelW -> TZ
tzByLabel = TZ.tzByLabel . unwrapTZLabel tzByLabel = TZ.tzByLabel . unwrapTZLabel
...@@ -163,8 +173,7 @@ widgetFileSettings = def ...@@ -163,8 +173,7 @@ widgetFileSettings = def
combineSettings :: CombineSettings combineSettings :: CombineSettings
combineSettings = def combineSettings = def
-- The rest of this file contains settings which rarely need changing by a -- | Load a widget from files with or without dynamic reload.
-- user.
widgetFile :: String -> Q Exp widgetFile :: String -> Q Exp
widgetFile = widgetFile =
(if appReloadTemplates compileTimeAppSettings (if appReloadTemplates compileTimeAppSettings
...@@ -188,29 +197,26 @@ compileTimeAppSettings = ...@@ -188,29 +197,26 @@ compileTimeAppSettings =
Error e -> error e Error e -> error e
Success settings -> settings Success settings -> settings
-- The following two functions can be used to combine multiple CSS or JS files -- | Combine CSS files at compile time to decrease the number of HTTP
-- at compile time to decrease the number of http requests. -- requests.
-- Sample usage (inside a Widget):
--
-- > $(combineStylesheets 'StaticR [style1_css, style2_css])
combineStylesheets :: Name -> [Route Static] -> Q Exp combineStylesheets :: Name -> [Route Static] -> Q Exp
combineStylesheets = combineStylesheets =
combineStylesheets' (appSkipCombining compileTimeAppSettings) combineSettings combineStylesheets' (appSkipCombining compileTimeAppSettings) combineSettings
-- | Combine JS files at compile time to decrease the number of HTTP
-- requests.
combineScripts :: Name -> [Route Static] -> Q Exp combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts =
combineScripts' (appSkipCombining compileTimeAppSettings) combineSettings combineScripts' (appSkipCombining compileTimeAppSettings) combineSettings
-- | Environment variable used for Google client ID.
varGoogleClientId :: IsString s => s varGoogleClientId :: IsString s => s
varGoogleClientId = "BOOKME_GOOGLE_ID" varGoogleClientId = "BOOKME_GOOGLE_ID"
-- | Environment variable used for Google client secret.
varGoogleSecret :: IsString s => s varGoogleSecret :: IsString s => s
varGoogleSecret = "BOOKME_GOOGLE_SECRET" varGoogleSecret = "BOOKME_GOOGLE_SECRET"
-- | Environment variable used for Google refresh token.
varGoogleRefreshToken :: IsString s => s varGoogleRefreshToken :: IsString s => s
varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH" varGoogleRefreshToken = "BOOKME_GOOGLE_REFRESH"
oauthClientFromEnv :: IO OAuthClient
oauthClientFromEnv =
OAuthClient <$> (ClientId . pack <$> getEnv varGoogleClientId) <*>
(Secret . pack <$> getEnv varGoogleSecret)
{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-| {-|
Module: Settings.Auth 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 module Settings.Auth
( authorizeMain ( authorizeMain
) where ) where
import qualified Calendar as Cal import qualified Calendar as Cal
import Import import Import
import Network.Google (LogLevel (Error), newLogger) import Network.Google (ClientId (..), LogLevel (Error),
Secret (..), newLogger)
import Network.Google.AppsCalendar (calendarScope) import Network.Google.AppsCalendar (calendarScope)
import Network.Google.Auth (Auth (..), import Network.Google.Auth (Auth (..),
Credentials (FromClient), Credentials (FromClient),
OAuthCode (..), OAuthToken (..), OAuthClient (..), OAuthCode (..),
OAuthToken (..),
RefreshToken (..), exchange, RefreshToken (..), exchange,
formURL) formURL)
import Network.HTTP.Client.TLS (tlsManagerSettings) 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 :: IO ()
authorizeMain = do authorizeMain = do
......
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