Skip to content

GitLab

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

Export list on Foundation

parent 2339d123
Hide whitespace changes
Inline Side-by-side
Showing with 64 additions and 65 deletions
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
......
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