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 @@ ...@@ -29,16 +29,15 @@
-- 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 Application (getApplicationRepl, shutdownApp) import Application (getApplicationRepl, shutdownApp)
import Prelude import Control.Concurrent
import Control.Exception (finally)
import Control.Concurrent import Control.Monad ((>=>))
import Control.Exception (finally) import Data.IORef
import Control.Monad ((>=>)) import Foreign.Store
import Data.IORef import GHC.Word
import Foreign.Store import Network.Wai.Handler.Warp
import GHC.Word import Prelude
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.
...@@ -46,15 +45,15 @@ import Network.Wai.Handler.Warp ...@@ -46,15 +45,15 @@ import Network.Wai.Handler.Warp
update :: IO () update :: IO ()
update = do update = do
mtidStore <- lookupStore tidStoreNum mtidStore <- lookupStore tidStoreNum
case mtidStore case mtidStore of
-- no server running -- no server running
of
Nothing -> do Nothing -> do
done <- storeAction doneStore newEmptyMVar done <- storeAction doneStore newEmptyMVar
tid <- start done tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid) _ <- storeAction (Store tidStoreNum) (newIORef tid)
return () 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 ())
...@@ -66,27 +65,28 @@ update = do ...@@ -66,27 +65,28 @@ update = 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 :: start ::
MVar () -- ^ Written to when the thread is killed. -- | Written to when the thread is killed.
-> IO ThreadId MVar () ->
IO ThreadId
start done = do start done = do
(port, site, app) <- getApplicationRepl (port, site, app) <- getApplicationRepl
forkIO forkIO
(finally ( finally
(runSettings (setPort port defaultSettings) app) (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 case mtidStore of
-- no server running -- no server running
of
Nothing -> putStrLn "no Yesod app running" Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do Just tidStore -> do
withStore tidStore $ readIORef >=> killThread withStore tidStore $ readIORef >=> killThread
......
import Prelude (IO) import Settings.Auth (authorizeMain)
import Settings.Auth (authorizeMain) import Prelude (IO)
main :: IO () main :: IO ()
main = authorizeMain main = authorizeMain
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
import "bookme" Application (develMain) import "bookme" Application (develMain)
import Prelude (IO) import Prelude (IO)
......
import Application (appMain) import Application (appMain)
import Prelude (IO) import Prelude (IO)
main :: IO () main :: IO ()
main = appMain main = appMain
...@@ -12,9 +12,18 @@ let ...@@ -12,9 +12,18 @@ let
&& ! (lib.elem (baseNameOf name) ignore) && ! (lib.elem (baseNameOf name) ignore)
&& ! (lib.hasPrefix ".ghc.environment" (baseNameOf name)) && ! (lib.hasPrefix ".ghc.environment" (baseNameOf name))
&& ! (lib.hasPrefix "autogen-" (baseNameOf name)); && ! (lib.hasPrefix "autogen-" (baseNameOf name));
hp = haskellPackages.override {
overrides = self: super: {
mkDerivation = args: super.mkDerivation (args // {
doHaddock = false;
enableLibraryProfiling = false;
});
};
};
in in
haskell.lib.overrideCabal haskell.lib.overrideCabal
(haskellPackages.callPackage ./bookme.nix { }) (hp.callPackage ./bookme.nix { })
(drv: { (drv: {
doCheck = false; doCheck = false;
doHaddock = false; doHaddock = false;
......
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application module Application
...@@ -12,12 +12,14 @@ module Application ...@@ -12,12 +12,14 @@ module Application
develMain, develMain,
makeFoundation, makeFoundation,
makeLogWare, makeLogWare,
-- * for DevelMain -- * for DevelMain
getApplicationRepl, getApplicationRepl,
shutdownApp, shutdownApp,
-- * for GHCI -- * for GHCI
handler handler,
) )
where where
import qualified Calendar as Cal import qualified Calendar as Cal
...@@ -36,21 +38,21 @@ import Network.Wai.Handler.Warp ...@@ -36,21 +38,21 @@ import Network.Wai.Handler.Warp
runSettings, runSettings,
setHost, setHost,
setOnException, setOnException,
setPort setPort,
) )
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
( Destination (Logger), ( Destination (Logger),
IPAddrSource (..), IPAddrSource (..),
OutputFormat (..), OutputFormat (..),
destination, destination,
mkRequestLogger, mkRequestLogger,
outputFormat outputFormat,
) )
import System.Log.FastLogger import System.Log.FastLogger
( defaultBufSize, ( defaultBufSize,
newStdoutLoggerSet, newStdoutLoggerSet,
toLogStr toLogStr,
) )
-- This line actually creates our YesodDispatch instance. It is the second half -- 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 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
...@@ -84,8 +86,8 @@ makeFoundation appSettings@AppSettings {..} = do ...@@ -84,8 +86,8 @@ makeFoundation appSettings@AppSettings {..} = do
$ FC.newCache appCacheExpiry $ FC.newCache appCacheExpiry
$ do $ do
logInfoN "Refreshing calendar cache" logInfoN "Refreshing calendar cache"
Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
$ fromWeeks appLookaheadWeeks fromWeeks appLookaheadWeeks
return App {..} return App {..}
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
...@@ -109,9 +111,9 @@ makeLogWare foundation = ...@@ -109,9 +111,9 @@ makeLogWare foundation =
( if appIpFromHeader $ appSettings foundation ( if appIpFromHeader $ appSettings foundation
then FromFallback then FromFallback
else FromSocket else FromSocket
), ),
destination = Logger $ loggerSet $ appLogger foundation destination = Logger $ loggerSet $ appLogger foundation
} }
-- | Warp settings for the given foundation value. -- | Warp settings for the given foundation value.
warpSettings :: App -> Settings warpSettings :: App -> Settings
...@@ -119,17 +121,17 @@ warpSettings foundation = ...@@ -119,17 +121,17 @@ warpSettings foundation =
setPort (appPort $ appSettings foundation) setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation) $ setHost (appHost $ appSettings foundation)
$ setOnException $ setOnException
( \_req e -> ( \_req e ->
when (defaultShouldDisplayException e) when (defaultShouldDisplayException e) $
$ messageLoggerSource messageLoggerSource
foundation foundation
(appLogger foundation) (appLogger foundation)
$(qLocation >>= liftLoc) $(qLocation >>= liftLoc)
"yesod" "yesod"
LevelError LevelError
(toLogStr $ "Exception from Warp: " ++ show e) (toLogStr $ "Exception from Warp: " ++ show e)
) )
defaultSettings defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application. -- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application) getApplicationDev :: IO (Settings, Application)
...@@ -182,6 +184,7 @@ shutdownApp _ = return () ...@@ -182,6 +184,7 @@ shutdownApp _ = return ()
--------------------------------------------- ---------------------------------------------
-- Functions for use in development with GHCi -- Functions for use in development with GHCi
--------------------------------------------- ---------------------------------------------
-- | Run a handler -- | Run a handler
handler :: Handler a -> IO a handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-| -- |
Module: BookingForm -- Module: BookingForm
Description: TODO -- Description: TODO
--
TODO -- TODO
-}
module BookingForm module BookingForm
( Booking (..), ( Booking (..),
bookingMForm, bookingMForm,
...@@ -19,8 +18,8 @@ module BookingForm ...@@ -19,8 +18,8 @@ module BookingForm
fromSession, fromSession,
b3Class, b3Class,
inputSize, inputSize,
labelSize labelSize,
) )
where where
import Calendar import Calendar
...@@ -41,7 +40,7 @@ data Booking ...@@ -41,7 +40,7 @@ data Booking
bookEmail :: Text, bookEmail :: Text,
bookSubject :: Text, bookSubject :: Text,
bookContact :: Maybe Text bookContact :: Maybe Text
} }
deriving (Show) deriving (Show)
toSession :: MonadHandler m => Booking -> m () toSession :: MonadHandler m => Booking -> m ()
...@@ -97,11 +96,10 @@ data RecaptchaResponse ...@@ -97,11 +96,10 @@ data RecaptchaResponse
= RecaptchaResponse = RecaptchaResponse
{ rrSuccess :: Bool, { rrSuccess :: Bool,
rrErrors :: [Text] rrErrors :: [Text]
} }
deriving (Show) deriving (Show)
instance Js.FromJSON RecaptchaResponse where instance Js.FromJSON RecaptchaResponse where
parseJSON = parseJSON =
Js.withObject "RecaptchaResponse" $ \o -> do Js.withObject "RecaptchaResponse" $ \o -> do
rrSuccess <- o .: "success" rrSuccess <- o .: "success"
...@@ -123,9 +121,9 @@ recaptcha = ...@@ -123,9 +121,9 @@ recaptcha =
let req = let req =
req' & H.setRequestManager mgr req' & H.setRequestManager mgr
& H.setRequestBodyURLEncoded & H.setRequestBodyURLEncoded
[ ("secret", encodeUtf8 secret), [ ("secret", encodeUtf8 secret),
("response", encodeUtf8 response) ("response", encodeUtf8 response)
] ]
resp <- H.getResponseBody <$> H.httpJSON req resp <- H.getResponseBody <$> H.httpJSON req
if rrSuccess resp if rrSuccess resp
then return (FormSuccess (), []) then return (FormSuccess (), [])
...@@ -170,8 +168,8 @@ b3Class g = ...@@ -170,8 +168,8 @@ b3Class g =
B3.ColMd n -> "col-md-" <> tshow n B3.ColMd n -> "col-md-" <> tshow n
B3.ColLg n -> "col-lg-" <> tshow n B3.ColLg n -> "col-lg-" <> tshow n
bookingMForm bookingMForm ::
:: Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget) Maybe Booking -> Html -> MForm Handler (FormResult Booking, Widget)
bookingMForm = B3.renderBootstrap3 horiz . bookingAForm bookingMForm = B3.renderBootstrap3 horiz . bookingAForm
where where
horiz = horiz =
......
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-| -- |
Module: Calendar -- Module: Calendar
Description: Query and manipulate calendars and events. -- Description: Query and manipulate calendars and events.
--
This module contains facilities for querying and manipulating -- This module contains facilities for querying and manipulating
calendars and their events. It supports both Google calendars and a -- 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
( CalendarScope, ( CalendarScope,
CalendarCredentials, CalendarCredentials,
...@@ -29,8 +28,8 @@ module Calendar ...@@ -29,8 +28,8 @@ module Calendar
partitionSlots, partitionSlots,
summaryMatches, summaryMatches,
isWithin, isWithin,
addEvent addEvent,
) )
where where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
...@@ -39,8 +38,8 @@ import Control.Monad.Logger ...@@ -39,8 +38,8 @@ import Control.Monad.Logger
( Loc, ( Loc,
LogSource, LogSource,
LogStr, LogStr,
defaultLoc defaultLoc,
) )
import qualified Data.Aeson as Js import qualified Data.Aeson as Js
import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Builder (toLazyByteString)
import Data.Function ((&)) import Data.Function ((&))
...@@ -49,8 +48,8 @@ import qualified Data.SortedList as SL ...@@ -49,8 +48,8 @@ import qualified Data.SortedList as SL
import Data.Time.Clock import Data.Time.Clock
( DiffTime, ( DiffTime,
NominalDiffTime, NominalDiffTime,
addUTCTime addUTCTime,
) )
import Data.Time.LocalTime (LocalTime (..)) import Data.Time.LocalTime (LocalTime (..))
import Data.Time.Zones (TZ, utcToLocalTimeTZ) import Data.Time.Zones (TZ, utcToLocalTimeTZ)
import qualified Network.Google as Google import qualified Network.Google as Google
...@@ -70,7 +69,6 @@ data CalendarCredentials ...@@ -70,7 +69,6 @@ data CalendarCredentials
-- | 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 CalendarCredentials where instance Show CalendarCredentials where
show MockCreds = "<mock>" show MockCreds = "<mock>"
show (GoogleCreds _) = "<google>" show (GoogleCreds _) = "<google>"
...@@ -78,7 +76,6 @@ instance Show CalendarCredentials where ...@@ -78,7 +76,6 @@ instance Show CalendarCredentials where
-- 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 CalendarCredentials where instance FromJSON CalendarCredentials where
parseJSON = parseJSON =
Js.withObject "CalendarCredentials" $ \o -> Js.withObject "CalendarCredentials" $ \o ->
o .: "client_id" >>= \c -> o .: "client_id" >>= \c ->
...@@ -105,41 +102,41 @@ mockFreeId = "mock-free" ...@@ -105,41 +102,41 @@ mockFreeId = "mock-free"
-- calendar operations. The Google environment requires a logging -- calendar operations. The Google environment requires a logging
-- function and an HTTP manager. If using a mock calendar, a warning is -- function and an HTTP manager. If using a mock calendar, a warning is
-- printed using the logging function. -- printed using the logging function.
initialize initialize ::
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->
-> Manager Manager ->
-> CalendarCredentials CalendarCredentials ->
-> IO CalendarContext IO CalendarContext
initialize appLog _ MockCreds = do initialize appLog _ MockCreds = do
appLog defaultLoc "" LevelWarn "Using mock calendar" appLog defaultLoc "" LevelWarn "Using mock calendar"
day <- succ . utctDay <$> getCurrentTime day <- succ . utctDay <$> getCurrentTime
let free = let free =
SL.toSortedList SL.toSortedList $
$ map map
(sampleEvent day) (sampleEvent day)
[ ("free1a", fwd 0, 1100, 1155), [ ("free1a", fwd 0, 1100, 1155),
("free1b #office", fwd 0, 1300, 1450), ("free1b #office", fwd 0, 1300, 1450),
("free1c #office", fwd 0, 1530, 1800), ("free1c #office", fwd 0, 1530, 1800),
("free2a #home", fwd 1, 1200, 1600), ("free2a #home", fwd 1, 1200, 1600),
("free2b #office", fwd 1, 1700, 1800), ("free2b #office", fwd 1, 1700, 1800),
("free3a #office", fwd 2, 1000, 1200), ("free3a #office", fwd 2, 1000, 1200),
("free3b #home", fwd 2, 1500, 1930) ("free3b #home", fwd 2, 1500, 1930)
] ]
busy = busy =
SL.toSortedList SL.toSortedList $
$ map map
(sampleEvent day) (sampleEvent day)
[ ("busy1a", fwd 0, 1210, 1300), [ ("busy1a", fwd 0, 1210, 1300),
("busy1b", fwd 0, 1330, 1430), ("busy1b", fwd 0, 1330, 1430),
("busy1c", fwd 0, 1500, 1550), ("busy1c", fwd 0, 1500, 1550),
("busy1d", fwd 0, 1730, 1830), ("busy1d", fwd 0, 1730, 1830),
("busy2a", fwd 1, 1130, 1215), ("busy2a", fwd 1, 1130, 1215),
("busy2b", fwd 1, 1330, 1400), ("busy2b", fwd 1, 1330, 1400),
("busy2c", fwd 1, 1430, 1500), ("busy2c", fwd 1, 1430, 1500),
("busy2d", fwd 1, 1610, 1650), ("busy2d", fwd 1, 1610, 1650),
("busy3a", fwd 2, 1100, 1400), ("busy3a", fwd 2, 1100, 1400),
("busy3b", fwd 2, 1900, 2100) ("busy3b", fwd 2, 1900, 2100)
] ]
MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)]) MockCxt <$> newMVar (Map.fromList [(mockFreeId, free), (mockBusyId, busy)])
initialize appLog manager (GoogleCreds creds) = initialize appLog manager (GoogleCreds creds) =
GoogleCxt GoogleCxt
...@@ -165,11 +162,10 @@ data SimpleEvent t ...@@ -165,11 +162,10 @@ data SimpleEvent t
seDescr :: Text, seDescr :: Text,
seLocation :: Text, seLocation :: Text,
seAttendees :: [Attendee] seAttendees :: [Attendee]
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Ord t => Ord (SimpleEvent t) where instance Ord t => Ord (SimpleEvent t) where
compare x y = compare (seStart x) (seStart y) compare x y = compare (seStart x) (seStart y)
type SimpleEventUTC = SimpleEvent UTCTime type SimpleEventUTC = SimpleEvent UTCTime
...@@ -180,7 +176,7 @@ data Attendee ...@@ -180,7 +176,7 @@ data Attendee
= Attendee = Attendee
{ atName :: Text, { atName :: Text,