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

Some more docs and dependency cleanup, hfmt

parent ed0bb11e
......@@ -27,19 +27,18 @@
--
-- There is more information about this approach,
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Prelude
import Application (getApplicationRepl, shutdownApp)
import Prelude
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad ((>=>))
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
import GHC.Word
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- newStore is from foreign-store.
......@@ -47,8 +46,9 @@ import GHC.Word
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
case mtidStore
-- no server running
of
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
......@@ -59,21 +59,22 @@ update = do
where
doneStore :: Store (MVar ())
doneStore = Store 0
-- shut the server down with killThread and wait for the done signal
restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
restartAppInNewThread tidStore =
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar
readStore doneStore >>= start
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
start ::
MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port, site, app) <- getApplicationRepl
forkIO (finally (runSettings (setPort port defaultSettings) app)
forkIO
(finally
(runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
......@@ -83,8 +84,9 @@ update = do
shutdown :: IO ()
shutdown = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
case mtidStore
-- no server running
of
Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do
withStore tidStore $ readIORef >=> killThread
......@@ -94,6 +96,7 @@ tidStoreNum :: Word32
tidStoreNum = 1
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
f v >>= writeIORef ref
import Prelude (IO)
import Application (appMain)
import Prelude (IO)
main :: IO ()
main = appMain
......@@ -4,7 +4,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
......@@ -21,19 +20,18 @@ module Application
) where
import qualified Calendar as Cal
import Control.Monad.Logger (logInfoN, liftLoc)
import Control.Monad.Logger (liftLoc, logInfoN)
import Data.Time.Clock (NominalDiffTime)
import qualified FreshCache as FC
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Data.Time.Clock (NominalDiffTime)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings,
defaultSettings,
defaultShouldDisplayException,
getPort, runSettings,
setHost,
setOnException,
setHost, setOnException,
setPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
......@@ -63,13 +61,15 @@ fromWeeks w = 24 * 7 * 60 * 60 * fromIntegral w
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings@AppSettings{..} = do
makeFoundation appSettings@AppSettings {..} = do
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic then staticDevel else static) appStaticDir
let
partialApp = App{..}
(if appMutableStatic
then staticDevel
else static)
appStaticDir
let partialApp = App {..}
where
appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
......@@ -77,10 +77,12 @@ makeFoundation appSettings@AppSettings{..} = do
whenM (shouldLogIO partialApp "" lv) .
messageLoggerSource partialApp appLogger loc src lv
appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
cache <- unsafeHandler partialApp $ FC.newCache $ do
cache <-
unsafeHandler partialApp $
FC.newCache $ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt
appFreeCalendarId appBusyCalendarId $ fromWeeks appLookaheadWeeks
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
fromWeeks appLookaheadWeeks
let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
return App {..}
......
......@@ -14,9 +14,9 @@ calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging.
-}
module Calendar
( Scope
, Credentials
, Context
( CalendarScope
, CalendarCredentials
, CalendarContext
, CalendarId
, SimpleEvent(..)
, SimpleEventUTC
......@@ -47,25 +47,25 @@ import qualified Network.Google.Auth.ApplicationDefault as Google
import System.Log.FastLogger (toLogStr)
-- | 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.
data Credentials
data CalendarCredentials
= MockCreds
| GoogleCreds (Google.Credentials Scope)
| GoogleCreds (Google.Credentials CalendarScope)
-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
instance Show Credentials where
instance Show CalendarCredentials where
show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>"
-- | If the field @client_id@ is just the string @"mock"@, then we use
-- a mock calender. Otherwise, we attempt to use @client_id@,
-- @client_secret@, and @refresh_token@ as Google credentials.
instance FromJSON Credentials where
instance FromJSON CalendarCredentials where
parseJSON =
Js.withObject "Credentials" $ \o ->
Js.withObject "CalendarCredentials" $ \o ->
o .: "client_id" >>= \c ->
if c == asText "mock"
then return MockCreds
......@@ -74,9 +74,9 @@ instance FromJSON Credentials where
-- | This represents a ready-to-use environment for calendar
-- operations.
data Context
data CalendarContext
= MockCxt Day
| GoogleCxt (Google.Env Scope)
| GoogleCxt (Google.Env CalendarScope)
-- | Use the static credentials to create a dynamic context for
-- calendar operations. The Google environment requires a logging
......@@ -85,8 +85,8 @@ data Context
initialize ::
(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Manager
-> Credentials
-> IO Context
-> CalendarCredentials
-> IO CalendarContext
initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar"
MockCxt . succ . utctDay <$> getCurrentTime
......@@ -156,7 +156,7 @@ sampleEvent d (summary, f, hmm1, hmm2) =
-- | Fetch events from a single calendar.
listUpcoming ::
MonadResource m
=> Context
=> CalendarContext
-> CalendarId
-> NominalDiffTime -- ^How far to look ahead
-> m [SimpleEventUTC]
......@@ -244,7 +244,7 @@ availMinusBusy (a:aa) (b:bb)
-- between them.
listAvailMinusBusy ::
(MonadResource m, MonadUnliftIO m)
=> Context
=> CalendarContext
-> CalendarId -- ^Calendar with available times
-> CalendarId -- ^Calendar with busy times
-> NominalDiffTime -- ^How far to look ahead
......
......@@ -19,7 +19,6 @@ module Foundation
, unsafeHandler
) where
import qualified Calendar as Cal
import qualified Control.Monad.Catch as MC
import Control.Monad.Logger (LogSource)
import qualified Data.CaseInsensitive as CI
......@@ -41,8 +40,8 @@ data App = App
, appStatic :: Static -- ^ Settings for static file serving.
, appHttpManager :: Manager
, appLogger :: Logger
, appCalendarCxt :: Cal.Context
, appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [Cal.SimpleEventUTC]
, appCalendarCxt :: CalendarContext
, appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [SimpleEventUTC]
-- ^ Fetch latest available times from the calendars. Return cached
-- version if it's less than given age, which defaults to
-- 'appCacheExpiry'.
......
......@@ -4,9 +4,12 @@
{-|
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
( Cache
......@@ -19,15 +22,21 @@ import ClassyPrelude.Yesod
import Control.Concurrent (threadDelay)
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 =
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 refresh = do
now <- liftIO getCurrentTime
result <- 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 (Cache mvar) maxAge =
modifyMVar mvar $ \val@(result, prev, refresh) -> do
......@@ -38,6 +47,7 @@ readCache (Cache mvar) maxAge =
newResult <- refresh
return ((newResult, now, refresh), newResult)
-- | A little concurrent test program using the cache.
cacheDemo :: IO ()
cacheDemo = do
let w sec = threadDelay (sec * 1000 * 1000)
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions.
module Handler.Common where
......@@ -11,12 +12,12 @@ import Import
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $ TypedContent "image/x-icon"
$ toContent $(embedFile "config/favicon.ico")
getFaviconR = do
cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $
TypedContent "image/x-icon" $ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "config/robots.txt")
getRobotsR =
return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")
......@@ -17,27 +17,30 @@ import Text.Julius (RawJS (..))
apptLengthOptions :: Handler (OptionList Int)
apptLengthOptions = do
lengths <- appApptLengthsMinutes . appSettings <$> getYesod
let
toOption m =
let toOption m =
Option
{ optionDisplay = tshow m <> " minute"
, optionInternalValue = m
, optionExternalValue = tshow m
}
okLength m =
if m `elem` lengths then Just m else Nothing
return $ OptionList
if m `elem` lengths
then Just m
else Nothing
return $
OptionList
{ olOptions = map toOption lengths
, olReadExternal = fromPathPiece >=> okLength
}
locationField :: Field Handler Location
locationField = Field{..}
locationField = Field {..}
where
fieldParse [] _ = return $ Left $ SomeMessage $ MsgInputNotFound "location"
fieldParse (txt:_) _ = do
locs <- appLocations . appSettings <$> getYesod
return $ case find ((== txt) . locId) locs of
return $
case find ((== txt) . locId) locs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
Just loc -> Right $ Just loc
fieldView i _ attrs val _ = do
......@@ -54,8 +57,9 @@ locationField = Field{..}
|]
fieldEnctype = UrlEncoded
data TimeFmt = Time12h | Time24h
data TimeFmt
= Time12h
| Time24h
deriving (Eq, Show, Enum, Bounded)
instance PathPiece TimeFmt where
......@@ -69,7 +73,9 @@ instance Default TimeFmt where
def = Time12h
timeFmtOptions :: Handler (OptionList TimeFmt)
timeFmtOptions = return $ OptionList
timeFmtOptions =
return $
OptionList
{ olReadExternal = fromPathPiece
, olOptions =
[ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h)
......@@ -83,19 +89,24 @@ data QueryForm = QueryForm
, queryTzLabel :: TZLabelW
, queryLocation :: Location
, querySlot :: Maybe Text -- TBD
} deriving Show
} deriving (Show)
queryForm :: Html -> MForm Handler (FormResult QueryForm, Widget)
queryForm extra = do
AppSettings{..} <- appSettings <$> getYesod
AppSettings {..} <- appSettings <$> getYesod
qc <- newIdent
let qs n = "" {fsName = Just n, fsId = Just n, fsAttrs = [("class", qc)]}
(lenRes, lenView) <- mreq (selectField apptLengthOptions) (qs "len") (headMay appApptLengthsMinutes)
(lenRes, lenView) <-
mreq
(selectField apptLengthOptions)
(qs "len")
(headMay appApptLengthsMinutes)
(fmtRes, fmtView) <- mreq (selectField timeFmtOptions) (qs "fmt") (Just def)
(locRes, locView) <- mreq locationField (qs "loc") (headMay appLocations)
(slotRes, _) <- mopt textField (qs "slot") Nothing
let
q = QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*> slotRes
let q =
QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*>
slotRes
widget = do
toWidget
[julius|
......@@ -130,14 +141,14 @@ queryForm extra = do
return (q, widget)
getHomeR :: Handler Html
getHomeR = do
getHomeR
-- Start (but don't wait for) refresh of calendar
App{..} <- getYesod
= do
App {..} <- getYesod
void $ async $ appGetCalendar Nothing
(widget, enctype) <- generateFormPost queryForm
(idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
defaultLayout
$(widgetFile "step1")
defaultLayout $(widgetFile "step1")
getAvailR :: Handler Html
getAvailR = do
......@@ -146,18 +157,19 @@ getAvailR = do
FormMissing -> invalidArgs ["missing"]
FormFailure errs -> invalidArgs errs
FormSuccess q -> do
App{appSettings=AppSettings{..}, ..} <- getYesod
App {appSettings = AppSettings {..}, ..} <- getYesod
let tz = tzByLabel $ queryTzLabel q
evs1 <- appGetCalendar Nothing
let evs2 = Cal.partitionSlots (queryApptLength q) evs1
let evs' = Cal.groupByDay $ map (Cal.applyTz tz) evs2
fmt = if queryTimeFmt q == Time12h
fmt =
if queryTimeFmt q == Time12h
then "%l:%M %p"
else "%H:%M"
showDate = TF.formatTime TF.defaultTimeLocale "%A %e %B" . Cal.seStart
showTime e =
TF.formatTime TF.defaultTimeLocale fmt (Cal.seStart e) <>
": " <> unpack (Cal.seSummary e)
TF.formatTime TF.defaultTimeLocale fmt (Cal.seStart e) <> ": " <>
unpack (Cal.seSummary e)
withUrlRenderer
[hamlet|
$if null evs'
......
{-# LANGUAGE CPP #-}
module Import.NoFoundation
( module Import
) where
import Calendar as Import (CalendarContext,
SimpleEventUTC)
import ClassyPrelude.Yesod as Import
import Settings as Import
import Settings.StaticFiles as Import
......
......@@ -27,7 +27,7 @@ module Settings
, combineScripts
) where
import qualified Calendar as Cal
import Calendar (CalendarCredentials, CalendarId)
import ClassyPrelude.Yesod
import qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject,
......@@ -92,15 +92,15 @@ data AppSettings = AppSettings
-- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appCredentials :: Cal.Credentials
, appCredentials :: CalendarCredentials
-- ^ Credentials needed for accessing the calendar
, appDefaultTimeZone :: TZLabelW
-- ^ Default time zone
, appLocations :: [Location]
-- ^ Available locations for appointments
, appFreeCalendarId :: Cal.CalendarId
, appFreeCalendarId :: CalendarId
-- ^ Calender specifying available time slots
, appBusyCalendarId :: Cal.CalendarId
, appBusyCalendarId :: CalendarId
-- ^ Calendar specifying busy times
, appLookaheadWeeks :: Int
-- ^ How far to look ahead when fetching calendar events
......
......@@ -12,8 +12,8 @@ module Settings.Auth
( authorizeMain
) where
import qualified Calendar as Cal
import Import
import Calendar (CalendarScope)
import ClassyPrelude.Yesod
import Network.Google (ClientId (..), LogLevel (Error),
Secret (..), newLogger)
import Network.Google.AppsCalendar (calendarScope)
......@@ -24,6 +24,7 @@ import Network.Google.Auth (Auth (..),
RefreshToken (..), exchange,
formURL)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Settings
import System.Environment (getEnv)
oauthClientFromEnv :: IO OAuthClient
......@@ -42,7 +43,7 @@ authorizeMain = do
formURL oac calendarScope <>
"\n\nThen run again with code as first argument.\n"
Just code -> do
let creds = FromClient oac (OAuthCode code) :: Credentials Cal.Scope
let creds = FromClient oac (OAuthCode code) :: Credentials CalendarScope
mgr <- newManagerSettings tlsManagerSettings
lgr <- newLogger Error stdout
auth <- exchange creds lgr mgr
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Settings.StaticFiles where
import Settings (appStaticDir, compileTimeAppSettings)
......
module Handler.CommonSpec (spec) where
module Handler.CommonSpec
( spec
) where
import TestImport
spec :: Spec
spec = withApp $ do
spec =
withApp $ do
describe "robots.txt" $ do
it "gives a 200" $ do
get RobotsR
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Handler.HomeSpec (spec) where
module Handler.HomeSpec
( spec
) where
import TestImport
spec :: Spec
spec = withApp $ do
spec =
withApp $ do
describe "Homepage" $ do
it "loads the index and checks it looks right" $ do
get HomeR
statusIs 200
htmlAnyContain "h1" "a modern framework for blazing fast websites"
request $ do
setMethod "POST"
setUrl HomeR
addToken
fileByLabelExact "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
byLabelExact "What's on the file?" "Some Content"
-- more debugging printBody
htmlAllContain ".upload-response" "text/plain"
htmlAllContain ".upload-response" "Some Content"
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module TestImport
( module TestImport
, module X
......@@ -10,19 +11,20 @@ import Application (makeFoundation, makeLogWare)
import ClassyPrelude as X hiding (Handler)
import Foundation as X
import Test.Hspec as X
import Yesod.Default.Config2 (useEnv, loadYamlSettings)
import Yesod.Test as X
import Yesod.Core.Unsafe (fakeHandlerGetLogger)
import Yesod.Default.Config2 (loadYamlSettings, useEnv)
import Yesod.Test as X
runHandler :: Handler a -> YesodExample App a
runHandler handler = do
app <- getTestYesod
fakeHandlerGetLogger appLogger app handler
withApp :: SpecWith (TestApp App) -> Spec
withApp = before $ do
settings <- loadYamlSettings
withApp =
before $ do
settings <-
loadYamlSettings
["config/test-settings.yml", "config/settings.yml"]
[]
useEnv
......
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