Commit e47f05e2 authored by Christopher League's avatar Christopher League
Browse files

Settings for time zone, location, etc

parent eba3190b
......@@ -10,6 +10,17 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
# Uncomment to set an explicit approot
#approot: "_env:APPROOT:http://localhost:3000"
time-zone: _env:BOOKME_TIME_ZONE:America/New_York
locations:
- - "#office"
- At LIU Brooklyn (usually H700)
- - ""
- Online via Google Hangout or phone
free-calendar: _env:BOOKME_FREE_CAL:uhqg996jdq8gc8r8g1bee8clc8@group.calendar.google.com
busy-calendar: _env:BOOKME_BUSY_CAL:cleague@gmail.com
look-ahead-weeks: 4
# By default, `yesod devel` runs in development, and built executables use
# production settings (see below). To override this, use the following:
#
......
......@@ -35,6 +35,7 @@ dependencies:
- template-haskell
- text >=0.11 && <2.0
- time
- tz
- unordered-containers
- vector
- wai
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
-- * for DevelMain
, getApplicationRepl
, shutdownApp
, getApplicationRepl
, shutdownApp
-- * for GHCI
, handler
) where
import Control.Monad.Logger (liftLoc)
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Google.Auth (OAuthClient(..))
import System.Environment (getEnv)
import Network.Google.Auth.ApplicationDefault (fromJSONCredentials)
import Network.Wai (Middleware)
import qualified Data.Aeson as Js
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, setHost,
setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
toLogStr)
, handler
) where
import Control.Lens ((.~), (<&>))
import Control.Monad.Logger (liftLoc)
import Control.Monad.Logger (defaultLoc)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Import
import Language.Haskell.TH.Syntax (qLocation)
import qualified Network.Google as Google
import Network.Google.AppsCalendar (calendarScope)
import Network.Google.Auth (OAuthClient (..))
import qualified Network.Google.Auth.ApplicationDefault as Google
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings,
defaultSettings,
defaultShouldDisplayException,
getPort, runSettings,
setHost,
setOnException,
setPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..),
destination,
mkRequestLogger,
outputFormat)
import System.Environment (getEnv)
import System.Log.FastLogger (defaultBufSize,
newStdoutLoggerSet,
toLogStr)
import Handler.Comment
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
import Handler.Comment
import Handler.Common
import Handler.Home
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
......@@ -55,70 +67,101 @@ mkYesodDispatch "App" resourcesApp
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do
makeFoundation appSettings
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic appSettings then staticDevel else static)
(appStaticDir appSettings)
OAuthClient{..} <- oauthClientFromEnv
token <- getEnv varGoogleRefreshToken
appGoogleCreds <- either throwString return $ fromJSONCredentials
$ Js.encode $ object ["client_id" .= _clientId, "client_secret" .= _clientSecret,
"refresh_token" .= token]
= do
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic 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 <-
Google.newEnvWith appGoogleCreds googleLogger appHttpManager <&>
Google.envScopes .~
calendarScope
-- Return the foundation
return App {..}
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
logWare <- makeLogWare foundation
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
makeLogWare :: App -> IO Middleware
makeLogWare foundation =
mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
mkRequestLogger
def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
$ setOnException (\_req e ->
when (defaultShouldDisplayException e) $ messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
setPort (appPort $ appSettings foundation) $
setHost (appHost $ appSettings foundation) $
setOnException
(\_req e ->
when (defaultShouldDisplayException e) $
messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
......@@ -129,44 +172,39 @@ develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
appMain
-- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs
= do
settings <-
loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
useEnv
-- Generate the foundation from the settings
foundation <- makeFoundation settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app
runSettings (warpSettings foundation) app
--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1)
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1)
shutdownApp :: App -> IO ()
shutdownApp _ = return ()
---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------
-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Foundation where
import Import.NoFoundation as Pre
import Control.Monad.Logger (LogSource)
import Text.Hamlet (hamletFile)
import qualified Control.Monad.Catch as MC
import Text.Jasmine (minifym)
import Yesod.Core.Types (Logger)
import Yesod.Default.Util (addStaticContentExternal)
import qualified Yesod.Core.Unsafe as Unsafe
import Network.Google.Auth (Credentials)
import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding as TE
import Import.NoFoundation as Pre
import qualified Network.Google as Google
import qualified Network.Google.Auth as Google
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
import Yesod.Default.Util (addStaticContentExternal)
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appGoogleCreds :: Credentials CalendarScope
}
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appGoogleCreds :: Google.Credentials CalendarScope
, appGoogleEnv :: Google.Env CalendarScope
}
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
, menuItemAccessCallback :: Bool
}
{ menuItemLabel :: Text
, menuItemRoute :: Route App
, menuItemAccessCallback :: Bool
}
data MenuTypes
= NavbarLeft MenuItem
| NavbarRight MenuItem
= 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:
......@@ -66,22 +73,24 @@ instance MC.MonadCatch (HandlerFor App) where
-- 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 where
instance Yesod App
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
approot :: Approot App
approot = ApprootRequest $ \app req ->
case appRoot $ appSettings app of
Nothing -> getApprootText guessApproot app req
Just root -> root
where
approot :: Approot App
approot =
ApprootRequest $ \app req ->
case appRoot $ appSettings app of
Nothing -> getApprootText guessApproot app req
Just root -> root
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend _ =
Just <$>
defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
......@@ -89,118 +98,109 @@ instance Yesod App where
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
defaultLayout :: Widget -> Handler Html
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
mcurrentRoute <- getCurrentRoute
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
defaultLayout :: Widget -> Handler Html
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, parents) <- breadcrumbs
(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]
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
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
pc <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
isAuthorized
:: Route App -- ^ The route the user is visiting.
-> Bool -- ^ Whether or not this is a "write" request.
-> Handler AuthResult
pc <-
widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
isAuthorized ::
Route App -- ^ The route the user is visiting.
-> Bool -- ^ Whether or not this is a "write" request.
-> Handler AuthResult
-- Routes not requiring authenitcation.
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
isAuthorized _ _ = return Authorized
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent
:: Text -- ^ The file extension
-> Text -- ^ The MIME content type
-> LByteString -- ^ The contents of the file
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where
addStaticContent ::
Text -- ^ The file extension
-> Text -- ^ The MIME content type
-> LByteString -- ^ The contents of the file
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
where
genFileName lbs = "autogen-" ++ base64md5 lbs
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger :: App -> IO Logger
makeLogger = return . appLogger
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $
appShouldLogAll (appSettings app) ||
level == LevelWarn || level == LevelError
makeLogger :: App -> IO Logger
makeLogger = return . appLogger
-- Define breadcrumbs.
instance YesodBreadcrumbs App where
instance YesodBreadcrumbs App
-- Takes the route that the user is currently on, and returns a tuple
-- of the 'Text' that you want the label to display, and a previous
-- breadcrumb route.
breadcrumb
:: Route App -- ^ The route the user is visiting currently.
-> Handler (Text, Maybe (Route App))
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb _ = return ("home", Nothing)
where
breadcrumb ::
Route App -- ^ The route the user is visiting currently.
-> Handler (Text, Maybe (Route App))
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb _ = return ("home", Nothing)
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
renderMessage :: App -> [Lang] -> FormMessage -> Text
renderMessage _ _ = defaultFormMessage