Skip to content

GitLab

Commit bdb06417 authored by Christopher League's avatar Christopher League 🖥
Browse files

Clean up and simplify

parent 31d061c1
Hide whitespace changes
Inline Side-by-side
Showing with 60 additions and 248 deletions
package.yaml
View file @ bdb06417
......@@ -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
View file @ bdb06417
......@@ -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 deleted 100644 → 0
View file @ 31d061c1
{-# 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 deleted 100644 → 0
View file @ 31d061c1
{-# 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
View file @ bdb06417
......@@ -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 deleted 100644 → 0
View file @ 31d061c1
{-# 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
View file @ bdb06417
......@@ -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();
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment