controlroom: replace servant/lucid with yesod

aka use something meant for webapps to write the webapp

1 files changed, 205 insertions, 149 deletions

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