control room: translations & form input

still basic, but works pretty well overall

2 files changed, 157 insertions, 196 deletions

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 0971e79..0e3f01e 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,89 +1,98 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DefaultSignatures   #-}
-{-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeOperators       #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DefaultSignatures     #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ViewPatterns          #-}
 
 module Server.ControlRoom (ControlRoom(..)) where
 
-import           Control.Monad               (unless, when)
-import           Control.Monad.IO.Class      (MonadIO (liftIO))
-import qualified Data.ByteString.Char8       as C8
-import qualified Data.Map                    as M
-import           Data.Swagger                (ToSchema (..))
-import           Data.Text                   (Text)
-import qualified Data.Text                   as T
-import           Web.FormUrlEncoded          (ToForm)
-import           Web.Internal.FormUrlEncoded (Form)
-
-import           Control.Monad               (forM_)
-import           Control.Monad.Extra         (maybeM, whenM)
-import           Data.Functor                ((<&>))
-import           Data.Map                    (Map)
-import           Data.Pool                   (Pool)
-import           Data.Time                   (getCurrentTime, utctDay)
-import           Data.Time.Calendar          (Day)
-import           Data.Time.Format.ISO8601    (iso8601Show)
-import           Data.UUID                   (UUID)
-import qualified Data.UUID                   as UUID
-import           Database.Persist            (Entity (..), delete, entityVal,
-                                              get, insert, selectList, (==.))
-import           Database.Persist.Sql        (SqlBackend, PersistFieldSql,
-                                              runSqlPool)
-import           GHC.Generics                (Generic)
-import           Persist                     (AmendmentStatus,
-                                              Announcement (..),
-                                              EntityField (..), Key (..),
-                                              ScheduleAmendment (ScheduleAmendment),
-                                              runSql)
-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           Control.Monad            (forM_)
+import           Control.Monad.Extra      (maybeM)
+import           Control.Monad.IO.Class   (MonadIO (liftIO))
+import qualified Data.ByteString.Char8    as C8
+import           Data.Functor             ((<&>))
+import           Data.List                (lookup)
+import           Data.Map                 (Map)
+import qualified Data.Map                 as M
+import           Data.Pool                (Pool)
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time                (getCurrentTime, utctDay)
+import           Data.Time.Calendar       (Day)
+import           Data.Time.Format.ISO8601 (iso8601Show)
+import           Data.UUID                (UUID)
+import qualified Data.UUID                as UUID
+import qualified Data.Vector              as V
+import           Database.Persist         (Entity (..), delete, entityVal, get,
+                                           insert, selectList, (==.))
+import           Database.Persist.Sql     (PersistFieldSql, SqlBackend,
+                                           runSqlPool)
+import           Fmt                      ((+|), (|+))
+import           GHC.Generics             (Generic)
+import           Persist                  (AmendmentStatus, Announcement (..),
+                                           EntityField (..), Key (..),
+                                           ScheduleAmendment (ScheduleAmendment),
+                                           runSql)
+import           Server.Util              (Service)
+import           Text.Blaze.Html          (ToMarkup (..))
+import           Text.ProtocolBuffers     (Default (defaultValue))
+import           Text.Read                (readMaybe)
+import           Yesod
+import           Yesod.Form
 
 import           GTFS
 
 
 data ControlRoom = ControlRoom
   { getBaseurl :: Text
-  , getGtfs :: GTFS
-  , getPool :: Pool SqlBackend
+  , getGtfs    :: GTFS
+  , getPool    :: Pool SqlBackend
   }
 
+mkMessage "ControlRoom" "messages" "en"
+
 mkYesod "ControlRoom" [parseRoutes|
-/main MainR GET
-/train/#TripID/#Day TrainViewR GET
+/ RootR GET
+/trains TrainsR GET
+/train/id/#TripID/#Day TrainViewR GET
+/train/announce/#TripID/#Day AnnounceR POST
+/train/del-announce/#UUID DelAnnounceR GET
+/trips TripsViewR GET
+/trip/#TripID TripViewR GET
 |]
 
 instance Yesod ControlRoom where
   approot = ApprootMaster (\cr -> getBaseurl cr)
 
+instance RenderMessage ControlRoom FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
 -- 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
+
+
+getRootR :: Handler Html
+getRootR = redirect (TrainsR)
+
+getTrainsR :: Handler Html
+getTrainsR = do
   req <- getRequest
   let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
 
@@ -91,30 +100,34 @@ getMainR = do
   gtfs <- getYesod <&> getGtfs
   let trips = tripsOnDay gtfs day
   defaultLayout [whamlet|
-<h1>Trips on #{iso8601Show day}
+<h1>Trains 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
+  (widget, enctype) <- generateFormPost (announceForm day trip)
   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
+<h1><a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{iso8601Show day}</a>
+<h2>_{MsgAnnouncements}
 <ul>
   $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
-    <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="">delete</a>
+    <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">delete</a>
   $if null anns
-    <li><em>(none)</em>
-  <li><a href="">Add Announcement</a>
-<h2>Stops
+    <li><em>(_{MsgNone})</em>
+<h3>_{MsgNewAnnouncement}
+<form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+  ^{widget}
+  <button>Submit
+<h2>_{MsgStops}
 <ol>
   $forall Stop{..} <- tripStops
     <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
@@ -124,130 +137,81 @@ getTrainViewR trip day = do
 |]
 
 
+getTripsViewR :: Handler Html
+getTripsViewR = do
+  GTFS{..} <- getYesod <&> getGtfs
+  defaultLayout [whamlet|
+<h1>List of Trips
+<ul>
+  $forall Trip{..} <- trips
+    <li><a href="@{TripViewR tripTripID}">#{tripTripID}</a>
+      : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
+|]
+
+
+getTripViewR :: TripID -> Handler Html
+getTripViewR tripId = do
+  GTFS{..} <- getYesod <&> getGtfs
+  case M.lookup tripId trips of
+    Nothing -> notFound
+    Just Trip{..} -> defaultLayout [whamlet|
+<h1>Trip #{tripTripID}
+<h2>Stops
+<ol>
+  $forall Stop{..} <- tripStops
+    <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
+<h2>Dates
+<ul>
+  TODO!
+|]
+
+
+postAnnounceR :: TripID -> Day -> Handler Html
+postAnnounceR trip day = do
+    ((result, widget), enctype) <- runFormPost (announceForm day trip)
+    case result of
+        FormSuccess ann -> do
+          runDB $ insert ann
+          redirect (TrainViewR trip day)
+        _ -> defaultLayout
+            [whamlet|
+                <p>Invalid input, let's try again.
+                <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+                    ^{widget}
+                    <button>Submit
+            |]
+
+getDelAnnounceR :: UUID -> Handler Html
+getDelAnnounceR uuid = do
+  ann <- runDB $ do
+    a <- get (AnnouncementKey uuid)
+    delete (AnnouncementKey uuid)
+    pure a
+  case ann of
+    Nothing -> notFound
+    Just Announcement{..} ->
+      redirect (TrainViewR announcementTrip announcementDay)
 
 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
+data TrainAnnounceF = TrainAnnounceF
+  { taHeader  :: Text
+  , taMsg     :: Text
+  , taLogTime :: Bool
+  } deriving (Show)
+
+
+
+announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm day tripId = renderDivs $ Announcement
+  <$> pure tripId
+  <*> areq textField "Header" Nothing
+  <*> areq textField "Text" Nothing
+  <*> pure day
+  <*> aopt urlField "Link" Nothing
+  <*> lift (liftIO getCurrentTime <&> Just)
+
+
+
diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index 1c62663..a7a358e 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 -- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService, redirect) where
+module Server.Util (Service, ServiceM, runService) where
 
 import           Control.Monad.Logger (LoggingT, runStderrLoggingT)
 import           Data.ByteString      (ByteString)
@@ -13,6 +13,3 @@ type Service api = ServerT api ServiceM
 
 runService :: ServiceM a -> Handler a
 runService = runStderrLoggingT
-
-redirect :: ByteString -> ServiceM a
-redirect path = throwError $ err302 { errHeaders = [("Location", path)] }