gistfile1.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-}
module Main (main) where

import Bootstrap
import Control.Concurrent
import Control.Lens hiding (children)
import Control.Monad ((>=>), void)
import Data.Constraint (Dict(..))
import Data.Function (on)
import Data.String
import Data.Ix
import Data.List (groupBy)
import Data.Maybe
import Data.Monoid
import Data.Singletons (fromSing)
import Data.Time
import Data.Traversable
import Francium
import GHCJS.Foreign
import GHCJS.Marshal
import GHCJS.Types
import SocketIO
import System.Locale

import qualified Text.Email.Validate as EmailValidate
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Francium.HTML as H
import qualified Fynder.Types.Misc as Fynder
import qualified Fynder.Types.Model.Business as Business
import qualified Fynder.Types.Model.Business as Fynder
import qualified Fynder.Types.Model.Class as Class
import qualified Fynder.Types.Model.Class as Fynder
import qualified Fynder.Types.Model.ClassType as ClassType
import qualified Fynder.Types.Model.ClassType as Fynder
import qualified Fynder.Types.Model.Id as Fynder
import qualified Fynder.Types.Model.Location as Location
import qualified Fynder.Types.Model.UserProfileBusinessStaff as UPBS
import qualified Metronome.JSON as Metronome
import qualified Metronome.Router as API
import qualified Metronome.SocketIO.JSON as Metronome
import qualified Metronome.SocketIO.Types as Metronome
import qualified XHRIO as XHR
import qualified Web.Routes as WebRoutes

--------------------------------------------------------------------------------
bool :: a -> a -> Bool -> a
bool f _ False = f
bool _ t True = t

--------------------------------------------------------------------------------
apiURL :: API.Route -> String
apiURL route =
    let (ps, params) = WebRoutes.formatPathSegments API.site route
    in apiPrefix <> "api" <> Text.unpack (WebRoutes.encodePathInfo ps params)

--------------------------------------------------------------------------------
-- None of this belongs in this project :)
instance ToJSString Fynder.Texty where
  toJSString = toJSString . review Fynder.texty

instance ToJSString Fynder.URI where
  toJSString = toJSString . review Fynder._URI

--------------------------------------------------------------------------------
apiPrefix :: IsString a => a
#ifdef API_PREFIX
apiPrefix = API_PREFIX
#else
apiPrefix = "http://localhost:8000/"
#endif

--------------------------------------------------------------------------------
requested :: Metronome.SubscriptionChannel -> JSString
requested c = toJSString (Metronome.channelName c <> ".requested")


--------------------------------------------------------------------------------
-- Run the whole network. We begin at 'loginPage'.
main :: IO ()
main = react $ mdo
  sio <- liftIO (socketIONew apiPrefix)
  liftIOLater (socketIOOpen sio)

  socketConnected <- set mapped sio <$> socketIOEvent sio "connect"

  scheduleChanged <- subscribeChanged socketConnected Metronome.SSchedulesChannel
  businessesChanged <- subscribeChanged socketConnected Metronome.SBusinessesChannel

  (filterBarUI, scheduleFilter) <- mkScheduleFilter (stepper [] businessesChanged)

  do
    let resubscribe = toJSRef >=> socketIOEmit sio (requested Metronome.SchedulesChannel)
    scheduleFilterChanged <- changes scheduleFilter
    reactimate' $ fmap resubscribe <$> scheduleFilterChanged
    reactimate $ resubscribe <$> scheduleFilter <@ socketConnected

  reactimate $
    socketConnected <&> \_ -> do
      obj <- toJSRef (Aeson.Array mempty)
      socketIOEmit sio (requested Metronome.BusinessesChannel) obj

  let focussedClass = stepper Nothing (spFocusChanged schedulePage)
  schedulePage <-
    anonymousSchedule (stepper [] scheduleChanged)
                      focussedClass
                      filterBarUI

  reactimate $
    spIdentityChanged schedulePage <&> \xFynderSession -> do
      socketIODisconnect sio
      socketIOSetQueryParameter sio
                                "x-fynder-session"
                                (toJSString ((unXFynderSession <$> xFynderSession) ^. _Just))
      socketIOReconnect sio

  return (spContent schedulePage)

--------------------------------------------------------------------------------
data SchedulePage behavior event = SchedulePage
  { spContent :: behavior HTML
  , spFocusChanged :: event (Maybe Fynder.ClassId)
  , spIdentityChanged :: event (Maybe XFynderSession)}

--------------------------------------------------------------------------------
trimSchedule
  :: SchedulePage (Behavior t) (Event t)
  -> Moment t (SchedulePage (AnyMoment Behavior) (AnyMoment Event))
trimSchedule SchedulePage{..} = do
  SchedulePage <$> trim spContent <*> trim spFocusChanged <*> trim spIdentityChanged

--------------------------------------------------------------------------------
switchSchedule
  :: SchedulePage (Behavior t) (Event t)
  -> Event t (SchedulePage (AnyMoment Behavior) (AnyMoment Event))
  -> SchedulePage (Behavior t) (Event t)
switchSchedule now later =
  SchedulePage { spContent = spContent now `switchB` (spContent <$> later)
               , spFocusChanged = spFocusChanged now `union` switchE (spFocusChanged <$> later)
               , spIdentityChanged = spIdentityChanged now `union` switchE (spIdentityChanged <$> later)
               }

--------------------------------------------------------------------------------
type Schedule t =
       Behavior t [Metronome.WithBusiness Metronome.BookableCustomerClass] ->
       Behavior t (Maybe Fynder.ClassId) ->
       Behavior t HTML ->
       Moment t (SchedulePage (Behavior t) (Event t))

--------------------------------------------------------------------------------
anonymousSchedule :: Frameworks t => Schedule t
anonymousSchedule schedule focussedClass filterBarUI = mdo
  presentLoginModal <- newDOMEvent

  let loginButton = H.with H.button (H.onClick presentLoginModal) ["Login"]

  baseScheduleView <-
    mkScheduleView loginButton
                   schedule
                   focussedClass
                   filterBarUI
                   (const (H.with H.button (do H.classes .= ["booked-false"]
                                               H.onClick presentLoginModal)
                                  ["Book"]))

  loginModalReady <- execute $
    domEvent presentLoginModal <&> \_ ->
    FrameworksMoment (trimLoginModal =<< mkLoginModal)

  let
    loginComplete = switchE (lmLoginComplete <$> loginModalReady)

    modal = switchB (pure Nothing) ((fmap Just . lmUI <$> loginModalReady) `union`
                                    (pure Nothing <$ switchE (lmModalClosed <$> loginModalReady)))

    schedulePage = baseScheduleView { spContent = overlayModal <$> spContent baseScheduleView <*> modal
                                    , spIdentityChanged = Just <$> loginComplete
                                    }

  loggedInScheduleNetworkReady <- do
    futureSchedule <- trim schedule
    futureCurrentFocus <- trim focussedClass
    futureFilterBarUI <- trim filterBarUI
    execute $
      loginComplete <&> \xFynderSession ->
      FrameworksMoment $ do
        schedule' <- now futureSchedule
        filterBarUI' <- now futureFilterBarUI
        currentFocus' <- now futureCurrentFocus
        trimSchedule =<< userSchedule xFynderSession schedule' currentFocus' filterBarUI'

  return (schedulePage `switchSchedule` loggedInScheduleNetworkReady)

  where
  overlayModal content Nothing = content
  overlayModal content (Just modal) =
    H.into H.div
           [H.div & H.classes .~ ["modal-backdrop"]
           ,modal
           ,content]

--------------------------------------------------------------------------------
userSchedule :: Frameworks t => XFynderSession -> Schedule t
userSchedule (XFynderSession xFynderSession) schedule focussedClass filterBarUI = do
  (userLoggedOut, logoutButton) <- over _2 (H.into ?? ["Logout"]) <$> reactiveButton

  bookingRequested <- newDOMEvent
  cancelRequested <- newDOMEvent

  reactimate $
    let book c = void $ forkIO $ do
          void $ XHR.request XHR.Request
               { XHR.rqWithCredentials = True
               , XHR.rqURL = apiURL (API.MyCustomerProfile ((Fynder.key . Metronome.wbBusiness) c))
               , XHR.rqMethod = XHR.PUT
               , XHR.rqHeaders = [("X-Fynder-Session", xFynderSession)]
               , XHR.rqPayload = Nothing
               }

          payload <- toJSRef $ Aeson.object [ "classId" Aeson..= (Fynder.key ((Metronome.classClass . Metronome.customerClass . Metronome.bccClass . Metronome.wbEntity) c)) ]
          void $ XHR.request
               XHR.Request { XHR.rqWithCredentials = True
                           , XHR.rqURL = apiURL API.MyBookings
                           , XHR.rqMethod = XHR.POST
                           , XHR.rqHeaders = [("X-Fynder-Session", xFynderSession)]
                           , XHR.rqPayload = Just (jsonStringify payload)}
    in book <$> domEvent bookingRequested

  reactimate $
    let cancel c = void $ forkIO $ void $ XHR.request
          XHR.Request { XHR.rqWithCredentials = True
                      , XHR.rqURL = apiURL (API.MyBooking (Fynder.key ((Metronome.classClass . Metronome.customerClass . Metronome.bccClass . Metronome.wbEntity) c)))
                      , XHR.rqMethod = XHR.DELETE
                      , XHR.rqHeaders = [("X-Fynder-Session", xFynderSession)]
                      , XHR.rqPayload = Nothing}
    in cancel <$> domEvent cancelRequested

  baseSchedulePage <- mkScheduleView logoutButton schedule focussedClass filterBarUI (mkBookButton bookingRequested cancelRequested)
  let schedulePage = baseSchedulePage { spIdentityChanged = Nothing <$ userLoggedOut }

  anonymousScheduleNetworkReady <- do
    futureSchedule <- trim schedule
    futureFocussedClass <- trim focussedClass
    futureFilterBarUI <- trim filterBarUI
    execute $
      userLoggedOut <&> \_ ->
      FrameworksMoment $ do
        schedule' <- now futureSchedule
        focussedClass' <- now futureFocussedClass
        filterBarUI' <- now futureFilterBarUI
        trimSchedule =<< anonymousSchedule schedule' focussedClass' filterBarUI'

  return (schedulePage `switchSchedule` anonymousScheduleNetworkReady)

  where
  mkBookButton book cancel c =
    let (label, cssClass, handler) =
          case (Metronome.customerClassBookingStatus . Metronome.bccClass . Metronome.wbEntity) c of
            Just Metronome.CustomerClassBookingBooked -> ("Cancel", "booked-true", cancel)
            _ -> ("Book", "booked-false", book)
    in H.with H.button (do H.classes .= [cssClass]
                           H.onClick (lmap (const c) handler))
              [label]

--------------------------------------------------------------------------------
newtype XFynderSession = XFynderSession { unXFynderSession :: String }
  deriving (Show)


--------------------------------------------------------------------------------
data LoginModal behavior event = LoginModal
  { lmUI :: behavior HTML
  , lmLoginComplete :: event XFynderSession
  , lmModalClosed :: event ()}

--------------------------------------------------------------------------------
trimLoginModal
  :: LoginModal (Behavior t) (Event t)
  -> Moment t (LoginModal (AnyMoment Behavior) (AnyMoment Event))
trimLoginModal (LoginModal x y z) = LoginModal <$> trim x <*> trim y <*> trim z

--------------------------------------------------------------------------------
mkLoginModal :: Frameworks t => Moment t (LoginModal (Behavior t) (Event t))
mkLoginModal = do
  (email, emailInput) <- reactiveInput
  (password, passwordInput) <- reactiveInput

  let emailValid = EmailValidate.isValid . Text.encodeUtf8 . Text.pack <$> facts email
      passwordValid = (> 5) . length <$> facts password
      submissionValid = (&&) <$> emailValid <*> passwordValid

  (login, loginButton) <- reactiveButton
  (closeModal, closeButton) <- reactiveButton

  (onLoginSuccess, fireOnSuccess) <- newEvent

  beginFacebookLogin <- newDOMEvent

  reactimate $
    performPasswordLogin fireOnSuccess
      <$> facts email
      <*> facts password
      <@ (whenE submissionValid login)

  let ui = mkUI <$> (validatingInput "Email"
                       <$> emailInput
                       <*> emailValid)
                <*> (validatingInput "Password"
                       <$> (passwordInput <&> H.attrs . at "type" ?~ "password")
                       <*> passwordValid)
                <*> (bool (H.attrs . at "disabled" ?~ "disabled") id <$> submissionValid <*> pure loginButton)
                <*> pure beginFacebookLogin
                <*> pure closeButton

  return (LoginModal ui onLoginSuccess closeModal)

  where
  performPasswordLogin onSuccess email password = void $ forkIO $ do
    payload <- jsonStringify <$> toJSRef (Aeson.object [ "email" Aeson..= email, "password" Aeson..= password ])
    res <- XHR.request XHR.Request
      { XHR.rqWithCredentials = True
      , XHR.rqURL = apiURL API.PasswordLogin
      , XHR.rqMethod = XHR.POST
      , XHR.rqHeaders = []
      , XHR.rqPayload = Just payload
      }
    if (200, 399) `inRange` XHR.resStatus res
      then case lookup "X-Fynder-Session" (XHR.resHeaders res) of
             Just x -> onSuccess (XFynderSession x)
             Nothing -> putStrLn "Login didn't deliver X-Fynder-Session"
      else putStrLn "Login failed"

  validatingInput placeholder control isValid =
    formGroup (
     (formControl control & H.attrs . at "placeholder" ?~ placeholder) :
     if isValid
       then []
       else [H.with H.span (H.classes .= ["input-group-addon"])
                    [H.span & H.classes .~ ["glyphicon" ,"glyphicon-warning-sign"]]])

  formControl e = e & H.classes .~ ["form-control"]

  mkUI email password loginButton beginFacebookLogin closeButton =
    H.with H.div
           (H.classes .= ["modal"])
           [H.with H.div
                   (H.classes .= ["modal-dialog"])
                   [H.with closeButton
                           (H.classes .= ["close"])
                           ["close"]
                   ,H.with H.div
                           (H.classes .= ["modal-content"])
                           [H.with H.div
                                   (H.classes .= ["register-modal"])
                                   [H.with H.div
                                           (H.classes .= ["modal-header"])
                                           [H.with H.h4
                                                   (H.classes .= ["modal-title"])
                                                   ["Sign in to book classes"]]
                                   ,H.with H.div
                                           (H.classes .= ["modal-body"])
                                           [H.with H.form
                                                   (H.attrs . at "role" ?= "form")
                                                   [H.into H.fieldset
                                                           [H.with H.button
                                                                   (do H.attrs . at "id" ?= "login-facebook"
                                                                       H.attrs . at "disabled" ?= "disabled"
                                                                       H.onClick beginFacebookLogin)
                                                                   ["Sign in with Facebook"]
                                                           ,email
                                                           ,password
                                                           ,formGroup [H.with loginButton
                                                                              (H.classes .= ["login"])
                                                                              ["Sign In"]]]]]]]]]

  formGroup children =
    H.with H.div
           (H.classes .= ["form-group"])
           [H.with H.div
                   (H.classes .= ["input-group","col-xs-12"])
                   children]

--------------------------------------------------------------------------------
reactiveInput :: Frameworks t => Moment t (Tidings t String, Behavior t HTML)
reactiveInput = do
  inputChanged <- newDOMEvent

  let knownInput = stepper "" (domEvent inputChanged)
      ui = knownInput <&> \txt ->
        H.input &~ (do H.attrs . at "value" ?= toJSString txt
                       H.onInput inputChanged)

  return (tidings knownInput (domEvent inputChanged), ui)

--------------------------------------------------------------------------------
reactiveButton :: Frameworks t => Moment t (Event t (), HTML)
reactiveButton = do
  click <- newDOMEvent
  let ui = H.button &~ H.onClick click
  return (domEvent click, ui)

--------------------------------------------------------------------------------
classView
  :: DOMEvent t () ()
  -> (Metronome.WithBusiness Metronome.BookableCustomerClass -> HTML)
  -> Metronome.WithBusiness Metronome.BookableCustomerClass
  -> HTML
classView goBack mkBookButton c =
  let
    avatar src =
      H.img & H.classes .~ ["avatar"]
            & H.attrs . at "src" ?~ toJSString (maybe "" (review Fynder._URI) src)

    classTypeSection =
      Just $
      H.with H.div
             (H.classes .= ["summary","class-type"])
             [avatar (c ^. ClassType.picture)
             ,H.into H.h3 [H.text (c ^. ClassType.title)]
             ,H.text (maybe ""
                            (review Fynder.texty)
                            (c ^. ClassType.description))]

    trainerSection =
      (Metronome.classTrainer . Metronome.customerClass . Metronome.bccClass . Metronome.wbEntity) c <&>
      \trainer ->
        H.with H.div
               (H.classes .= ["summary","trainer"])
               [avatar (trainer ^. UPBS.picture)
               ,H.into H.h3 [H.text (trainer ^. UPBS.name)]
               ,H.text (maybe ""
                              (review Fynder.texty)
                              (trainer ^. UPBS.description))]

    googleMapsApiKey = "whoops"

    address = c ^. Location.address . re Fynder.texty

  in H.into H.div
            [H.with H.nav
                    (H.attrs . at "role" ?= "navigation")
                    [H.with H.div
                            (H.classes .= ["toolbar"])
                            [H.with H.button
                                    (do H.classes .= ["back"]
                                        H.onClick goBack)
                                    ["Back"]]]
            ,H.with H.div
                    (H.classes .= ["class-detail"])
                    [H.into H.div
                            [H.iframe &~
                             do H.attrs . at "frameborder" ?= "0"
                                H.attrs . at "style" ?= "border: 0; width: 100%;"
                                H.attrs . at "src" ?=
                                  toJSString
                                    ("https://www.google.com/maps/embed/v1/search?key=" <>
                                     googleMapsApiKey <> "&q=" <> address)]
                    ,H.with H.div
                            (H.classes .= ["classes"])
                            [classRow c mkBookButton]
                    ,H.into container (catMaybes [classTypeSection,trainerSection])]]


--------------------------------------------------------------------------------
mkScheduleView
  :: Frameworks t
  => HTML
  -> Behavior t [Metronome.WithBusiness Metronome.BookableCustomerClass]
  -> Behavior t (Maybe Fynder.ClassId) -- Possible current focus
  -> Behavior t HTML
  -> (Metronome.WithBusiness Metronome.BookableCustomerClass -> HTML)
  -> Moment t (SchedulePage (Behavior t) (Event t))
mkScheduleView authPanel schedule focussedClassId filterBarUI mkBookButton = do
  classFocusRequested <- newDOMEvent
  returnToSchedule <- newDOMEvent

  let focussedClass =
        (\mc classes ->
           case mc of
             Just cId ->
               listToMaybe
                 (filter (\c ->
                            (Fynder.key . Metronome.classClass . Metronome.customerClass .
                                                                 Metronome.bccClass .
                                                                 Metronome.wbEntity) c ==
                            cId)
                         classes)
             Nothing -> Nothing) <$>
        focussedClassId <*>
        schedule

  return SchedulePage
    { spContent =
        let
          scheduleView =
            let navBar = filterBarUI <&> \filterBarUIInstant ->
                  H.with H.nav
                         (H.attrs . at "role" ?= "navigation")
                         [H.with H.div
                                 (H.classes .= ["toolbar"])
                                 [authPanel]
                         ,filterBarUIInstant]
                mkSchedule schedule_ =
                  H.with H.div
                         (H.classes .= ["schedules"])
                         [case schedule_ of
                            [] -> emptySchedule
                            _ -> H.with H.div
                                       (H.classes .= ["classes"])
                                       (dayRow classFocusRequested <$>
                                          groupBy ((==) `on` (utctDay . view Class.startTs))
                                                  schedule_)]

            in (H.into H.div) <$> sequenceA [navBar, mkSchedule <$> schedule]

        in fromMaybe <$> scheduleView
                     <*> (fmap (classView returnToSchedule mkBookButton) <$> focussedClass)

    , spFocusChanged = (Just <$> domEvent classFocusRequested) `union`
                       (Nothing <$ domEvent returnToSchedule)

    , spIdentityChanged = never
    }

  where
  emptySchedule =
    H.with H.div
           (H.classes .= ["no-events"])
           ["There are no events here right now."]

  dayRow fireClassSelected day =
    let dayHeader =
          H.into row
                 [H.with H.div
                         (H.classes .= ["date-header"])
                         [H.text (formatTime defaultTimeLocale
                                             "%A %e %B"
                                             (Prelude.head day ^. Class.startTs))]]
        clickableClassRow c =
          let handler =
                lmap (const ((Fynder.key . Metronome.classClass .
                                           Metronome.customerClass .
                                           Metronome.bccClass . Metronome.wbEntity) c))
                     fireClassSelected
          in H.with row
                    (H.onClick handler)
                    [classRow c mkBookButton]
    in H.into containerFluid
              (dayHeader : (clickableClassRow <$> day))

--------------------------------------------------------------------------------
classRow :: (Fynder.HasBusiness c, Fynder.HasClassType c, Fynder.HasClass c) => c -> (c -> HTML) -> HTML
classRow c mkBookButton =
  let rowCell cellClass t =
        H.with H.div
               (H.classes .= [cellClass])
               [H.text t]
  in H.with H.div
            (H.classes .= ["class"])
            [H.with container
                    (H.classes <>= ["time"])
                    [H.into row
                            [rowCell "start-time"
                                     (formatTime defaultTimeLocale
                                                 "%H:%M"
                                                 (c ^. Class.startTs))
                            ,rowCell "duration" (show (Class.duration c))]]
            ,H.with container
                    (H.classes <>= ["details"])
                    [H.into row
                            [rowCell "type" (c ^. ClassType.title)
                            ,H.with H.div
                                    (H.classes .= ["business"])
                                    [showBusiness c]]]
            ,H.with H.div
                    (H.classes .= ["action"])
                    [mkBookButton c]]
  where showBusiness b =
          maybe (H.text (b ^. Business.name))
                (\pic -> H.img & H.attrs . at "src" ?~ toJSString pic)
                (b ^. Business.picture)

--------------------------------------------------------------------------------
mkScheduleFilter
  :: Frameworks t
  => Behavior t [Fynder.KV Fynder.BusinessId Fynder.Business]
  -> Moment t (Behavior t HTML, Behavior t Metronome.ClassesRequestedArgs)
mkScheduleFilter businesses = mdo
  (weekNavigatorUI, weekBeginning) <- weekNavigator

  let currentBusiness = stepper Nothing currentBusinessChanged

  (filterBusiness, currentBusinessChanged) <-
    filterPopOver ((Nothing :) . map Just <$> businesses)
                  currentBusiness
                  (H.text . maybe "Business" (view (Business.name . re Fynder.texty)))

  let
    currentBusinessId = fmap Fynder.key <$> currentBusiness

    scheduleFilter =
      let mkFilterVal businessId start =
            Metronome.ClassesRequestedArgs
              start
              (daysToShow `addUTCTime` start)
              (case businessId of
                 Just bId -> Metronome.AllBusinessLocations bId
                 Nothing -> Metronome.AllBusinesses)
      in mkFilterVal <$> currentBusinessId <*> weekBeginning

    compositeUI = mkUI <$> weekNavigatorUI <*> filterBusiness

  return (compositeUI, scheduleFilter)

  where
  mkUI navigator filterBusiness =
    H.with containerFluid
           (H.classes <>= ["filterbar"])
           [H.with row
                   (H.classes <>= ["dropdowns"])
                   [filterBusiness]
           ,H.with H.div
                   (H.classes .= ["paging"])
                   [navigator]]


--------------------------------------------------------------------------------
weekNavigator :: Frameworks t => Moment t (Behavior t HTML, Behavior t UTCTime)
weekNavigator = do
  now <- liftIO getCurrentTime

  (navigateBack, backButton) <- reactiveButton
  (navigateForward, forwardButton) <- reactiveButton

  let
    weekStart = accumB now (((negate daysToShow `addUTCTime`) <$ navigateBack) `union`
                            ((daysToShow `addUTCTime`) <$ navigateForward))

    ui =
      weekStart <&> \ws ->
        H.into H.div
               [H.with backButton
                       (H.classes .= ["back"])
                       ["Back"]
               ,H.with H.h2
                       (H.classes .= ["date"])
                       [H.text (toJSString (formatTime defaultTimeLocale "%a %e %b" ws))
                       ," - "
                       ,H.text (formatTime defaultTimeLocale
                                           "%a %e %b"
                                           (daysToShow `addUTCTime` ws))]
               ,H.with forwardButton
                       (H.classes .= ["forward"])
                       ["Forward"]]

  return (ui, weekStart)

--------------------------------------------------------------------------------
socketIOEvent :: Frameworks t => SocketIO -> JSString -> Moment t (Event t (JSRef a))
socketIOEvent sio eventName = fromAddHandler $ AddHandler $ \h -> do
  callback <- syncCallback1 AlwaysRetain True h
  socketIOOn sio eventName callback
  return (return ())

--------------------------------------------------------------------------------
daysToShow :: NominalDiffTime
daysToShow = 60 * 60 * 24 * 2

--------------------------------------------------------------------------------
filterPopOver
  :: Frameworks t
  => Behavior t [a]
  -> Behavior t a
  -> (a -> HTML)
  -> Moment t (Behavior t HTML, Event t a)
filterPopOver optionsB currentB render = do
  selectionChanged <- newDOMEvent

  let
    mkUI options currentSelection =
      H.with H.div
             (H.classes .= ["btn-group","btn-group-justified"])
             [H.with H.div
                     (H.classes .= ["filter-dropdown","btn-group","location"])
                     [H.with H.button
                             (do H.classes .= ["dropdown-toggle"]
                                 H.attrs . at "data-toggle" ?= "dropdown")
                             [render currentSelection]
                     ,H.with H.ul
                             (do H.classes .= ["dropdown-menu"]
                                 H.attrs . at "role" ?= "menu")
                             (options <&>
                              \o ->
                                let handler = lmap (const o) selectionChanged
                                in H.with H.li
                                          (do H.classes .= ["item"]
                                              H.onClick handler)
                                          [render o])]]
    ui = mkUI <$> optionsB <*> currentB

  return (ui,domEvent selectionChanged)

--------------------------------------------------------------------------------
subscribeChanged
  :: (Frameworks t, Aeson.FromJSON (Metronome.SubscriptionResponse channel))
  => Event t SocketIO
  -> Metronome.SSubscriptionChannel channel
  -> Moment t (Event t (Metronome.SubscriptionResponse channel))
subscribeChanged socketConnected ev = fmap switchE $ execute $
  socketConnected <&> \sio -> FrameworksMoment $ do
    evOccured <- fromAddHandler $ AddHandler $ \h -> do
      callback <- syncCallback1 AlwaysRetain True $ \ref -> do
        Just jsonAST <- fromJSRef ref
        case Metronome.witnessSerializableChannel ev of
          Dict ->
            case Aeson.fromJSON jsonAST of
              Aeson.Success x -> h x
              Aeson.Error e -> putStrLn $ "Failed to decode: " ++ show e

      socketIOOn sio (toJSString (Metronome.channelName (fromSing ev) <> ".changed")) callback
      return (return ())

    trim evOccured

--------------------------------------------------------------------------------
#ifndef HLINT

foreign import javascript safe
  "JSON.stringify($1)" jsonStringify :: JSRef a -> JSString

#endif