controlroom: replace servant/lucid with yesod

aka use something meant for webapps to write the webapp

5 files changed, 212 insertions, 269 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 9ed2846..9400187 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -19,7 +19,7 @@ import           Servant                     (Application, FormUrlEncoded,
                                               Server, err401, err404, type (:>))
 import           Servant.API                 (Capture, Get, JSON, NoContent,
                                               PlainText, Post, QueryParam,
-                                              ReqBody, type (:<|>) ((:<|>)))
+                                              ReqBody, type (:<|>) ((:<|>)), Raw)
 import           Servant.API.WebSocket       (WebSocket)
 import           Servant.GTFS.Realtime       (Proto)
 import           Servant.Swagger             (HasSwagger (..))
@@ -69,7 +69,7 @@ type AdminAPI =
 -- documented, which would be silly and way to verbose.
 type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
   :<|> API
-  :<|> "cr" :> ControlRoomAPI
+  :<|> "cr" :> Raw
 
 
 -- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs
deleted file mode 100644
index 918c942..0000000
--- a/lib/Lucid/Forms.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DefaultSignatures   #-}
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeOperators       #-}
-
-
-module Lucid.Forms ( GToHtmlForm(..)
-                   , GToHtmlFormInput(..)
-                   , ToHtmlForm(..)
-                   , ToHtmlFormInput(..)
-                   , HtmlFormOptions(..)
-                   ) where
-
-import           Data.Maybe           (maybeToList)
-import           Data.Proxy           (Proxy (..))
-import           Data.Text            (Text)
-import qualified Data.Text            as T
-import           Data.Time            (Day)
-import           GHC.Generics         (C1, D1, Generic (Rep), K1, Meta (..),
-                                       Rec0, S1, U1, type (:*:), type (:+:))
-import           GHC.TypeLits         (KnownSymbol, symbolVal)
-import           Lucid                (Html, HtmlT, ToHtml (toHtml), action_,
-                                       div_, for_, form_, id_, input_, label_,
-                                       method_, name_, placeholder_, type_,
-                                       value_)
-import           Lucid.Base           (relaxHtmlT)
-import           Text.ProtocolBuffers (Default (defaultValue))
-
-class GToHtmlFormInput a where
-  gtoHtmlFormInput :: Text -> Proxy (a p) -> Html ()
-
-instance (KnownSymbol name)
-  => GToHtmlFormInput (C1 (MetaCons name f s) U1) where
-  gtoHtmlFormInput group _ = do
-    input_ [type_ "radio", id_ name, value_ name, name_ group] -- need a shared name for all options here
-    label_ [for_ name] (toHtml name)
-    where name = T.pack (symbolVal (Proxy @name))
-
-instance (GToHtmlFormInput l, GToHtmlFormInput r) => GToHtmlFormInput (l :+: r) where
-  gtoHtmlFormInput group _ = do
-    gtoHtmlFormInput group (Proxy @(l _))
-    gtoHtmlFormInput group (Proxy @(r _))
-
--- | ignore constructor & type metainfo
-instance GToHtmlFormInput a => GToHtmlFormInput (D1 r a) where
-  gtoHtmlFormInput group _ = gtoHtmlFormInput group (Proxy @(a _))
-
--- | class for things which can be (single) options (i.e. a single input-tag or
--- | a group of radio buttons) in an html form
-class ToHtmlFormInput a where
-  toFormInput :: Text -> Proxy a -> Html ()
-  default toFormInput :: (GToHtmlFormInput (Rep a)) => Text -> Proxy a -> Html ()
-  toFormInput group p = gtoHtmlFormInput group (Proxy @(Rep a _))
-
-instance ToHtmlFormInput Text where
-  toFormInput name _ = input_ [type_ "text", name_ name, placeholder_ name]
-instance ToHtmlFormInput Day where
-  toFormInput name _ = input_ [type_ "text", name_ name]
-instance ToHtmlFormInput Bool where
-  toFormInput name _ = input_ [type_ "checkbox", name_ name]
-instance ToHtmlFormInput (Maybe Bool) where
-  toFormInput name _ = input_ [type_ "checkbox", name_ name]
-
-
--- | generic conversion of record data types to input forms
-class GToHtmlForm a where
-  gtoHtmlForm :: Proxy (a p) -> Html ()
-
--- | each record field is a form input
-instance (KnownSymbol name, ToHtmlFormInput a)
-  => GToHtmlForm (S1 (MetaSel (Just name) su ss ds) (Rec0 a)) where
-  gtoHtmlForm _ = toFormInput (T.pack (symbolVal (Proxy @name))) (Proxy @a)
-
--- | just chain all fields
-instance (GToHtmlForm l, GToHtmlForm r) => GToHtmlForm (l :*: r) where
-  gtoHtmlForm _ = do
-    gtoHtmlForm (Proxy @(l _))
-    gtoHtmlForm (Proxy @(r _))
-
--- | ignore constructor & type metainfo
-instance GToHtmlForm a => GToHtmlForm (D1 r a) where
-  gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _))
-instance GToHtmlForm a => GToHtmlForm (C1 r a) where
-  gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _))
-
--- | class for things which can be entered via html forms
-class ToHtmlForm a where
-  toHtmlForm :: Monad m => HtmlFormOptions -> Proxy a -> HtmlT m ()
-  default toHtmlForm :: (GToHtmlForm (Rep a), Monad m) => HtmlFormOptions -> Proxy a -> HtmlT m ()
-  toHtmlForm options = relaxHtmlT . genericToHtmlForm options
-
-data HtmlFormOptions = HtmlFormOptions
-  { formAction           :: Maybe Text
-  , formMethod           :: Text
-  , formSubmitButtonText :: Text
-  }
-
-defaultOptions ::HtmlFormOptions
-defaultOptions = HtmlFormOptions Nothing "post" "Ok"
-
-instance Default HtmlFormOptions where
-  defaultValue = defaultOptions
-
-genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html ()
-genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) =
-  form_ ((method_ formMethod) : maybeToList (fmap action_ formAction)) $ do
-    gtoHtmlForm (Proxy @(Rep a _))
-    input_ [type_ "submit", value_ formSubmitButtonText]
diff --git a/lib/Persist.hs b/lib/Persist.hs
index f42c1cc..c9c7901 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -46,7 +46,6 @@ import           Data.Time.Calendar          (Day, DayOfWeek (..))
 import           Data.Vector                 (Vector)
 import           Database.Persist.Postgresql (SqlBackend)
 import           GHC.Generics                (Generic)
-import           Lucid.Forms                 (ToHtmlFormInput)
 import           Web.PathPieces              (PathPiece)
 
 newtype Token = Token UUID
@@ -60,7 +59,7 @@ instance ToParamSchema Token where
   toParamSchema _ = toParamSchema (Proxy @String)
 
 data AmendmentStatus = Cancelled | Added
-  deriving (ToJSON, FromJSON, Generic, Show, Read, Eq, ToHtmlFormInput)
+  deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
 derivePersistField "AmendmentStatus"
 instance FromHttpApiData AmendmentStatus where
   parseUrlPiece "Cancelled" = Right Cancelled
diff --git a/lib/Server.hs b/lib/Server.hs
index cc86cd2..24f29f9 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -47,6 +47,9 @@ import           Persist
 import           Server.ControlRoom
 import           Server.GTFS_RT              (gtfsRealtimeServer)
 import           Server.Util                 (Service, ServiceM, runService)
+import Yesod (toWaiAppPlain)
+
+import System.IO.Unsafe
 
 application :: GTFS -> Pool SqlBackend -> IO Application
 application gtfs dbpool = do
@@ -65,7 +68,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
   :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
   gtfsRealtimeServer gtfs dbpool
   :<|> adminServer gtfs dbpool)
-  :<|> controlRoomServer gtfs dbpool
+  :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom "http://localhost:4000/cr" gtfs dbpool)))
   where handleStations = pure stations
         handleTimetable station maybeDay = do
           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index d7aee07..0971e79 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -10,8 +10,12 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE ViewPatterns #-}
 
-module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where
+module Server.ControlRoom (ControlRoom(..)) where
 
 import           Control.Monad               (unless, when)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
@@ -20,21 +24,6 @@ import qualified Data.Map                    as M
 import           Data.Swagger                (ToSchema (..))
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
-import           Lucid                       (Html, HtmlT, ToHtml (toHtml), a_,
-                                              action_, class_, div_, em_, for_,
-                                              form_, h1_, h2_, h3_, href_, id_,
-                                              input_, label_, li_, main_,
-                                              method_, name_, ol_, placeholder_,
-                                              type_, ul_, value_)
-import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
-                                              Get, Handler, JSON,
-                                              NoContent (..), PlainText, Post,
-                                              Proxy (Proxy), QueryParam,
-                                              QueryParam', ReqBody, Required,
-                                              ServerError, Strict, err302,
-                                              err404, errHeaders, throwError,
-                                              type (:<|>) (..), type (:>))
-import           Servant.HTML.Lucid          (HTML)
 import           Web.FormUrlEncoded          (ToForm)
 import           Web.Internal.FormUrlEncoded (Form)
 
@@ -50,10 +39,9 @@ import           Data.UUID                   (UUID)
 import qualified Data.UUID                   as UUID
 import           Database.Persist            (Entity (..), delete, entityVal,
                                               get, insert, selectList, (==.))
-import           Database.Persist.Sql        (SqlBackend)
+import           Database.Persist.Sql        (SqlBackend, PersistFieldSql,
+                                              runSqlPool)
 import           GHC.Generics                (Generic)
-import           Lucid.Forms                 (ToHtmlForm (..),
-                                              ToHtmlFormInput (..), formAction)
 import           Persist                     (AmendmentStatus,
                                               Announcement (..),
                                               EntityField (..), Key (..),
@@ -62,136 +50,204 @@ import           Persist                     (AmendmentStatus,
 import           Server.Util                 (Service, redirect)
 import           Text.ProtocolBuffers        (Default (defaultValue))
 import           Web.FormUrlEncoded          (FromForm)
-
 import           Fmt                         ((+|), (|+))
+import Yesod
+import Data.List (lookup)
+import Text.Read (readMaybe)
+import Text.Blaze.Html (ToMarkup(..))
+import qualified Data.Vector as V
+
 import           GTFS
 
-data TrainView = TrainView
-  { tvDay           :: Day
-  , tvTrip          :: Trip Deep Deep
-  , tvAnnouncements :: [Entity Announcement]
-  , tvRunning       :: Bool
-  } deriving Show
-
-type ControlRoomAPI =
-  "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
-  :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
-  :<|> "trips" :> Get '[HTML] (Map TripID (Trip Deep Deep))
-  :<|> "trip" :> Capture "tripId" TripID :> Get '[HTML] (Trip Deep Deep)
-  :<|> ControlRoomCranks
-
--- | train infra seems to involve turning lots of cranks, so here have some!
-type ControlRoomCranks =
-  "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
-  :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent
-  :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
-  :<|> "train" :> "date" :> Capture "tripId" TripID :> ReqBody '[FormUrlEncoded] TrainDateF :> Post '[PlainText] NoContent
-  :<|> "train" :> "date" :> Capture "tripId" TripID :> QueryParam' '[Required] "" TrainDateF :> Post '[PlainText] NoContent
-  :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
-  :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
-  :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
-
-data TrainAnnounceF = TrainAnnounceF
-  { taHeader  :: Text
-  , taMsg     :: Text
-  , taLogTime :: Maybe Bool
-  } deriving (Generic, ToHtmlForm, FromForm)
-
--- | TODO: can also be "normal"?
-data TrainDateF = TrainDateF
-  { tdDay    :: Day
-  , tdStatus :: AmendmentStatus
-  } deriving (Generic, ToHtmlForm, FromForm)
-
-
-controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
-controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrain :<|> handleTrips :<|> handleTrip
-  :<|> controlRoomCranks dbpool
-  where handleTrain trip day = case M.lookup trip trips of
-          Just res -> do
-            as <- runSql dbpool
-              $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
-            pure (TrainView day res as True) -- TODO: can't just assume it runs that day …
-          Nothing  -> throwError err404
-        handleTimetable maybeDay = do
-          -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
-          day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
-          pure $ (day, tripsOnDay gtfs day)
-        handleTrips = pure trips
-        handleTrip tripId = case M.lookup tripId trips of
-          Just trip -> pure trip
-          Nothing   -> throwError err404
-
-controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
-controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> handleDate :<|> handleDate :<|> undefined
-  where handleAnnounce tripID day TrainAnnounceF{..} = do
-          now <- liftIO $ getCurrentTime
-          AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
-            { announcementTrip = tripID
-            , announcementMessage = taMsg
-            , announcementHeader = taHeader
-            , announcementDay = day
-            , announcementUrl = Nothing
-            , announcementAnnouncedAt =
-              fmap (const now) taLogTime
-            }
-          redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day))
-        handleAnnounceDel uuid = do
-          ann <- runSql dbpool $ do
-            a <- get (AnnouncementKey uuid)
-            delete (AnnouncementKey uuid)
-            pure a
-          case ann of
-            Nothing -> throwError err404
-            Just Announcement{..} ->
-              redirect ("/cr/train/"+|announcementTrip|+"/"+| iso8601Show announcementDay|+"")
-        handleDate tripId TrainDateF{..} = do
-          -- TODO: check that tripId exists
-          runSql dbpool $ insert $ ScheduleAmendment tripId tdDay tdStatus
-          redirect ("/cr/train/"+|tripId|+"/"+| iso8601Show tdDay|+"")
-
-
-instance ToHtmlFormInput CalendarExceptionType
-instance ToHtmlForm CalendarDate
-
-
-instance ToHtml TrainView  where
-  toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do
-    unless running $ do
-      div_ [class_ "warning"] "Warning: Trip not running on this day!"
-
-    h2_ "Announcements"
-    ul_ $ do
-      unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do
-        li_ $ do
-          em_ (toHtml announcementHeader); ": "; toHtml announcementMessage
-          " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete"
-      li_ $ do
-        "Add Announcement:"
-        toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
-          (Proxy @TrainAnnounceF)
-
-    h2_ "Stops"
-    ol_ $ forM_ tripStops $ \Stop{..} -> do
-      div_ (toHtml (stationName stopStation))
-
-    h2_ "Vehicle Position"
-    div_ "todo!"
-
-    h2_ "Cancellation Status"
-    a_ [href_ ("/cr/train/date/"+|tripTripID|+"?tdDate="+|iso8601Show day|+"&tdStatus=Cancelled")] "Cancel"
-
-
-instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
-  toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do
-    ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
-      a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID)
-    when (null trips) $ do
-      em_ "(none)"
-    where shownDay = T.pack (iso8601Show day)
-
--- | control room page
-crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
-crPage title content = do
-  h1_ (toHtml title)
-  main_ content
+
+data ControlRoom = ControlRoom
+  { getBaseurl :: Text
+  , getGtfs :: GTFS
+  , getPool :: Pool SqlBackend
+  }
+
+mkYesod "ControlRoom" [parseRoutes|
+/main MainR GET
+/train/#TripID/#Day TrainViewR GET
+|]
+
+instance Yesod ControlRoom where
+  approot = ApprootMaster (\cr -> getBaseurl cr)
+
+-- which backend we're using and how to run an action.
+instance YesodPersist ControlRoom where
+  type YesodPersistBackend ControlRoom = SqlBackend
+
+  runDB action = do
+    pool <- getYesod <&> getPool
+    runSqlPool action pool
+
+getMainR :: Handler Html
+getMainR = do
+  req <- getRequest
+  let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
+
+  day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
+  gtfs <- getYesod <&> getGtfs
+  let trips = tripsOnDay gtfs day
+  defaultLayout [whamlet|
+<h1>Trips on #{iso8601Show day}
+<ol>
+  $forall Trip{..} <- trips
+    <li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a>
+        : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
+|] -- TODO: display stuff
+
+getTrainViewR :: TripID -> Day -> Handler Html
+getTrainViewR trip day = do
+  GTFS{..} <- getYesod <&> getGtfs
+  case M.lookup trip trips of
+    Nothing -> notFound
+    Just res@Trip{..} -> do
+      anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
+      defaultLayout [whamlet|
+<h1>#{tripTripID} on #{iso8601Show day}
+<h2>Announcements
+<ul>
+  $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
+    <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="">delete</a>
+  $if null anns
+    <li><em>(none)</em>
+  <li><a href="">Add Announcement</a>
+<h2>Stops
+<ol>
+  $forall Stop{..} <- tripStops
+    <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
+
+<h2>Vehicle Position
+<div> Todo!
+|]
+
+
+
+instance ToMarkup Time where
+  toMarkup time =
+    toMarkup (show time)
+
+-- type ControlRoomAPI =
+--   "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
+--   :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
+--   :<|> "trips" :> Get '[HTML] (Map TripID (Trip Deep Deep))
+--   :<|> "trip" :> Capture "tripId" TripID :> Get '[HTML] (Trip Deep Deep)
+--   :<|> ControlRoomCranks
+
+-- -- | train infra seems to involve turning lots of cranks, so here have some!
+-- type ControlRoomCranks =
+--   "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+--   :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent
+--   :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
+--   :<|> "train" :> "date" :> Capture "tripId" TripID :> ReqBody '[FormUrlEncoded] TrainDateF :> Post '[PlainText] NoContent
+--   :<|> "train" :> "date" :> Capture "tripId" TripID :> QueryParam' '[Required] "" TrainDateF :> Post '[PlainText] NoContent
+--   :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+--   :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
+--   :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
+
+-- data TrainAnnounceF = TrainAnnounceF
+--   { taHeader  :: Text
+--   , taMsg     :: Text
+--   , taLogTime :: Maybe Bool
+--   } deriving (Generic, ToHtmlForm, FromForm)
+
+-- -- | TODO: can also be "normal"?
+-- data TrainDateF = TrainDateF
+--   { tdDay    :: Day
+--   , tdStatus :: AmendmentStatus
+--   } deriving (Generic, ToHtmlForm, FromForm)
+
+
+-- controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
+-- controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrain :<|> handleTrips :<|> handleTrip
+--   :<|> controlRoomCranks dbpool
+--   where handleTrain trip day = case M.lookup trip trips of
+--           Just res -> do
+--             as <- runSql dbpool
+--               $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
+--             pure (TrainView day res as True) -- TODO: can't just assume it runs that day …
+--           Nothing  -> throwError err404
+--         handleTimetable maybeDay = do
+--           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
+--           day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
+--           pure $ (day, tripsOnDay gtfs day)
+--         handleTrips = pure trips
+--         handleTrip tripId = case M.lookup tripId trips of
+--           Just trip -> pure trip
+--           Nothing   -> throwError err404
+
+-- controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
+-- controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> handleDate :<|> handleDate :<|> undefined
+--   where handleAnnounce tripID day TrainAnnounceF{..} = do
+--           now <- liftIO $ getCurrentTime
+--           AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
+--             { announcementTrip = tripID
+--             , announcementMessage = taMsg
+--             , announcementHeader = taHeader
+--             , announcementDay = day
+--             , announcementUrl = Nothing
+--             , announcementAnnouncedAt =
+--               fmap (const now) taLogTime
+--             }
+--           redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day))
+--         handleAnnounceDel uuid = do
+--           ann <- runSql dbpool $ do
+--             a <- get (AnnouncementKey uuid)
+--             delete (AnnouncementKey uuid)
+--             pure a
+--           case ann of
+--             Nothing -> throwError err404
+--             Just Announcement{..} ->
+--               redirect ("/cr/train/"+|announcementTrip|+"/"+| iso8601Show announcementDay|+"")
+--         handleDate tripId TrainDateF{..} = do
+--           -- TODO: check that tripId exists
+--           runSql dbpool $ insert $ ScheduleAmendment tripId tdDay tdStatus
+--           redirect ("/cr/train/"+|tripId|+"/"+| iso8601Show tdDay|+"")
+
+
+-- instance ToHtmlFormInput CalendarExceptionType
+-- instance ToHtmlForm CalendarDate
+
+
+-- instance ToHtml TrainView  where
+--   toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do
+--     unless running $ do
+--       div_ [class_ "warning"] "Warning: Trip not running on this day!"
+
+--     h2_ "Announcements"
+--     ul_ $ do
+--       unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do
+--         li_ $ do
+--           em_ (toHtml announcementHeader); ": "; toHtml announcementMessage
+--           " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete"
+--       li_ $ do
+--         "Add Announcement:"
+--         toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
+--           (Proxy @TrainAnnounceF)
+
+--     h2_ "Stops"
+--     ol_ $ forM_ tripStops $ \Stop{..} -> do
+--       div_ (toHtml (stationName stopStation))
+
+--     h2_ "Vehicle Position"
+--     div_ "todo!"
+
+--     h2_ "Cancellation Status"
+--     a_ [href_ ("/cr/train/date/"+|tripTripID|+"?tdDate="+|iso8601Show day|+"&tdStatus=Cancelled")] "Cancel"
+
+
+-- instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
+--   toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do
+--     ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
+--       a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID)
+--     when (null trips) $ do
+--       em_ "(none)"
+--     where shownDay = T.pack (iso8601Show day)
+
+-- -- | control room page
+-- crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
+-- crPage title content = do
+--   h1_ (toHtml title)
+--   main_ content