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
......@@ -29,16 +29,15 @@
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationRepl, shutdownApp)
import Prelude
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad ((>=>))
import Data.IORef
import Foreign.Store
import GHC.Word
import Network.Wai.Handler.Warp
import Application (getApplicationRepl, shutdownApp)
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad ((>=>))
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,15 +45,15 @@ import Network.Wai.Handler.Warp
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore
-- no server running
of
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
-- server is already running
Just tidStore -> restartAppInNewThread tidStore
where
doneStore :: Store (MVar ())
......@@ -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
(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))
( 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)
)
-- | kill the server
shutdown :: IO ()
shutdown = do
mtidStore <- lookupStore tidStoreNum
case mtidStore
-- no server running
of
case mtidStore of
-- no server running
Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do
withStore tidStore $ readIORef >=> killThread
......
import Prelude (IO)
import Settings.Auth (authorizeMain)
import Settings.Auth (authorizeMain)
import Prelude (IO)
main :: IO ()
main = authorizeMain
{-# LANGUAGE PackageImports #-}
import "bookme" Application (develMain)
import Prelude (IO)
......
import Application (appMain)
import Prelude (IO)
import Application (appMain)
import Prelude (IO)
main :: IO ()
main = appMain
......@@ -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,12 +12,14 @@ module Application
develMain,
makeFoundation,
makeLogWare,
-- * for DevelMain
getApplicationRepl,
shutdownApp,
-- * for GHCI
handler
)
handler,
)
where
import qualified Calendar as Cal
......@@ -36,21 +38,21 @@ import Network.Wai.Handler.Warp
runSettings,
setHost,
setOnException,
setPort
)
setPort,
)
import Network.Wai.Middleware.RequestLogger
( Destination (Logger),
IPAddrSource (..),
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
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
......@@ -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
......@@ -109,9 +111,9 @@ makeLogWare foundation =
( if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket
),
),
destination = Logger $ loggerSet $ appLogger foundation
}
}
-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
......@@ -119,17 +121,17 @@ 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
( \_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)
......@@ -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,8 +18,8 @@ module BookingForm
fromSession,
b3Class,
inputSize,
labelSize
)
labelSize,
)
where
import Calendar
......@@ -41,7 +40,7 @@ data Booking
bookEmail :: Text,
bookSubject :: Text,
bookContact :: Maybe Text
}
}
deriving (Show)
toSession :: MonadHandler m => Booking -> m ()
......@@ -97,11 +96,10 @@ data RecaptchaResponse
= RecaptchaResponse
{ rrSuccess :: Bool,
rrErrors :: [Text]
}
}
deriving (Show)
instance Js.FromJSON RecaptchaResponse where
parseJSON =
Js.withObject "RecaptchaResponse" $ \o -> do
rrSuccess <- o .: "success"
......@@ -123,9 +121,9 @@ recaptcha =
let req =
req' & H.setRequestManager mgr
& H.setRequestBodyURLEncoded
[ ("secret", encodeUtf8 secret),
("response", encodeUtf8 response)
]
[ ("secret", encodeUtf8 secret),
("response", encodeUtf8 response)
]
resp <- H.getResponseBody <$> H.httpJSON req
if rrSuccess resp
then return (FormSuccess (), [])
......@@ -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,8 +28,8 @@ module Calendar
partitionSlots,
summaryMatches,
isWithin,
addEvent
)
addEvent,
)
where
import ClassyPrelude.Yesod
......@@ -39,8 +38,8 @@ import Control.Monad.Logger
( Loc,
LogSource,
LogStr,
defaultLoc
)
defaultLoc,
)
import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString)
import Data.Function ((&))
......@@ -49,8 +48,8 @@ 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)
import qualified Network.Google as Google
......@@ -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,41 +102,41 @@ 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
(sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155),
("free1b #office", fwd 0, 1300, 1450),
("free1c #office", fwd 0, 1530, 1800),
("free2a #home", fwd 1, 1200, 1600),
("free2b #office", fwd 1, 1700, 1800),
("free3a #office", fwd 2, 1000, 1200),
("free3b #home", fwd 2, 1500, 1930)
]
SL.toSortedList $
map
(sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155),
("free1b #office", fwd 0, 1300, 1450),
("free1c #office", fwd 0, 1530, 1800),
("free2a #home", fwd 1, 1200, 1600),
("free2b #office", fwd 1, 1700, 1800),
("free3a #office", fwd 2, 1000, 1200),
("free3b #home", fwd 2, 1500, 1930)
]
busy =
SL.toSortedList
$ map
(sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300),
("busy1b", fwd 0, 1330, 1430),
("busy1c", fwd 0, 1500, 1550),
("busy1d", fwd 0, 1730, 1830),
("busy2a", fwd 1, 1130, 1215),
("busy2b", fwd 1, 1330, 1400),
("busy2c", fwd 1, 1430, 1500),
("busy2d", fwd 1, 1610, 1650),
("busy3a", fwd 2, 1100, 1400),
("busy3b", fwd 2, 1900, 2100)
]
SL.toSortedList $
map
(sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300),
("busy1b", fwd 0, 1330, 1430),
("busy1c", fwd 0, 1500, 1550),
("busy1d", fwd 0, 1730, 1830),
("busy2a", fwd 1, 1130, 1215),
("busy2b", fwd 1, 1330, 1400),
("busy2c", fwd 1, 1430, 1500),
("busy2d", fwd 1, 1610, 1650),
("busy3a", fwd 2, 1100, 1400),
("busy3b", fwd 2, 1900, 2100)
]
MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)])
initialize appLog manager (GoogleCreds creds) =
GoogleCxt
......@@ -165,11 +162,10 @@ data SimpleEvent t
seDescr :: Text,
seLocation :: Text,
seAttendees :: [Attendee]
}
}
deriving (Eq, Show)
instance Ord t => Ord (SimpleEvent t) where
compare x y = compare (seStart x) (seStart y)
type SimpleEventUTC = SimpleEvent UTCTime
......@@ -180,7 +176,7 @@ data Attendee
= Attendee
{ atName :: Text,
atEmail :: Text
}
}
deriving (Show, Eq)
-- | Extract essential event data from a Google @Event@ object.
......@@ -209,16 +205,16 @@ expandEvent SimpleEvent {..} =
.~ map expandAttendee seAttendees
& eReminders
.~ Just
( eventReminders & erOverrides .~ defaultReminders
& erUseDefault
.~ Just False
)
( eventReminders & erOverrides .~ defaultReminders
& erUseDefault
.~ Just False
)
defaultReminders :: [EventReminder]
defaultReminders =
[ eventReminder & erMethod .~ Just "email" & erMinutes .~ Just 1440,
eventReminder & erMethod .~ Just "popup" & erMinutes .~ Just 10
]
]
simplifyAttendee :: EventAttendee -> Maybe Attendee
simplifyAttendee at = do
......@@ -260,15 +256,16 @@ sampleEvent d (summary, f, hmm1, hmm2) =
seDescr = "",
seLocation = "",
seAttendees = []
}
}
-- | 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
......@@ -278,12 +275,12 @@ listUpcoming (GoogleCxt env) cid lookahead = do
Google.runGoogle env
$ Google.send
$ eventsList cid
& elTimeMin
.~ Just now
& elTimeMax
.~ Just end
& elSingleEvents
.~ Just True
& elTimeMin
.~ Just now
& elTimeMax
.~ Just end
& elSingleEvents
.~ Just True
let es = SL.toSortedList $ mapMaybe simplifyEvent $ xs ^. eveItems
--forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
return es
......@@ -291,13 +288,14 @@ 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 =
ev
{ seStart = utcToLocalTimeTZ tz (seStart ev),
seEnd = utcToLocalTimeTZ tz (seEnd ev)
}
}
groupByDay :: SL.SortedList SimpleEventLocal -> [[SimpleEventLocal]]
groupByDay = groupAllOn (localDay . seStart) . SL.fromSortedList
......@@ -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