Some more docs and dependency cleanup, hfmt

app/DevelMain.hs

@@ -27,73 +27,76 @@
 --
 -- 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           Application              (getApplicationRepl, shutdownApp)
+import           Prelude
 
-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           Control.Concurrent
+import           Control.Exception        (finally)
+import           Control.Monad            ((>=>))
+import           Data.IORef
+import           Foreign.Store
+import           GHC.Word
+import           Network.Wai.Handler.Warp
 
 -- | Start or restart the server.
 -- newStore is from foreign-store.
 -- A Store holds onto some data across ghci reloads
 update :: IO ()
 update = do
-    mtidStore <- lookupStore tidStoreNum
-    case mtidStore of
+  mtidStore <- lookupStore tidStoreNum
+  case mtidStore
       -- no server running
-      Nothing -> do
-          done <- storeAction doneStore newEmptyMVar
-          tid <- start done
-          _ <- storeAction (Store tidStoreNum) (newIORef tid)
-          return ()
+        of
+    Nothing -> do
+      done <- storeAction doneStore newEmptyMVar
+      tid <- start done
+      _ <- storeAction (Store tidStoreNum) (newIORef tid)
+      return ()
       -- server is already running
-      Just tidStore -> restartAppInNewThread tidStore
+    Just tidStore -> restartAppInNewThread tidStore
   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.
-          -> IO ThreadId
+    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)
+      (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))
+           (putMVar done () >> shutdownApp site))
 
 -- | kill the server
 shutdown :: IO ()
 shutdown = do
-    mtidStore <- lookupStore tidStoreNum
-    case mtidStore of
+  mtidStore <- lookupStore tidStoreNum
+  case mtidStore
       -- no server running
-      Nothing -> putStrLn "no Yesod app running"
-      Just tidStore -> do
-          withStore tidStore $ readIORef >=> killThread
-          putStrLn "Yesod app is shutdown"
+        of
+    Nothing -> putStrLn "no Yesod app running"
+    Just tidStore -> do
+      withStore tidStore $ readIORef >=> killThread
+      putStrLn "Yesod app is shutdown"
 
 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

app/auth.hs

-import Prelude (IO)
-import Settings.Auth (authorizeMain)
+import           Prelude       (IO)
+import           Settings.Auth (authorizeMain)
 
 main :: IO ()
 main = authorizeMain

app/main.hs

-import Prelude     (IO)
-import Application (appMain)
+import           Application (appMain)
+import           Prelude     (IO)
 
 main :: IO ()
 main = appMain

src/Application.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE ViewPatterns          #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Application
@@ -20,30 +19,29 @@ module Application
   , handler
   ) where
 
-import qualified Calendar as Cal
-import           Control.Monad.Logger                   (logInfoN, liftLoc)
-import qualified FreshCache as FC
+import qualified Calendar                             as Cal
+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,
-                                                         setPort)
-import           Network.Wai.Middleware.RequestLogger   (Destination (Logger),
-                                                         IPAddrSource (..),
-                                                         OutputFormat (..),
-                                                         destination,
-                                                         mkRequestLogger,
-                                                         outputFormat)
-import           System.Log.FastLogger                  (defaultBufSize,
-                                                         newStdoutLoggerSet,
-                                                         toLogStr)
+import           Language.Haskell.TH.Syntax           (qLocation)
+import           Network.HTTP.Client.TLS              (getGlobalManager)
+import           Network.Wai                          (Middleware)
+import           Network.Wai.Handler.Warp             (Settings,
+                                                       defaultSettings,
+                                                       defaultShouldDisplayException,
+                                                       getPort, runSettings,
+                                                       setHost, setOnException,
+                                                       setPort)
+import           Network.Wai.Middleware.RequestLogger (Destination (Logger),
+                                                       IPAddrSource (..),
+                                                       OutputFormat (..),
+                                                       destination,
+                                                       mkRequestLogger,
+                                                       outputFormat)
+import           System.Log.FastLogger                (defaultBufSize,
+                                                       newStdoutLoggerSet,
+                                                       toLogStr)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -63,24 +61,28 @@ 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{..}
-      where
-        appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
-        appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
-    logFunc loc src lv =
-      whenM (shouldLogIO partialApp "" lv) .
-      messageLoggerSource partialApp appLogger loc src lv
+    (if appMutableStatic
+       then staticDevel
+       else static)
+      appStaticDir
+  let partialApp = App {..}
+        where
+          appCalendarCxt = error "partialApp loop: Accessing appCalendarCxt"
+          appGetCalendar = error "partialApp loop: Accessing appGetCalendar"
+      logFunc loc src lv =
+        whenM (shouldLogIO partialApp "" lv) .
+        messageLoggerSource partialApp appLogger loc src lv
   appCalendarCxt <- Cal.initialize logFunc appHttpManager appCredentials
-  cache <- unsafeHandler partialApp $ FC.newCache $ do
-    logInfoN "Refreshing calendar cache"
-    Cal.listAvailMinusBusy appCalendarCxt
-      appFreeCalendarId appBusyCalendarId $ fromWeeks appLookaheadWeeks
+  cache <-
+    unsafeHandler partialApp $
+    FC.newCache $ do
+      logInfoN "Refreshing calendar cache"
+      Cal.listAvailMinusBusy appCalendarCxt appFreeCalendarId appBusyCalendarId $
+        fromWeeks appLookaheadWeeks
   let appGetCalendar = FC.readCache cache . fromMaybe appCacheExpiry
   return App {..}
 

src/Calendar.hs

@@ -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

src/Foundation.hs

@@ -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
@@ -37,12 +36,12 @@ import           Yesod.Default.Util   (addStaticContentExternal)
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data App = App
-  { appSettings :: AppSettings
-  , appStatic :: Static -- ^ Settings for static file serving.
+  { appSettings    :: AppSettings
+  , appStatic      :: Static -- ^ Settings for static file serving.
   , appHttpManager :: Manager
-  , appLogger :: Logger
-  , appCalendarCxt :: Cal.Context
-  , appGetCalendar :: Maybe NominalDiffTime -> HandlerFor App [Cal.SimpleEventUTC]
+  , appLogger      :: Logger
+  , 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'.

src/FreshCache.hs

@@ -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)

src/Handler/Common.hs

-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+
 -- | Common handler functions.
 module Handler.Common where
 
-import Data.FileEmbed (embedFile)
-import Import
+import           Data.FileEmbed (embedFile)
+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")

src/Handler/Home.hs

@@ -9,37 +9,40 @@
 
 module Handler.Home where
 
-import qualified Calendar as Cal
+import qualified Calendar         as Cal
 import qualified Data.Time.Format as TF
 import           Import
-import           Text.Julius                 (RawJS (..))
+import           Text.Julius      (RawJS (..))
 
 apptLengthOptions :: Handler (OptionList Int)
 apptLengthOptions = do
   lengths <- appApptLengthsMinutes . appSettings <$> getYesod
-  let
-    toOption m =
-      Option
-      { optionDisplay = tshow m <> " minute"
-      , optionInternalValue = m
-      , optionExternalValue = tshow 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
+      { olOptions = map toOption lengths
+      , olReadExternal = fromPathPiece >=> okLength
       }
-    okLength m =
-      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
-                 Nothing -> Left $ SomeMessage $ MsgInvalidEntry txt
-                 Just loc -> Right $ Just loc
+      return $
+        case find ((== txt) . locId) locs of
+          Nothing  -> Left $ SomeMessage $ MsgInvalidEntry txt
+          Just loc -> Right $ Just loc
     fieldView i _ attrs val _ = do
       locs <- appLocations . appSettings <$> getYesod
       [whamlet|
@@ -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
@@ -63,19 +67,21 @@ instance PathPiece TimeFmt where
   toPathPiece Time24h = "24h"
   fromPathPiece "12h" = Just Time12h
   fromPathPiece "24h" = Just Time24h
-  fromPathPiece _ = Nothing
+  fromPathPiece _     = Nothing
 
 instance Default TimeFmt where
   def = Time12h
 
 timeFmtOptions :: Handler (OptionList TimeFmt)
-timeFmtOptions = return $ OptionList
-  { olReadExternal = fromPathPiece
-  , olOptions =
-      [ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h)
-      , Option "24-hour" Time24h (toPathPiece Time24h)
-      ]
-  }
+timeFmtOptions =
+  return $
+  OptionList
+    { olReadExternal = fromPathPiece
+    , olOptions =
+        [ Option "12-hour (AM/PM)" Time12h (toPathPiece Time12h)
+        , Option "24-hour" Time24h (toPathPiece Time24h)
+        ]
+    }
 
 data QueryForm = QueryForm
   { queryApptLength :: Int
@@ -83,22 +89,27 @@ 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
-    widget = do
-      toWidget
-        [julius|
+  let q =
+        QueryForm <$> lenRes <*> fmtRes <*> pure appDefaultTimeZone <*> locRes <*>
+        slotRes
+      widget = do
+        toWidget
+          [julius|
                $(function(){
                  $(".#{rawJS qc}").change(sendQuery);
                  sendQuery();
@@ -113,7 +124,7 @@ queryForm extra = do
                  });
                }
                |]
-      [whamlet|
+        [whamlet|
               #{extra}
               <p>
                 Show
@@ -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
-                then "%l:%M %p"
-                else "%H:%M"
+          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'

src/Import.hs

 module Import
-    ( module Import
-    ) where
+  ( module Import
+  ) where
 
-import Foundation            as Import
-import Import.NoFoundation   as Import
+import           Foundation          as Import
+import           Import.NoFoundation as Import