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

Some more docs and dependency cleanup, hfmt

parent ed0bb11e
...@@ -27,73 +27,76 @@ ...@@ -27,73 +27,76 @@
-- --
-- There is more information about this approach, -- There is more information about this approach,
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where module DevelMain where
import Prelude import Application (getApplicationRepl, shutdownApp)
import Application (getApplicationRepl, shutdownApp) import Prelude
import Control.Exception (finally) import Control.Concurrent
import Control.Monad ((>=>)) import Control.Exception (finally)
import Control.Concurrent import Control.Monad ((>=>))
import Data.IORef import Data.IORef
import Foreign.Store import Foreign.Store
import Network.Wai.Handler.Warp import GHC.Word
import GHC.Word import Network.Wai.Handler.Warp
-- | Start or restart the server. -- | Start or restart the server.
-- newStore is from foreign-store. -- newStore is from foreign-store.
-- A Store holds onto some data across ghci reloads -- A Store holds onto some data across ghci reloads
update :: IO () update :: IO ()
update = do update = do
mtidStore <- lookupStore tidStoreNum mtidStore <- lookupStore tidStoreNum
case mtidStore of case mtidStore
-- no server running -- no server running
Nothing -> do of
done <- storeAction doneStore newEmptyMVar Nothing -> do
tid <- start done done <- storeAction doneStore newEmptyMVar
_ <- storeAction (Store tidStoreNum) (newIORef tid) tid <- start done
return () _ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running -- server is already running
Just tidStore -> restartAppInNewThread tidStore Just tidStore -> restartAppInNewThread tidStore
where where
doneStore :: Store (MVar ()) doneStore :: Store (MVar ())
doneStore = Store 0 doneStore = Store 0
-- shut the server down with killThread and wait for the done signal -- shut the server down with killThread and wait for the done signal
restartAppInNewThread :: Store (IORef ThreadId) -> IO () restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do restartAppInNewThread tidStore =
modifyStoredIORef tidStore $ \tid -> do
killThread tid killThread tid
withStore doneStore takeMVar withStore doneStore takeMVar
readStore doneStore >>= start readStore doneStore >>= start
-- | Start the server in a separate thread. -- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed. start ::
-> IO ThreadId MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do start done = do
(port, site, app) <- getApplicationRepl (port, site, app) <- getApplicationRepl
forkIO (finally (runSettings (setPort port defaultSettings) app) forkIO
(finally
(runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency -- Note that this implies concurrency
-- between shutdownApp and the next app that is starting. -- between shutdownApp and the next app that is starting.
-- Normally this should be fine -- Normally this should be fine
(putMVar done () >> shutdownApp site)) (putMVar done () >> shutdownApp site))
-- | kill the server -- | kill the server
shutdown :: IO () shutdown :: IO ()
shutdown = do shutdown = do
mtidStore <- lookupStore tidStoreNum mtidStore <- lookupStore tidStoreNum
case mtidStore of case mtidStore
-- no server running -- no server running
Nothing -> putStrLn "no Yesod app running" of
Just tidStore -> do Nothing -> putStrLn "no Yesod app running"
withStore tidStore $ readIORef >=> killThread Just tidStore -> do
putStrLn "Yesod app is shutdown" withStore tidStore $ readIORef >=> killThread
putStrLn "Yesod app is shutdown"
tidStoreNum :: Word32 tidStoreNum :: Word32
tidStoreNum = 1 tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do modifyStoredIORef store f =
withStore store $ \ref -> do
v <- readIORef ref v <- readIORef ref
f v >>= writeIORef ref f v >>= writeIORef ref
import Prelude (IO) import Prelude (IO)
import Settings.Auth (authorizeMain) import Settings.Auth (authorizeMain)
main :: IO () main :: IO ()
main = authorizeMain main = authorizeMain
import Prelude (IO) import Application (appMain)
import Application (appMain) import Prelude (IO)
main :: IO () main :: IO ()
main = appMain main = appMain
...@@ -4,7 +4,6 @@ ...@@ -4,7 +4,6 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application module Application
...@@ -20,30 +19,29 @@ module Application ...@@ -20,30 +19,29 @@ module Application
, handler , handler
) where ) where
import qualified Calendar as Cal import qualified Calendar as Cal
import Control.Monad.Logger (logInfoN, liftLoc) import Control.Monad.Logger (liftLoc, logInfoN)
import qualified FreshCache as FC import Data.Time.Clock (NominalDiffTime)
import qualified FreshCache as FC
import Import import Import
import Language.Haskell.TH.Syntax (qLocation) import Language.Haskell.TH.Syntax (qLocation)
import Data.Time.Clock (NominalDiffTime) import Network.HTTP.Client.TLS (getGlobalManager)
import Network.HTTP.Client.TLS (getGlobalManager) import Network.Wai (Middleware)
import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings,
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultSettings, defaultShouldDisplayException,
defaultShouldDisplayException, getPort, runSettings,
getPort, runSettings, setHost, setOnException,
setHost, setPort)
setOnException, import Network.Wai.Middleware.RequestLogger (Destination (Logger),
setPort) IPAddrSource (..),
import Network.Wai.Middleware.RequestLogger (Destination (Logger), OutputFormat (..),
IPAddrSource (..), destination,
OutputFormat (..), mkRequestLogger,
destination, outputFormat)
mkRequestLogger, import System.Log.FastLogger (defaultBufSize,
outputFormat) newStdoutLoggerSet,
import System.Log.FastLogger (defaultBufSize, toLogStr)
newStdoutLoggerSet,
toLogStr)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
...@@ -63,24 +61,28 @@ fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w ...@@ -63,24 +61,28 @@ fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App makeFoundation :: AppSettings -> IO App
makeFoundation appSettings@AppSettings{..} = do makeFoundation appSettings@AppSettings {..} = do
appHttpManager <- getGlobalManager appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <- appStatic <-
(if appMutableStatic then staticDevel else static) appStaticDir (if appMutableStatic
let then staticDevel
partialApp = App{..} else static)
where appStaticDir
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt" let partialApp = App {..}
appGetCalendar = error "partialApp loop: Accessing appGetCalendar" where
logFunc loc src lv = appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
whenM (shouldLogIO partialApp "" lv) . appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
messageLoggerSource partialApp appLogger loc src lv logFunc loc src lv =
whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv
appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
cache <- unsafeHandler partialApp $ FC.newCache $ do cache <-
logInfoN "Refreshing calendar cache" unsafeHandler partialApp $
Cal.listAvailMinusBusy appCalendarCxt FC.newCache $ do
appFreeCalendarId appBusyCalendarId $ fromWeeks appLookaheadWeeks logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
fromWeeks appLookaheadWeeks
let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
return App {..} return App {..}
......
...@@ -14,9 +14,9 @@ calendars and their events. It supports both Google calendars and a ...@@ -14,9 +14,9 @@ calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging. mock calendar for used for testing and debugging.
-} -}
module Calendar module Calendar
( Scope ( CalendarScope
, Credentials , CalendarCredentials
, Context , CalendarContext
, CalendarId , CalendarId
, SimpleEvent(..) , SimpleEvent(..)
, SimpleEventUTC , SimpleEventUTC
...@@ -47,25 +47,25 @@ import qualified Network.Google.Auth.ApplicationDefault as Google ...@@ -47,25 +47,25 @@ import qualified Network.Google.Auth.ApplicationDefault as Google
import System.Log.FastLogger (toLogStr) import System.Log.FastLogger (toLogStr)
-- | Google authorization scope representing calendar operations. -- | Google authorization scope representing calendar operations.
type Scope = '[ "https://www.googleapis.com/auth/calendar"] type CalendarScope = '[ "https://www.googleapis.com/auth/calendar"]
-- | Credentials needed for accessing the calendar. -- | Credentials needed for accessing the calendar.
data Credentials data CalendarCredentials
= MockCreds = MockCreds
| GoogleCreds (Google.Credentials Scope) | GoogleCreds (Google.Credentials CalendarScope)
-- | Doesn't reveal the credentials, but simply allows to distinguish -- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked. -- whether they are for Google or mocked.
instance Show Credentials where instance Show CalendarCredentials where
show MockCreds = "<mock>" show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>" show (GoogleCreds _) = "<google>"
-- | If the field @client_id@ is just the string @"mock"@, then we use -- | If the field @client_id@ is just the string @"mock"@, then we use
-- a mock calender. Otherwise, we attempt to use @client_id@, -- a mock calender. Otherwise, we attempt to use @client_id@,
-- @client_secret@, and @refresh_token@ as Google credentials. -- @client_secret@, and @refresh_token@ as Google credentials.
instance FromJSON Credentials where instance FromJSON CalendarCredentials where
parseJSON = parseJSON =
Js.withObject "Credentials" $ \o -> Js.withObject "CalendarCredentials" $ \o ->
o .: "client_id" >>= \c -> o .: "client_id" >>= \c ->
if c == asText "mock" if c == asText "mock"
then return MockCreds then return MockCreds
...@@ -74,9 +74,9 @@ instance FromJSON Credentials where ...@@ -74,9 +74,9 @@ instance FromJSON Credentials where
-- | This represents a ready-to-use environment for calendar -- | This represents a ready-to-use environment for calendar
-- operations. -- operations.
data Context data CalendarContext
= MockCxt Day = MockCxt Day
| GoogleCxt (Google.Env Scope) | GoogleCxt (Google.Env CalendarScope)
-- | Use the static credentials to create a dynamic context for -- | Use the static credentials to create a dynamic context for
-- calendar operations. The Google environment requires a logging -- calendar operations. The Google environment requires a logging
...@@ -85,8 +85,8 @@ data Context ...@@ -85,8 +85,8 @@ data Context
initialize :: initialize ::
(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Manager -> Manager
-> Credentials -> CalendarCredentials
-> IO Context -> IO CalendarContext
initialize appLog _ MockCreds = do initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar" appLog defaultLoc "" LevelWarn "Using mock calendar"
MockCxt . succ . utctDay <$> getCurrentTime MockCxt . succ . utctDay <$> getCurrentTime
...@@ -156,7 +156,7 @@ sampleEvent d (summary, f, hmm1, hmm2) = ...@@ -156,7 +156,7 @@ sampleEvent d (summary, f, hmm1, hmm2) =
-- | Fetch events from a single calendar. -- | Fetch events from a single calendar.
listUpcoming :: listUpcoming ::
MonadResource m MonadResource m
=> Context => CalendarContext
-> CalendarId -> CalendarId
-> NominalDiffTime -- ^How far to look ahead -> NominalDiffTime -- ^How far to look ahead
-> m [SimpleEventUTC] -> m [SimpleEventUTC]
...@@ -244,7 +244,7 @@ availMinusBusy (a:aa) (b:bb) ...@@ -244,7 +244,7 @@ availMinusBusy (a:aa) (b:bb)
-- between them. -- between them.
listAvailMinusBusy :: listAvailMinusBusy ::
(MonadResource m, MonadUnliftIO m) (MonadResource m, MonadUnliftIO m)
=> Context => CalendarContext
-> CalendarId -- ^Calendar with available times -> CalendarId -- ^Calendar with available times
-> CalendarId -- ^Calendar with busy times -> CalendarId -- ^Calendar with busy times
-> NominalDiffTime -- ^How far to look ahead -> NominalDiffTime -- ^How far to look ahead
......
...@@ -19,7 +19,6 @@ module Foundation ...@@ -19,7 +19,6 @@ module Foundation
, unsafeHandler , unsafeHandler
) where ) where
import qualified Calendar as Cal
import qualified Control.Monad.Catch as MC import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource) import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
...@@ -37,12 +36,12 @@ import Yesod.Default.Util (addStaticContentExternal) ...@@ -37,12 +36,12 @@ import Yesod.Default.Util (addStaticContentExternal)
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data App = App data App = App
{ appSettings :: AppSettings { appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving. , appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager , appHttpManager :: Manager
, appLogger :: Logger , appLogger :: Logger
, appCalendarCxt :: Cal.Context , appCalendarCxt :: CalendarContext
, appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [Cal.SimpleEventUTC] , appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [SimpleEventUTC]
-- ^ Fetch latest available times from the calendars. Return cached -- ^ Fetch latest available times from the calendars. Return cached
-- version if it's less than given age, which defaults to -- version if it's less than given age, which defaults to
-- 'appCacheExpiry'. -- 'appCacheExpiry'.
......
...@@ -4,9 +4,12 @@ ...@@ -4,9 +4,12 @@
{-| {-|
Module: FreshCache Module: FreshCache
Description: TODO Description: Cache the result of an expensive action
TODO This utility caches the result of an expensive action for a specified
amount of time. If the result is requested again within that time, the
existing one is used. If it is requested after the time is expired, we
automatically refresh it. Should be thread-safe.
-} -}
module FreshCache module FreshCache
( Cache ( Cache
...@@ -19,15 +22,21 @@ import ClassyPrelude.Yesod ...@@ -19,15 +22,21 @@ import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Data.Time.Clock (NominalDiffTime, diffUTCTime) import Data.Time.Clock (NominalDiffTime, diffUTCTime)
-- | The cache structure. Saves the value 'a' which can be refreshed or
-- accessed within the monad 'm'.
newtype Cache m a = newtype Cache m a =
Cache (MVar (a, UTCTime, m a)) Cache (MVar (a, UTCTime, m a))
-- | Create a new cache by running the action and saving it with a
-- timestamp.
newCache :: MonadIO m => m a -> m (Cache m a) newCache :: MonadIO m => m a -> m (Cache m a)
newCache refresh = do newCache refresh = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
result <- refresh result <- refresh
Cache <$> newMVar (result, now, refresh) Cache <$> newMVar (result, now, refresh)
-- | Retrieve the value from the cache if it's within the specified
-- maximum age. Otherwise, refresh it and return the new value.
readCache :: MonadUnliftIO m => Cache m a -> NominalDiffTime -> m a readCache :: MonadUnliftIO m => Cache m a -> NominalDiffTime -> m a
readCache (Cache mvar) maxAge = readCache (Cache mvar) maxAge =
modifyMVar mvar $ \val@(result, prev, refresh) -> do modifyMVar mvar $ \val@(result, prev, refresh) -> do
...@@ -38,6 +47,7 @@ readCache (Cache mvar) maxAge = ...@@ -38,6 +47,7 @@ readCache (Cache mvar) maxAge =
newResult <- refresh newResult <- refresh
return ((newResult, now, refresh), newResult) return ((newResult, now, refresh), newResult)
-- | A little concurrent test program using the cache.
cacheDemo :: IO () cacheDemo :: IO ()
cacheDemo = do cacheDemo = do
let w sec = threadDelay (sec * 1000 * 1000) let w sec = threadDelay (sec * 1000 * 1000)
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions. -- | Common handler functions.
module Handler.Common where module Handler.Common where
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import Import import Import
-- These handlers embed files in the executable at compile time to avoid a -- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency. -- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent getFaviconR :: Handler TypedContent
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month getFaviconR = do
return $ TypedContent "image/x-icon" cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
$ toContent $(embedFile "config/favicon.ico") return $
TypedContent "image/x-icon" $ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain getRobotsR =
$ toContent $(embedFile "config/robots.txt") return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")
...@@ -9,37 +9,40 @@ ...@@ -9,37 +9,40 @@
module Handler.Home where module Handler.Home where
import qualified Calendar as Cal import qualified Calendar as Cal
import qualified Data.Time.Format as TF import qualified Data.Time.Format as TF
import Import import Import
import Text.Julius (RawJS (..)) import Text.Julius (RawJS (..))
apptLengthOptions :: Handler (OptionList Int) apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do apptLengthOptions = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod lengths <- appApptLengthsMinutes . appSettings <$> getYesod
let let toOption m =
toOption m = Option
Option { optionDisplay = tshow m <> " minute"
{ optionDisplay = tshow m <> " minute" , optionInternalValue = m
, optionInternalValue = m , optionExternalValue = tshow m
, optionExternalValue = tshow m }
okLength m =
if m `elem` lengths
then Just m
else Nothing
return $
OptionList
{ olOptions = map toOption lengths
, olReadExternal = fromPathPiece >=> okLength
} }
okLength m =
if m `elem` lengths then Just m else Nothing
return $ OptionList
{ olOptions = map toOption lengths
, olReadExternal = fromPathPiece >=> okLength
}
locationField :: Field Handler Location locationField :: Field Handler Location
locationField = Field{..} locationField = Field {..}
where where
fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location" fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location"
fieldParse (txt:_) _ = do fieldParse (txt:_) _ = do
locs <- appLocations . appSettings <$> getYesod locs <- appLocations . appSettings <$> getYesod
return $ case find ((== txt) . locId) locs of return $
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt case find ((== txt) . locId) locs of
Just loc -> Right $ Just loc Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldView i _ attrs val _ = do fieldView i _ attrs val _ = do
locs <- appLocations . appSettings <$> getYesod locs <- appLocations . appSettings <$> getYesod
[whamlet| [whamlet|
...@@ -54,8 +57,9 @@ locationField = Field{..} ...@@ -54,8 +57,9 @@ locationField = Field{..}
|] |]
fieldEnctype = UrlEncoded fieldEnctype = UrlEncoded
data TimeFmt
data TimeFmt = Time12h | Time24h = Time12h
| Time24h
deriving (Eq, Show, Enum, Bounded) deriving (Eq, Show, Enum, Bounded)
instance PathPiece TimeFmt where instance PathPiece TimeFmt where
...@@ -63,19 +67,21 @@ instance PathPiece TimeFmt where ...@@ -63,19 +67,21 @@ instance PathPiece TimeFmt where
toPathPiece Time24h = "24h" toPathPiece Time24h = "24h"
fromPathPiece "12h" = Just Time12h fromPathPiece "12h" = Just Time12h
fromPathPiece "24h" = Just Time24h fromPathPiece "24h" = Just Time24h
fromPathPiece _ = Nothing fromPathPiece _ = Nothing
instance Default TimeFmt where instance Default TimeFmt where
def = Time12h def = Time12h
timeFmtOptions :: Handler (OptionList TimeFmt) timeFmtOptions :: Handler (OptionList TimeFmt)
timeFmtOptions = return $ OptionList timeFmtOptions =
{ olReadExternal = fromPathPiece return $
, olOptions = OptionList
[ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h) { olReadExternal = fromPathPiece