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

Reformat w/newer ormolu; leaner nix closure

parent bf8a7532
Pipeline #931 passed with stage
in 1 minute and 48 seconds
......@@ -30,8 +30,6 @@
module DevelMain where
import Application (getApplicationRepl, shutdownApp)
import Prelude
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad ((>=>))
......@@ -39,6 +37,7 @@ import Data.IORef
import Foreign.Store
import GHC.Word
import Network.Wai.Handler.Warp
import Prelude
-- | Start or restart the server.
-- newStore is from foreign-store.
......@@ -46,9 +45,9 @@ import Network.Wai.Handler.Warp
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore
case mtidStore of
-- no server running
of
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
......@@ -66,27 +65,28 @@ update = 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.
-> IO ThreadId
-- | Written to when the thread is killed.
MVar () ->
IO ThreadId
start done = do
(port, site, app) <- getApplicationRepl
forkIO
(finally
( 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
(putMVar done () >> shutdownApp site))
(putMVar done () >> shutdownApp site)
)
-- | kill the server
shutdown :: IO ()
shutdown = do
mtidStore <- lookupStore tidStoreNum
case mtidStore
case mtidStore of
-- no server running
of
Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do
withStore tidStore $ readIORef >=> killThread
......
import Prelude (IO)
import Settings.Auth (authorizeMain)
import Prelude (IO)
main :: IO ()
main = authorizeMain
{-# LANGUAGE PackageImports #-}
import "bookme" Application (develMain)
import Prelude (IO)
......
......@@ -12,9 +12,18 @@ let
&& ! (lib.elem (baseNameOf name) ignore)
&& ! (lib.hasPrefix ".ghc.environment" (baseNameOf name))
&& ! (lib.hasPrefix "autogen-" (baseNameOf name));
hp = haskellPackages.override {
overrides = self: super: {
mkDerivation = args: super.mkDerivation (args // {
doHaddock = false;
enableLibraryProfiling = false;
});
};
};
in
haskell.lib.overrideCabal
(haskellPackages.callPackage ./bookme.nix { })
(hp.callPackage ./bookme.nix { })
(drv: {
doCheck = false;
doHaddock = false;
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
......@@ -12,11 +12,13 @@ module Application
develMain,
makeFoundation,
makeLogWare,
-- * for DevelMain
getApplicationRepl,
shutdownApp,
-- * for GHCI
handler
handler,
)
where
......@@ -36,7 +38,7 @@ import Network.Wai.Handler.Warp
runSettings,
setHost,
setOnException,
setPort
setPort,
)
import Network.Wai.Middleware.RequestLogger
( Destination (Logger),
......@@ -44,12 +46,12 @@ import Network.Wai.Middleware.RequestLogger
OutputFormat (..),
destination,
mkRequestLogger,
outputFormat
outputFormat,
)
import System.Log.FastLogger
( defaultBufSize,
newStdoutLoggerSet,
toLogStr
toLogStr,
)
-- This line actually creates our YesodDispatch instance. It is the second half
......@@ -84,8 +86,8 @@ makeFoundation appSettings@AppSettings {..} = do
$ FC.newCache appCacheExpiry
$ do
logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId
$ fromWeeks appLookaheadWeeks
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
fromWeeks appLookaheadWeeks
return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
......@@ -120,8 +122,8 @@ warpSettings foundation =
$ setHost (appHost $ appSettings foundation)
$ setOnException
( \_req e ->
when (defaultShouldDisplayException e)
$ messageLoggerSource
when (defaultShouldDisplayException e) $
messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
......@@ -182,6 +184,7 @@ 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 LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module: BookingForm
Description: TODO
TODO
-}
-- |
-- Module: BookingForm
-- Description: TODO
--
-- TODO
module BookingForm
( Booking (..),
bookingMForm,
......@@ -19,7 +18,7 @@ module BookingForm
fromSession,
b3Class,
inputSize,
labelSize
labelSize,
)
where
......@@ -101,7 +100,6 @@ data RecaptchaResponse
deriving (Show)
instance Js.FromJSON RecaptchaResponse where
parseJSON =
Js.withObject "RecaptchaResponse" $ \o -> do
rrSuccess <- o .: "success"
......@@ -170,8 +168,8 @@ b3Class g =
B3.ColMd n -> "col-md-" <> tshow n
B3.ColLg n -> "col-lg-" <> tshow n
bookingMForm
:: Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm ::
Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm = B3.renderBootstrap3 horiz . bookingAForm
where
horiz =
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module: Calendar
Description: Query and manipulate calendars and events.
This module contains facilities for querying and manipulating
calendars and their events. It supports both Google calendars and a
mock calendar for used for testing and debugging.
-}
-- |
-- Module: Calendar
-- Description: Query and manipulate calendars and events.
--
-- This module contains facilities for querying and manipulating
-- calendars and their events. It supports both Google calendars and a
-- mock calendar for used for testing and debugging.
module Calendar
( CalendarScope,
CalendarCredentials,
......@@ -29,7 +28,7 @@ module Calendar
partitionSlots,
summaryMatches,
isWithin,
addEvent
addEvent,
)
where
......@@ -39,7 +38,7 @@ import Control.Monad.Logger
( Loc,
LogSource,
LogStr,
defaultLoc
defaultLoc,
)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
......@@ -49,7 +48,7 @@ import qualified Data.SortedList as SL
import Data.Time.Clock
( DiffTime,
NominalDiffTime,
addUTCTime
addUTCTime,
)
import Data.Time.LocalTime (LocalTime (..))
import Data.Time.Zones (TZ, utcToLocalTimeTZ)
......@@ -70,7 +69,6 @@ data CalendarCredentials
-- | Doesn't reveal the credentials, but simply allows to distinguish
-- whether they are for Google or mocked.
instance Show CalendarCredentials where
show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>"
......@@ -78,7 +76,6 @@ instance Show CalendarCredentials where
-- a mock calender. Otherwise, we attempt to use @client_id@,
-- @client_secret@, and @refresh_token@ as Google credentials.
instance FromJSON CalendarCredentials where
parseJSON =
Js.withObject "CalendarCredentials" $ \o ->
o .: "client_id" >>= \c ->
......@@ -105,17 +102,17 @@ mockFreeId = "mock-free"
-- calendar operations. The Google environment requires a logging
-- function and an HTTP manager. If using a mock calendar, a warning is
-- printed using the logging function.
initialize
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> Manager
-> CalendarCredentials
-> IO CalendarContext
initialize ::
(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->
Manager ->
CalendarCredentials ->
IO CalendarContext
initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar"
day <- succ . utctDay <$> getCurrentTime
let free =
SL.toSortedList
$ map
SL.toSortedList $
map
(sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155),
("free1b #office", fwd 0, 1300, 1450),
......@@ -126,8 +123,8 @@ initialize appLog _ MockCreds = do
("free3b #home", fwd 2, 1500, 1930)
]
busy =
SL.toSortedList
$ map
SL.toSortedList $
map
(sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300),
("busy1b", fwd 0, 1330, 1430),
......@@ -169,7 +166,6 @@ data SimpleEvent t
deriving (Eq, Show)
instance Ord t => Ord (SimpleEvent t) where
compare x y = compare (seStart x) (seStart y)
type SimpleEventUTC = SimpleEvent UTCTime
......@@ -263,12 +259,13 @@ sampleEvent d (summary, f, hmm1, hmm2) =
}
-- | Fetch events from a single calendar.
listUpcoming
:: MonadResource m
=> CalendarContext
-> CalendarId
-> NominalDiffTime -- ^How far to look ahead
-> m (SL.SortedList SimpleEventUTC)
listUpcoming ::
MonadResource m =>
CalendarContext ->
CalendarId ->
-- | How far to look ahead
NominalDiffTime ->
m (SL.SortedList SimpleEventUTC)
listUpcoming (MockCxt v) cid _ =
fromMaybe mempty . Map.lookup cid <$> readMVar v
listUpcoming (GoogleCxt env) cid lookahead = do
......@@ -291,6 +288,7 @@ listUpcoming (GoogleCxt env) cid lookahead = do
-- sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
-- sayEvent prefix SimpleEvent {..} =
-- say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary
-- | Convert an event into a local time zone.
applyTz :: TZ -> SimpleEventUTC -> SimpleEventLocal
applyTz tz ev =
......@@ -305,11 +303,14 @@ groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList
-- | Construct a stream of events that represent available times with
-- chunks of busy times removed. Requires that the event streams are
-- already ordered.
availMinusBusy
:: Ord t
=> SL.SortedList (SimpleEvent t) -- ^Available times
-> SL.SortedList (SimpleEvent t) -- ^Busy times
-> SL.SortedList (SimpleEvent t) -- ^Remaining available times
availMinusBusy ::
Ord t =>
-- | Available times
SL.SortedList (SimpleEvent t) ->
-- | Busy times
SL.SortedList (SimpleEvent t) ->
-- | Remaining available times
SL.SortedList (SimpleEvent t)
availMinusBusy aaa bbb =
case (SL.uncons aaa, SL.uncons bbb) of
(Nothing, _) -> mempty -- No available times
......@@ -331,19 +332,22 @@ availMinusBusy aaa bbb =
let a' = a {seStart = seEnd b}
in availMinusBusy (SL.insert a' aa) bb
-- B overlaps end of A, so keep truncated A and consider next A
| otherwise -> {-seStart a <= seStart b && seEnd a <= seEnd b-}
| otherwise {-seStart a <= seStart b && seEnd a <= seEnd b-} ->
let a' = a {seEnd = seStart b}
in SL.insert a' $ availMinusBusy aa bbb
-- | Simultaneously fetch two calendars and return the difference
-- between them.
listAvailMinusBusy
:: (MonadResource m, MonadUnliftIO m)
=> CalendarContext
-> CalendarId -- ^Calendar with available times
-> CalendarId -- ^Calendar with busy times
-> NominalDiffTime -- ^How far to look ahead
-> m (SL.SortedList SimpleEventUTC)
listAvailMinusBusy ::
(MonadResource m, MonadUnliftIO m) =>
CalendarContext ->
-- | Calendar with available times
CalendarId ->
-- | Calendar with busy times
CalendarId ->
-- | How far to look ahead
NominalDiffTime ->
m (SL.SortedList SimpleEventUTC)
listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
availT <- async $ listUpcoming cxt cidAvail lookahead
busyT <- async $ listUpcoming cxt cidBusy (lookahead + 86400)
......@@ -353,11 +357,13 @@ listAvailMinusBusy cxt cidAvail cidBusy lookahead = do
-- | Take a stream of available times and split them into slots exactly
-- N minutes long.
partitionSlots
:: Maybe Int -- ^ Offset of each new slot, in minutes
-> Int -- ^ Length of each slot, in minutes
-> SL.SortedList SimpleEventUTC
-> SL.SortedList SimpleEventUTC
partitionSlots ::
-- | Offset of each new slot, in minutes
Maybe Int ->
-- | Length of each slot, in minutes
Int ->
SL.SortedList SimpleEventUTC ->
SL.SortedList SimpleEventUTC
partitionSlots offsetM lengthM evs = loop evs
where
lengthT = fromIntegral $ lengthM * 60
......@@ -381,12 +387,12 @@ summaryMatches search = isInfixOf search . seSummary
isWithin :: Ord t => SimpleEvent t -> SimpleEvent t -> Bool
isWithin e1 e2 = seStart e2 <= seStart e1 && seEnd e1 <= seEnd e2
addEvent
:: (MonadUnliftIO m, MonadResource m)
=> CalendarContext
-> CalendarId
-> SimpleEventUTC
-> m ()
addEvent ::
(MonadUnliftIO m, MonadResource m) =>
CalendarContext ->
CalendarId ->
SimpleEventUTC ->
m ()
addEvent (MockCxt v) cid e =
modifyMVar_ v $ \m ->
return $ Map.insert cid (SL.insert e $ Map.findWithDefault mempty cid m) m
......
......@@ -3,11 +3,11 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Foundation
( App (..),
......@@ -16,7 +16,7 @@ module Foundation
Form,
Route (..),
resourcesApp,
unsafeHandler
unsafeHandler,
)
where
......@@ -40,14 +40,15 @@ import Yesod.Default.Util (addStaticContentExternal)
data App
= App
{ appSettings :: AppSettings,
appStatic :: Static, -- ^ Settings for static file serving.
-- | Settings for static file serving.
appStatic :: Static,
appHttpManager :: Manager,
appLogger :: Logger,
appCalendarCxt :: CalendarContext,
appCalendarCache :: FC.Cache (HandlerFor App) (SL.SortedList 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
-- 'appCacheExpiry'.
appCalendarCache :: FC.Cache (HandlerFor App) (SL.SortedList SimpleEventUTC)
}
-- This is where we define all of the routes in our application. For a full
......@@ -68,7 +69,6 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
instance MC.MonadCatch (HandlerFor App) where
catch = Pre.catch
addStylesheetL :: Route App -> Text -> [(Text, Text)] -> Widget
......@@ -86,7 +86,6 @@ 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 where
approot :: Approot App
approot =
ApprootRequest $ \app req ->
......@@ -144,10 +143,12 @@ instance Yesod App where
$(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
isAuthorized ::
-- | The route the user is visiting.
Route App ->
-- | Whether or not this is a "write" request.
Bool ->
Handler AuthResult
-- Routes not requiring authenitcation.
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
......@@ -158,11 +159,14 @@ instance Yesod App where
-- 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 ::
-- | The file extension
Text ->
-- | The MIME content type
Text ->
-- | The contents of the file
LByteString ->
Handler (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
......@@ -182,8 +186,8 @@ instance Yesod App where
-- in development, and warnings and errors in production.
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return
$ appShouldLogAll (appSettings app)
return $
appShouldLogAll (appSettings app)
|| level
== LevelWarn
|| level
......@@ -194,20 +198,19 @@ instance Yesod App where
-- Define breadcrumbs.
instance YesodBreadcrumbs App where
-- 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 ::
-- | The route the user is visiting currently.
Route App ->
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
......@@ -215,7 +218,6 @@ instance RenderMessage App FormMessage where
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod applications.
instance HasHttpManager App where
getHttpManager :: App -> Manager
getHttpManager = appHttpManager
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module: FreshCache
Description: Cache the result of an expensive action
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
-- Description: Cache the result of an expensive action
--
-- 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,
newCache,
readCache,
invalidateCache,
cacheDemo
cacheDemo,
)
where
......
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module: Handlers
Description: TODO
TODO
-}
-- |
-- Module: Handlers
-- Description: TODO
--
-- TODO
module Handlers
( getFaviconR,
getRobotsR,
......@@ -21,7 +20,7 @@ module Handlers
postBookR,