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

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 =
......
This diff is collapsed.
......@@ -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,8 +16,8 @@ module Foundation
Form,
Route (..),
resourcesApp,
unsafeHandler
)
unsafeHandler,
)
where
import qualified Control.Monad.Catch as MC
......@@ -40,15 +40,16 @@ 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
-- explanation of the syntax, please see:
......@@ -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 ->
......@@ -100,8 +99,8 @@ instance Yesod App where
makeSessionBackend _ =
Just
<$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
120 -- timeout in minutes
"config/client_session_key.aes"
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
......@@ -126,7 +125,7 @@ instance Yesod App where
"https://code.jquery.com/jquery-3.3.1.min.js"
[ ("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8="),
("crossorigin", "anonymous")
]
]
addScriptL
(StaticR js_js_cookie_2_2_0_min_js)
"https://cdn.jsdelivr.net/npm/js-cookie@2.2.0/src/js.cookie.min.js"
......@@ -138,16 +137,18 @@ instance Yesod App where
"https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"
[ ( "integrity",
"sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u"
),
),
("crossorigin", "anonymous")
]
]
$(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,32 +186,31 @@ 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)
|| level
== LevelWarn
|| level
== LevelError
return $
appShouldLogAll (appSettings app)
|| level
== LevelWarn
|| level
== LevelError
makeLogger :: App -> IO Logger
makeLogger = return . appLogger
-- 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
import ClassyPrelude.Yesod
......@@ -29,14 +28,14 @@ data CacheData a
= CacheData
{ value :: a,
retrievedAt :: UTCTime
}
}
data CacheMeta m a
= CacheMeta
{ content :: Maybe (CacheData a),
maxAge :: NominalDiffTime,
refresh :: m a
}
}
-- | The cache structure. Saves the value 'a' which can be refreshed or
-- accessed within the monad 'm'.
......
{-# 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,8 +20,8 @@ module Handlers
postBookR,
getFinalR,
getClearR,
getVersionR
)
getVersionR,
)
where
import BookingForm (b3Class, inputSize, labelSize)
......
module Import
( module Import
)
( module Import,
)
where
import Foundation as Import
......
......@@ -4,14 +4,14 @@ module Import.NoFoundation
( module Import,
pluralN,
fromWeeks,
fromMinutes
)
fromMinutes,
)
where
import Calendar as Import
( CalendarContext,
SimpleEventUTC
)
SimpleEventUTC,
)
import ClassyPrelude.Yesod as Import
import Data.Time.Clock (NominalDiffTime)
import Settings as Import
......
......@@ -2,20 +2,19 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module: QueryForm
Description: Form for front page, to query available times
Form for front page, to query available times. Consists of the
location, appointment length, time format, and time zone.
-}
-- |
-- Module: QueryForm
-- Description: Form for front page, to query available times
--
-- Form for front page, to query available times. Consists of the
-- location, appointment length, time format, and time zone.
module QueryForm
( TimeFmt (..),
QueryForm (..),
......@@ -36,8 +35,8 @@ module QueryForm
noSessionError,
showDate,
showTime,
prettyTz
)
prettyTz,
)
where
import Control.Monad.Trans.Maybe
......@@ -56,7 +55,6 @@ data TimeFmt
-- | Time format serialization for session and GET/POST parameters.
instance PathPiece TimeFmt where
toPathPiece Time12h = "12h"
toPathPiece Time24h = "24h"
......@@ -66,7 +64,6 @@ instance PathPiece TimeFmt where
-- | Default is 12-hour time.
instance Default TimeFmt where
def = Time12h
-- | Format strings to be used with 'Data.Time.Format'.
......@@ -82,7 +79,7 @@ data QueryForm
queryTimeFmt :: TimeFmt,
queryTzLabel :: TZLabelW,
queryLocation :: Location
}
}
deriving (Show)
-- | Represent field names used in a form. This abstraction gives
......@@ -94,11 +91,9 @@ data QueryName
deriving (Eq, Show)