aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/API.hs4
-rw-r--r--lib/Lucid/Forms.hs115
-rw-r--r--lib/Persist.hs3
-rw-r--r--lib/Server.hs5
-rw-r--r--lib/Server/ControlRoom.hs354
-rw-r--r--tracktrain.cabal5
6 files changed, 214 insertions, 272 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
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 253999b..ef3a1f2 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -77,8 +77,6 @@ library
, servant-swagger
, servant-docs
, servant-websockets
- , servant-lucid
- , lucid
, websockets
, lens
, persistent
@@ -94,12 +92,13 @@ library
, transformers
, extra
, vector-algorithms
+ , yesod
+ , blaze-html
hs-source-dirs: lib
exposed-modules: GTFS
, Server
, Server.GTFS_RT
, Server.ControlRoom
- , Lucid.Forms
, PersistOrphans
, Persist
, API