Clean up and simplify

package.yaml

@@ -7,51 +7,48 @@ dependencies:
 # See: https://ghc.haskell.org/trac/ghc/ticket/12130
 - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
 
-- aeson                  >=0.6   && <1.3
-- bytestring             >=0.9   && <0.11
-- case-insensitive
-- classy-prelude         >=1.4   && <1.5
-- classy-prelude-conduit >=1.4   && <1.5
-- classy-prelude-yesod   >=1.4   && <1.5
-- conduit                >=1.0   && <2.0
-- containers
-- base64-bytestring
-- binary
-- data-default
-- directory              >=1.1   && <1.4
-- exceptions
-- fast-logger            >=2.2   && <2.5
-- file-embed
-- foreign-store
-- gogol                  >=0.3.0 && <0.4
-- gogol-apps-calendar    >=0.3.0 && <0.4
-- hjsmin                 >=0.1   && <0.3
-- http-client-tls        >=0.3   && <0.4
-- http-conduit           >=2.3   && <2.4
-- http-types
-- lens
-- monad-control          >=0.3   && <1.1
-- monad-logger           >=0.3   && <0.4
-- safe
-- shakespeare            >=2.0   && <2.1
-- sorted-list            >=0.2.0.0 && <0.3
-- template-haskell
-- text                   >=0.11  && <2.0
-- time
-- tz
-- transformers
-- blaze-markup
-- unordered-containers
-- vector
-- wai
-- wai-extra              >=3.0   && <3.1
-- wai-logger             >=2.2   && <2.4
-- warp                   >=3.0   && <3.3
-- yaml                   >=0.8   && <0.9
-- yesod                  >=1.6   && <1.7
-- yesod-core             >=1.6   && <1.7
-- yesod-form             >=1.6   && <1.7
-- yesod-static           >=1.6   && <1.7
+- aeson                  >=0.6      && <1.3
+- blaze-markup           >=0.8.2.1  && <0.9
+- bytestring             >=0.9      && <0.11
+- case-insensitive       >=1.2.0.11 && <1.3
+- classy-prelude         >=1.4      && <1.5
+- classy-prelude-conduit >=1.4      && <1.5
+- classy-prelude-yesod   >=1.4      && <1.5
+- conduit                >=1.0      && <2.0
+- containers             >=0.5.10.2 && <0.6
+- data-default           >=0.7.1.1  && <0.8
+- directory              >=1.1      && <1.4
+- exceptions             >=0.8.3    && <0.9
+- fast-logger            >=2.2      && <2.5
+- file-embed             >=0.0.10.1 && <0.1
+- foreign-store          >=0.2      && <0.3
+- gogol                  >=0.3.0    && <0.4
+- gogol-apps-calendar    >=0.3.0    && <0.4
+- hjsmin                 >=0.1      && <0.3
+- http-client-tls        >=0.3      && <0.4
+- http-conduit           >=2.3      && <2.4
+- http-types             >=0.12.1   && <0.13
+- lens                   >=4.16.1   && <4.17
+- monad-control          >=0.3      && <1.1
+- monad-logger           >=0.3      && <0.4
+- shakespeare            >=2.0      && <2.1
+- sorted-list            >=0.2.0.0  && <0.3
+- template-haskell       >=2.12.0.0 && <2.13
+- text                   >=0.11     && <2.0
+- time                   >=1.8.0.2  && <1.9
+- transformers           >=0.5.2.0  && <0.6
+- tz                     >=0.1.3.1  && <0.2
+- unordered-containers   >=0.2.9.0  && <0.3
+- vector                 >=0.12.0.1 && <0.13
+- wai                    >=3.2.1.2  && <3.3
+- wai-extra              >=3.0      && <3.1
+- wai-logger             >=2.2      && <2.4
+- warp                   >=3.0      && <3.3
+- yaml                   >=0.8      && <0.9
+- yesod                  >=1.6      && <1.7
+- yesod-core             >=1.6      && <1.7
+- yesod-form             >=1.6      && <1.7
+- yesod-static           >=1.6      && <1.7
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Calendar.hs

@@ -258,9 +258,9 @@ listUpcoming (GoogleCxt env) cid lookahead = do
   --forM_ (SL.fromSortedList es) $ sayEvent $ take 4 cid
   return es
 
-sayEvent :: MonadIO m => Text -> SimpleEventUTC -> m ()
-sayEvent prefix SimpleEvent {..} =
-  say $ prefix <> " " <> tshow seStart <> " " <> tshow seEnd <> " " <> seSummary
+-- 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

src/Handler/Common.hs

-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude     #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-
--- | Common handler functions.
-module Handler.Common where
-
-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")
-
-getRobotsR :: Handler TypedContent
-getRobotsR =
-  return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt")

src/Handler/Home.hs

-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude     #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-
-module Handler.Home where
-
-import qualified BookingForm     as BF
-import           Calendar
-import qualified Data.SortedList as SL
-import           Data.Time.Clock (addUTCTime)
-import           Data.Time.Zones
-import qualified FreshCache      as FC
-import           Import
-import qualified QueryForm       as QF
-import           Text.Hamlet     (hamletFile)
-import           Text.Julius     (RawJS (..))
-{-
-getHomeR :: Handler Html
-getHomeR = do
-  App {..} <- getYesod
-  -- Start refresh of calendar, but don't wait for result.
-  void $ async $ FC.readCache appCalendarCache
-  (widget, enctype) <- generateFormPost QF.queryForm
-  (idSpinner, idAvail, idAlert) <- (,,) <$> newIdent <*> newIdent <*> newIdent
-  defaultLayout $ do
-    setTitle "Book an appointment"
-    $(widgetFile "homepage")
-
-formSuccess :: MonadHandler m => ((FormResult a, b), c) -> m a
-formSuccess ((formResult, _), _) =
-  case formResult of
-    FormMissing        -> invalidArgs ["Missing form data!"]
-    FormFailure errors -> invalidArgs errors
-    FormSuccess result -> return result
-
-showD :: SimpleEventLocal -> String
-showD = QF.showDate . seStart
-
-showT :: QF.TimeFmt -> SimpleEventLocal -> String
-showT fmt = QF.showTime fmt . seStart
-
-slotVal :: SimpleEventLocal -> Text
-slotVal = tshow . seStart
-
-getAvailR :: Handler Html
-getAvailR = do
-  QF.QueryForm {..} <- formSuccess =<< runFormGet QF.queryForm
-  App {appSettings = AppSettings {..}, ..} <- getYesod
-  let tz = tzByLabel queryTzLabel
-      offset = fromMaybe queryApptLength $ headMay appApptLengthsMinutes
-  avail <-
-    groupByDay .
-    SL.map (applyTz tz) .
-    partitionSlots offset queryApptLength .
-    SL.filter (summaryMatches (locSearch queryLocation)) <$>
-    FC.readCache appCalendarCache
-  withUrlRenderer
-    [hamlet|
-$if null avail
-  No appointments available in the next #{pluralN appLookaheadWeeks "week" "weeks"}.
-$else
-  $forall eachDay <- avail
-    $maybe firstSlot <- headMay eachDay
-      <h4>#{showD firstSlot}
-      <form .slot-choices>
-        <input type=hidden name=fooo value=12345>
-        $forall eachSlot <- eachDay
-          <button type=submit name=slot value=#{slotVal eachSlot}
-                  .btn.btn-default.btn-small>
-            #{showT queryTimeFmt eachSlot}
-|]
-
-postHomeR :: Handler Html
-postHomeR = do
-  q@QF.QueryForm {..} <- formSuccess =<< runFormPost QF.queryForm
-  slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
-  (widget, enctype) <- generateFormPost BF.bookingMForm
-  defaultLayout $ do
-    setTitle "Book an appointment"
-    $(widgetFile "confirm")
-
-postConfirmR :: Handler Html
-postConfirmR = do
-  b@BF.Booking {..} <- formSuccess =<< runFormPost BF.bookingMForm
-  q@QF.QueryForm {..} <- formSuccess =<< runFormPostNoToken QF.queryForm
-  slot <- maybe (invalidArgs ["Missing time slot"]) return querySlot
-  App {..} <- getYesod
-  let utcStart = tzByLabel queryTzLabel `localTimeToUTCTZ` QF.slotLocal slot
-      utcEnd = fromMinutes queryApptLength `addUTCTime` utcStart
-      ok e =
-        summaryMatches (locSearch queryLocation) e &&
-        withinEvent utcStart utcEnd e
-  SL.uncons . SL.filter ok <$> FC.readCache appCalendarCache >>= \case
-    Nothing -> invalidArgs ["No longer available?"] -- TODO should be friendlier
-    Just (e, _) -> do
-      addEvent
-        appCalendarCxt
-        (appBusyCalendarId appSettings)
-        SimpleEvent
-          { seSummary = bookName
-          , seStart = utcStart
-          , seEnd = utcEnd
-          , seDescr =
-              "Subject: " <> bookSubject <>
-              maybe "" ("\nContact: " <>) bookContact
-          , seLocation = locDescr queryLocation
-          , seAttendees = [Attendee bookName bookEmail]
-          }
-      FC.invalidateCache appCalendarCache
-      defaultLayout $ do
-        setTitle "Appointment created"
-        $(widgetFile "final")
-
-getFinalR :: Handler Html
-getFinalR = do
-  defaultLayout $ do
-    setTitle "Appointment details"
-    [whamlet|OKOK|]
--}

src/QueryForm.hs

@@ -209,16 +209,22 @@ locationChoiceField = Field {..}
       locs <- appLocations . appSettings <$> getYesod
       $(widgetFile "query-locations")
 
+zonesByContinent :: Map Text [(Text, Text)]
 zonesByContinent =
   Map.fromList $ map continent $ groupAllOn fst $ map splitTz allZones
   where
     allZones :: [TZLabelW]
     allZones = [minBound..maxBound]
 
-    splitTz :: TZLabelW -> (Text, Text)
-    splitTz = (id *** drop 1) . break (== '/') . toPathPiece
+    space '_' = ' '
+    space c = c
 
-    continent :: [(Text,Text)] -> (Text,[Text])
+    splitTz :: TZLabelW -> (Text, (Text, Text))
+    splitTz tz = (cont, (txt, omap space (drop 1 city)))
+      where (cont, city) = break (== '/') txt
+            txt = toPathPiece tz
+
+    continent :: [(Text,a)] -> (Text,[a])
     continent [] = error "zonesByContinent: Impossible"
     continent ((x,y):xys) = (x, y : map snd xys)
 
@@ -240,9 +246,9 @@ tzSelectorField = Field {..}
                   <option value=#{c} :isPrefixOf c currentTz:selected>#{c}
               $forall c <- Map.keys zonesByContinent
                 <select name=#{name}-#{c} :not(isPrefixOf c currentTz):style="display:none" *{cityAttrs}>
-                  $maybe xs <- lookup c zonesByContinent
-                    $forall x <- xs
-                      <option value=#{x} :isSuffixOf x currentTz:selected>#{x}
+                  $maybe zs <- lookup c zonesByContinent
+                    $forall (z,txt) <- zs
+                      <option value=#{toPathPiece z} :z == currentTz:selected>#{txt}
               |]
 
 qControl :: Text

src/TamperResistant.hs

-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-{-|
-Module: TamperResistant
-Description: TODO
-
-TODO
--}
-module TamperResistant
-  ( TamperResistant(..)
-  ) where
-
-import           ClassyPrelude.Yesod
-import qualified Data.Binary            as Bin
-import qualified Data.ByteString.Base64 as B64
-
--- | A wrapper that adds some characters to the PathPiece
--- representation to detect casual tampering. This isn't safe against a
--- determined opponent, so make sure there's another validity check
--- too.
-newtype TamperResistant a = TamperResistant
-  { untamper :: a
-  } deriving (Show)
-
--- | Produce an ASCII string representing a simple checksum.
-checksum :: Hashable a => a -> Text
-checksum = decodeUtf8 . B64.encode . toStrict . Bin.encode . hash
-
--- | This cannot be a character that is used in Base64.
-separator :: Char
-separator = '*'
-
-instance PathPiece a => PathPiece (TamperResistant a) where
-  toPathPiece (TamperResistant a) = checksum p <> singleton separator <> p
-    where
-      p = toPathPiece a
-  fromPathPiece = verify . (id *** drop 1) . break (== separator)
-    where
-      verify (s, p)
-        | s == checksum p = TamperResistant <$> fromPathPiece p
-        | otherwise = Nothing

templates/query-form.julius

@@ -5,10 +5,10 @@ $(function(){
 function juggleTimeZone() {
     if($(this).hasClass("tzsel") || $(this).attr("name") == "tz-con") {
         var continent = $("select[name=tz-con]").val();
-        var citySel = "select[name=tz-"+continent+"]";
+        var cityElt = $("select[name=tz-"+continent+"]");
         $(".tzsel").hide();
-        $(citySel).show();
-        $("input[name=tz]").val(continent + "/" + $(citySel).val());
+        cityElt.show();
+        $("input[name=tz]").val(cityElt.val());
     }
     sendQuery();
 }