restructure: split web frontend into several modules

9 files changed, 487 insertions, 582 deletions

diff --git a/lib/Server.hs b/lib/Server.hs
index 1833aa0..055e440 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -40,7 +40,7 @@ import           Servant.API                 ((:<|>) (..))
 import           Servant.Server              (hoistServer)
 import           Servant.Swagger             (toSwagger)
 import           Server.Base                 (ServerState)
-import           Server.ControlRoom          (ControlRoom (ControlRoom))
+import           Server.Frontend             (Frontend (..))
 import           Server.GTFS_RT              (gtfsRealtimeServer)
 import           Server.Ingest               (handleTrackerRegister,
                                               handleTrainPing, handleWS)
@@ -82,7 +82,7 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI
         :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool)
   :<|> handleMetrics
   :<|> serveDirectoryFileServer (serverConfigAssets settings)
-  :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings)))
+  :<|> pure (unsafePerformIO (toWaiAppPlain (Frontend gtfs dbpool settings)))
   where
     handleDebugState = do
       now <- liftIO getCurrentTime
diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
new file mode 100644
index 0000000..8d744db
--- /dev/null
+++ b/lib/Server/Frontend.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Server.Frontend (Frontend(..), Handler) where
+
+import           Server.Frontend.Gtfs
+import           Server.Frontend.OnboardUnit
+import           Server.Frontend.Routes
+import           Server.Frontend.Tickets
+
+import           Yesod
+import           Yesod.Auth
+
+
+mkYesodDispatch "Frontend" resourcesFrontend
+
+
+getRootR :: Handler Html
+getRootR = redirect TicketsR
+
+
diff --git a/lib/Server/Frontend/Gtfs.hs b/lib/Server/Frontend/Gtfs.hs
new file mode 100644
index 0000000..bc21ab7
--- /dev/null
+++ b/lib/Server/Frontend/Gtfs.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Gtfs (getGtfsTripViewR, getGtfsTripsViewR) where
+
+import           Server.Frontend.Routes
+
+import           Data.Functor           ((<&>))
+import qualified Data.Map               as M
+import           Data.Text              (Text)
+import qualified Data.Vector            as V
+import qualified GTFS
+import           Text.Blaze.Html        (Html)
+import           Yesod
+
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
+  defaultLayout $ do
+    setTitle "List of Trips"
+    [whamlet|
+<h1>List of Trips
+<section><ul>
+  $forall trip@GTFS.Trip{..} <- trips
+    <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
+      : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
+|]
+
+
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+  GTFS.GTFS{..} <- getYesod <&> getGtfs
+  case M.lookup tripId trips of
+    Nothing -> notFound
+    Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
+<section>
+  <h2>_{MsgInfo}
+  <p><strong>_{MsgtripId}:</strong> #{tripTripId}
+  <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
+  <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
+<section>
+  <h2>_{MsgStops}
+  <ol>
+    $forall GTFS.Stop{..} <- tripStops
+      <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
+<section>
+  <h2>Dates
+  <ul>
+    TODO!
+|]
+
+mightbe :: Maybe Text -> Text
+mightbe (Just a) = a
+mightbe Nothing  = ""
diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs
new file mode 100644
index 0000000..6a8fe6e
--- /dev/null
+++ b/lib/Server/Frontend/OnboardUnit.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.OnboardUnit (getOnboardTrackerR) where
+
+import           Server.Frontend.Routes
+
+import           Data.Functor           ((<&>))
+import qualified Data.Map               as M
+import           Data.Maybe             (fromJust)
+import           Data.Text              (Text)
+import           Data.Time              (UTCTime (..), getCurrentTime)
+import           Data.UUID              (UUID)
+import qualified Data.UUID              as UUID
+import qualified Data.Vector            as V
+import qualified GTFS
+import           Persist                (EntityField (..), Key (..), Stop (..),
+                                         Ticket (..))
+import           Text.Blaze.Html        (Html)
+import           Yesod
+
+
+getOnboardTrackerR :: Handler Html
+getOnboardTrackerR = do defaultLayout [whamlet|
+  <h1>_{MsgOBU}
+
+  <section>
+    <h2>Tracker
+    <strong>Token:</strong> <span id="token">
+  <section>
+    <h2>Status
+    <p id="status">_{MsgNone}
+    <p id>_{MsgError}: <span id="error">
+  <section>
+    <h2>_{MsgLive}
+    <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
+    <p><strong>Accuracy: </strong><span id="acc">
+  <section>
+    <h2>_{MsgEstimated}
+    <p><strong>_{MsgDelay}</strong>: <span id="delay">
+    <p><strong>_{MsgSequence}</strong>: <span id="sequence">
+
+
+  <script>
+    var token = null;
+
+    let euclid = (a,b) => {
+      let x = a[0]-b[0];
+      let y = a[1]-b[1];
+      return x*x+y*y;
+    }
+
+    let minimalDist = (point, list, proj, norm) => {
+      return list.reduce (
+        (min, x) => {
+          let dist = norm(point, proj(x));
+          return dist < min[0] ? [dist,x] : min
+        },
+        [norm(point, proj(list[0])), list[0]]
+      )[1]
+    }
+
+    let counter = 0;
+    let ws;
+    let id;
+
+    function setStatus(msg) {
+      document.getElementById("status").innerText = msg
+    }
+
+    async function geoError(error) {
+      setStatus("error");
+      alert(`_{MsgPermissionFailed}: \n${error.message}`);
+      console.error(error);
+      main();
+    }
+
+    async function wsError(error) {
+      // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`);
+      console.log(error);
+      navigator.geolocation.clearWatch(id);
+    }
+
+    async function wsClose(error) {
+      console.log(error);
+      document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`;
+      navigator.geolocation.clearWatch(id);
+      setTimeout(openWebsocket, 1000);
+    }
+
+    function wsMsg(msg) {
+      let json = JSON.parse(msg.data);
+      console.log(json);
+      document.getElementById("delay").innerText =
+        `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
+      document.getElementById("sequence").innerText = json.sequence;
+    }
+
+
+    function initGeopos() {
+      document.getElementById("error").innerText = "";
+      id = navigator.geolocation.watchPosition(
+        geoPing,
+        geoError,
+        {enableHighAccuracy: true}
+      );
+    }
+
+
+    function openWebsocket () {
+      ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/tracker/ping/ws");
+      ws.onerror = wsError;
+      ws.onclose = wsClose;
+      ws.onmessage = wsMsg;
+      ws.onopen = (event) => {
+        setStatus("connected");
+      };
+    }
+
+    async function geoPing(geoloc) {
+      console.log("got position update " + counter);
+      document.getElementById("lat").innerText = geoloc.coords.latitude;
+      document.getElementById("long").innerText = geoloc.coords.longitude;
+      document.getElementById("acc").innerText = geoloc.coords.accuracy;
+
+      if (ws !== undefined && ws.readyState == 1) {
+          ws.send(JSON.stringify({
+              token: token,
+              geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ],
+              timestamp: (new Date()).toISOString()
+          }));
+          counter += 1;
+          setStatus(`sent ${counter} pings`);
+      } else {
+          setStatus(`websocket readystate ${ws.readyState}`);
+      }
+    }
+
+
+    async function main() {
+      initGeopos();
+
+      let urlparams = new URLSearchParams(window.location.search);
+
+      token = urlparams.get("token");
+
+        if (token === null) {
+          token = await (await fetch("/api/tracker/register/", {
+               method: "POST",
+               body: JSON.stringify({agent: "tracktrain-website"}),
+               headers: {"Content-Type": "application/json"}
+          })).json();
+
+          if (token.error) {
+              alert("could not obtain token: \n" + token.msg);
+              setStatus("_{MsgTokenFailed}");
+          } else {
+              console.log("got token");
+              window.location.search = `?token=${token}`;
+          }
+      }
+
+      console.log(token)
+
+      if (token !== null) {
+          document.getElementById("token").innerText = token;
+          openWebsocket();
+      }
+    }
+
+    main()
+  |]
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
new file mode 100644
index 0000000..2d74338
--- /dev/null
+++ b/lib/Server/Frontend/Routes.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies    #-}
+
+module Server.Frontend.Routes where
+
+import           Config                    (ServerConfig (..), UffdConfig (..))
+import           Control.Monad             (forM_)
+import qualified Data.Aeson                as A
+import qualified Data.ByteString.Char8     as C8
+import qualified Data.ByteString.Lazy      as LB
+import           Data.Functor              ((<&>))
+import           Data.Pool                 (Pool)
+import qualified Data.Text                 as T
+import           Data.Time                 (UTCTime)
+import           Data.Time.Calendar        (Day)
+import           Data.UUID                 (UUID)
+import           Database.Persist.Sql      (SqlBackend, runSqlPool)
+import qualified GTFS
+import           Persist                   (Token)
+import           Text.Blaze.Internal       (MarkupM (Empty))
+import           Yesod
+import           Yesod.Auth
+import           Yesod.Auth.OAuth2.Prelude
+import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)
+import           Yesod.Orphans             ()
+
+data Frontend = Frontend
+  { getGtfs     :: GTFS.GTFS
+  , getPool     :: Pool SqlBackend
+  , getSettings :: ServerConfig
+  }
+
+mkMessage "Frontend" "messages" "en"
+
+mkYesodData "Frontend" [parseRoutes|
+/ RootR GET
+/auth AuthR Auth getAuth
+
+/tickets TicketsR GET
+/ticket/#UUID TicketViewR GET
+/ticket/map/#UUID TicketMapViewR GET
+/ticket/announce/#UUID AnnounceR POST
+/ticket/del-announce/#UUID DelAnnounceR GET
+
+/token/block/#Token TokenBlock GET
+
+/gtfs/trips GtfsTripsViewR GET
+/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
+/gtfs/import/#Day GtfsTicketImportR POST
+
+/tracker OnboardTrackerR GET
+|]
+
+emptyMarkup :: MarkupM a -> Bool
+emptyMarkup (Empty _) = True
+emptyMarkup _         = False
+
+
+instance Yesod Frontend where
+  authRoute _ = Just $ AuthR LoginR
+  isAuthorized OnboardTrackerR _ = pure Authorized
+  isAuthorized (AuthR _) _ = pure Authorized
+  isAuthorized _ _ = do
+    UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
+    if uffdConfigEnable then maybeAuthId >>= \case
+      Just _  -> pure Authorized
+      Nothing -> pure AuthenticationRequired
+    else pure Authorized
+
+
+  defaultLayout w = do
+      PageContent{..} <- widgetToPageContent w
+      msgs <- getMessages
+
+      withUrlRenderer [hamlet|
+        $newline never
+        $doctype 5
+        <html>
+          <head>
+            <title>
+              $if emptyMarkup pageTitle
+                Tracktrain
+              $else
+                #{pageTitle}
+            $maybe description <- pageDescription
+              <meta name="description" content="#{description}">
+            ^{pageHead}
+            <link rel="stylesheet" href="/assets/style.css">
+            <meta name="viewport" content="width=device-width, initial-scale=1">
+          <body>
+            $forall (status, msg) <- msgs
+              <!--  <p class="message #{status}">#{msg} -->
+            ^{pageBody}
+        |]
+
+
+instance RenderMessage Frontend FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
+instance YesodPersist Frontend where
+  type YesodPersistBackend Frontend = SqlBackend
+  runDB action = do
+    pool <- getYesod <&> getPool
+    runSqlPool action pool
+
+
+-- this instance is only slightly cursed (it keeps login information
+-- as json in a session cookie and hopes nothing will ever go wrong)
+instance YesodAuth Frontend where
+  type AuthId Frontend = UffdUser
+
+  authPlugins cr = case config of
+    UffdConfig {..} -> if uffdConfigEnable
+      then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
+      else []
+    where config = serverConfigLogin (getSettings cr)
+
+  maybeAuthId = do
+    e <- lookupSession "json"
+    pure $ case e of
+      Nothing    -> Nothing
+      Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
+
+  authenticate creds = do
+    forM_ (credsExtra creds) (uncurry setSession)
+    -- extra <- lookupSession "extra"
+    -- pure (Authenticated ( undefined))
+    e <- lookupSession "json"
+    case e of
+      Nothing -> error "no session information"
+      Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
+        Nothing   -> error "malformed session information"
+        Just user -> pure $ Authenticated user
+
+  loginDest _ = RootR
+  logoutDest _ = RootR
+  -- hardcode redirecting to uffd directly; showing the normal login
+  -- screen is kinda pointless when there's only one option
+  loginHandler = do
+    redirect ("/auth/page/uffd/forward" :: Text)
+  onLogout = do
+    clearSession
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/Frontend/Tickets.hs
index 5292620..43f24aa 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -1,192 +1,55 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies      #-}
-
-module Server.ControlRoom (ControlRoom(..)) where
-
-import           Config                    (ServerConfig (..), UffdConfig (..))
-import           Control.Monad             (forM, forM_, join)
-import           Control.Monad.Extra       (maybeM)
-import           Control.Monad.IO.Class    (MonadIO (liftIO))
-import qualified Data.Aeson                as A
-import qualified Data.ByteString.Char8     as C8
-import qualified Data.ByteString.Lazy      as LB
-import           Data.Coerce               (coerce)
-import           Data.Function             (on, (&))
-import           Data.Functor              ((<&>))
-import           Data.List                 (lookup, nubBy)
-import           Data.List.NonEmpty        (nonEmpty)
-import           Data.Map                  (Map)
-import qualified Data.Map                  as M
-import           Data.Maybe                (catMaybes, fromJust, isJust)
-import           Data.Pool                 (Pool)
-import           Data.Text                 (Text)
-import qualified Data.Text                 as T
-import           Data.Time                 (UTCTime (..), addDays,
-                                            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           Extrapolation             (Extrapolator (..),
-                                            LinearExtrapolator (..))
-import           Fmt                       ((+|), (|+))
-import           GHC.Float                 (int2Double)
-import           GHC.Generics              (Generic)
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Tickets
+  ( getTicketsR
+  , postGtfsTicketImportR
+  , getTicketViewR
+  , getTicketMapViewR
+  , getDelAnnounceR
+  , postAnnounceR
+  , getTokenBlock
+  ) where
+
+import           Server.Frontend.Routes
+
+import           Config                   (ServerConfig (..), UffdConfig (..))
+import           Control.Monad            (forM, forM_, join)
+import           Control.Monad.Extra      (maybeM)
+import           Control.Monad.IO.Class   (MonadIO (liftIO))
+import           Data.Coerce              (coerce)
+import           Data.Function            (on, (&))
+import           Data.Functor             ((<&>))
+import           Data.List                (lookup, nubBy)
+import           Data.List.NonEmpty       (nonEmpty)
+import           Data.Map                 (Map)
+import qualified Data.Map                 as M
+import           Data.Maybe               (catMaybes, fromJust, isJust)
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time                (UTCTime (..), addDays,
+                                           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           Extrapolation            (Extrapolator (..),
+                                           LinearExtrapolator (..))
+import           Fmt                      ((+|), (|+))
+import           GHC.Float                (int2Double)
 import qualified GTFS
-import           Numeric                   (showFFloat)
+import           Numeric                  (showFFloat)
 import           Persist
-import           Server.Util               (Service, secondsNow)
-import           Text.Blaze.Html           (ToMarkup (..))
-import           Text.Blaze.Internal       (MarkupM (Empty))
-import           Text.Read                 (readMaybe)
-import           Text.Shakespeare.Text
+import           Server.Util              (Service, secondsNow)
+import           Text.Read                (readMaybe)
 import           Yesod
 import           Yesod.Auth
-import           Yesod.Auth.OAuth2.Prelude
-import           Yesod.Auth.OpenId         (IdentifierType (..), authOpenId)
-import           Yesod.Auth.Uffd           (UffdUser (..), uffdClient)
-import           Yesod.Form
-import           Yesod.Orphans             ()
+import           Yesod.Auth.Uffd          (UffdUser (..), uffdClient)
 
 
-data ControlRoom = ControlRoom
-  { getGtfs     :: GTFS.GTFS
-  , getPool     :: Pool SqlBackend
-  , getSettings :: ServerConfig
-  }
-
-mkMessage "ControlRoom" "messages" "en"
-
-mkYesod "ControlRoom" [parseRoutes|
-/ RootR GET
-/auth AuthR Auth getAuth
-
-/tickets TicketsR GET
-/ticket/#UUID TicketViewR GET
-/ticket/map/#UUID TicketMapViewR GET
-/ticket/announce/#UUID AnnounceR POST
-/ticket/del-announce/#UUID DelAnnounceR GET
-
-/token/block/#Token TokenBlock GET
-
-/gtfs/trips GtfsTripsViewR GET
-/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
-/gtfs/import/#Day GtfsTicketImportR POST
-
-/obu OnboardUnitMenuR GET
-/obu/#UUID OnboardUnitR GET
-/tracker OnboardTrackerR GET
-|]
-
-emptyMarkup :: MarkupM a -> Bool
-emptyMarkup (Empty _) = True
-emptyMarkup _         = False
-
-instance Yesod ControlRoom where
-  authRoute _ = Just $ AuthR LoginR
-  isAuthorized OnboardUnitMenuR _ = pure Authorized
-  isAuthorized (OnboardUnitR _) _ = pure Authorized
-  isAuthorized OnboardTrackerR _ = pure Authorized
-  isAuthorized (AuthR _) _ = pure Authorized
-  isAuthorized _ _ = do
-    UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
-    if uffdConfigEnable then maybeAuthId >>= \case
-      Just _  -> pure Authorized
-      Nothing -> pure AuthenticationRequired
-    else pure Authorized
-
-
-  defaultLayout w = do
-      PageContent{..} <- widgetToPageContent w
-      msgs <- getMessages
-
-      withUrlRenderer [hamlet|
-        $newline never
-        $doctype 5
-        <html>
-          <head>
-            <title>
-              $if emptyMarkup pageTitle
-                Tracktrain
-              $else
-                #{pageTitle}
-            $maybe description <- pageDescription
-              <meta name="description" content="#{description}">
-            ^{pageHead}
-            <link rel="stylesheet" href="/assets/style.css">
-            <meta name="viewport" content="width=device-width, initial-scale=1">
-          <body>
-            $forall (status, msg) <- msgs
-              <!--  <p class="message #{status}">#{msg} -->
-            ^{pageBody}
-        |]
-
-
-instance RenderMessage ControlRoom FormMessage where
-  renderMessage _ _ = defaultFormMessage
-
-instance YesodPersist ControlRoom where
-  type YesodPersistBackend ControlRoom = SqlBackend
-  runDB action = do
-    pool <- getYesod <&> getPool
-    runSqlPool action pool
-
-
--- this instance is only slightly cursed (it keeps login information
--- as json in a session cookie and hopes nothing will ever go wrong)
-instance YesodAuth ControlRoom where
-  type AuthId ControlRoom = UffdUser
-
-  authPlugins cr = case config of
-    UffdConfig {..} -> if uffdConfigEnable
-      then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
-      else []
-    where config = serverConfigLogin (getSettings cr)
-
-  maybeAuthId = do
-    e <- lookupSession "json"
-    pure $ case e of
-      Nothing    -> Nothing
-      Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
-
-  authenticate creds = do
-    forM_ (credsExtra creds) (uncurry setSession)
-    -- extra <- lookupSession "extra"
-    -- pure (Authenticated ( undefined))
-    e <- lookupSession "json"
-    case e of
-      Nothing -> error "no session information"
-      Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
-        Nothing   -> error "malformed session information"
-        Just user -> pure $ Authenticated user
-
-  loginDest _ = RootR
-  logoutDest _ = RootR
-  -- hardcode redirecting to uffd directly; showing the normal login
-  -- screen is kinda pointless when there's only one option
-  loginHandler = do
-    redirect ("/auth/page/uffd/forward" :: Text)
-  onLogout = do
-    clearSession
-
-
-
-
-getRootR :: Handler Html
-getRootR = redirect TicketsR
-
 getTicketsR :: Handler Html
 getTicketsR = do
   req <- getRequest
@@ -439,46 +302,47 @@ getTicketMapViewR ticketId = do
   }
 |]
 
+tripImportForm
+  :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
+  -> Html
+  -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
+tripImportForm trips extra = do
+  forms <- forM trips $ \(trip, day) -> do
+    (aRes, aView) <- mreq checkBoxField "import" Nothing
+    let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+    pure (trip, day, dings, aView)
 
+  let widget = toWidget [whamlet|
+     #{extra}
+     <ol>
+       $forall (trip@GTFS.Trip{..}, day, res, view) <- forms
+         <li>
+           ^{fvInput view}
+           <label for="^{fvId view}">
+             _{MsgTrip} #{GTFS.tripName trip}
+               : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
+  |]
 
-getGtfsTripsViewR :: Handler Html
-getGtfsTripsViewR = do
-  GTFS.GTFS{..} <- getYesod <&> getGtfs
-  defaultLayout $ do
-    setTitle "List of Trips"
-    [whamlet|
-<h1>List of Trips
-<section><ul>
-  $forall trip@GTFS.Trip{..} <- trips
-    <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
-      : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
-|]
+  let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
+        sequenceA (fmap (\(_,_,res,_) -> res) forms)
 
+  pure (fmap catMaybes a, widget)
 
-getGtfsTripViewR :: GTFS.TripId -> Handler Html
-getGtfsTripViewR tripId = do
-  GTFS.GTFS{..} <- getYesod <&> getGtfs
-  case M.lookup tripId trips of
-    Nothing -> notFound
-    Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
-<h1>_{MsgTrip} #{GTFS.tripName trip}
-<section>
-  <h2>_{MsgInfo}
-  <p><strong>_{MsgtripId}:</strong> #{tripTripId}
-  <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
-  <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
-<section>
-  <h2>_{MsgStops}
-  <ol>
-    $forall GTFS.Stop{..} <- tripStops
-      <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
-<section>
-  <h2>Dates
-  <ul>
-    TODO!
-|]
+gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
+gtfsHeadsign GTFS.Trip{..} =
+  case tripHeadsign of
+    Just headsign -> headsign
+    Nothing       -> GTFS.stationName (GTFS.stopStation (V.last tripStops))
 
 
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+  <$> pure (TicketKey ticketId)
+  <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
+  <*> areq textField (fieldSettingsLabel MsgText) Nothing
+  <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
+  <*> lift (liftIO getCurrentTime <&> Just)
+
 postAnnounceR :: UUID -> Handler Html
 postAnnounceR ticketId = do
     ((result, widget), enctype) <- runFormPost (announceForm ticketId)
@@ -520,86 +384,3 @@ getTokenBlock token = do
         Just ticket -> TicketViewR (coerce ticket)
         Nothing     -> RootR
     Nothing -> notFound
-
-getOnboardUnitMenuR :: Handler Html
-getOnboardUnitMenuR = do
-  day <- liftIO getCurrentTime <&> utctDay
-
-  tickets <-
-    runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do
-      firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ]
-      pure (ticket, entityVal $ fromJust firstStop))
-
-  defaultLayout $ do
-    [whamlet|
-      <h1>_{MsgOBU}
-      <section>
-       _{MsgChooseTrain}
-       $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
-         <hr>
-         <a href="@{OnboardUnitR ticketId}">
-          #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
-      <section>
-        <a href="@{OnboardTrackerR}">_{MsgStartTracking}
-    |]
-
-getOnboardUnitR :: UUID -> Handler Html
-getOnboardUnitR ticketId = do
-  Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case
-    Nothing -> notFound
-    Just ticket -> pure ticket
-  defaultLayout $(whamletFile "site/obu.hamlet")
-
-getOnboardTrackerR :: Handler Html
-getOnboardTrackerR = do
-  defaultLayout
-    $( whamletFile "site/tracker.hamlet")
-
-
-announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm ticketId = renderDivs $ Announcement
-  <$> pure (TicketKey ticketId)
-  <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
-  <*> areq textField (fieldSettingsLabel MsgText) Nothing
-  <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
-  <*> lift (liftIO getCurrentTime <&> Just)
-
-
-
-tripImportForm
-  :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
-  -> Html
-  -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
-tripImportForm trips extra = do
-  forms <- forM trips $ \(trip, day) -> do
-    (aRes, aView) <- mreq checkBoxField "import" Nothing
-    let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
-    pure (trip, day, dings, aView)
-
-  let widget = toWidget [whamlet|
-     #{extra}
-     <ol>
-       $forall (trip@GTFS.Trip{..}, day, res, view) <- forms
-         <li>
-           ^{fvInput view}
-           <label for="^{fvId view}">
-             _{MsgTrip} #{GTFS.tripName trip}
-               : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
-  |]
-
-  let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
-        sequenceA (fmap (\(_,_,res,_) -> res) forms)
-
-  pure (fmap catMaybes a, widget)
-
-
-mightbe :: Maybe Text -> Text
-mightbe (Just a) = a
-mightbe Nothing  = ""
-
-
-gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
-gtfsHeadsign GTFS.Trip{..} =
-  case tripHeadsign of
-    Just headsign -> headsign
-    Nothing       -> GTFS.stationName (GTFS.stopStation (V.last tripStops))
diff --git a/site/obu.hamlet b/site/obu.hamlet
deleted file mode 100644
index ed8017a..0000000
--- a/site/obu.hamlet
+++ /dev/null
@@ -1,132 +0,0 @@
-<h1>_{MsgOBU}
-
-<section>
-  <h2>#{ticketTripName} _{Msgon} #{ticketDay}
-  <strong>Token:</strong> <span id="token">
-
-<section>
-  <h2>_{MsgLive}
-  <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
-  <p><strong>Accuracy: </strong><span id="acc">
-
-<section>
-  <h2>_{MsgEstimated}
-  <p><strong>_{MsgDelay}</strong>: <span id="delay">
-  <p><strong>_{MsgSequence}</strong>: <span id="sequence">
-
-<section>
-  <h2>Status
-  <p id="status">_{MsgNone}
-  <p id>_{MsgError}: <span id="error">
-
-
-<script>
-  var token = null;
-
-  let euclid = (a,b) => {
-    let x = a[0]-b[0];
-    let y = a[1]-b[1];
-    return x*x+y*y;
-  }
-
-  let minimalDist = (point, list, proj, norm) => {
-    return list.reduce (
-      (min, x) => {
-        let dist = norm(point, proj(x));
-        return dist < min[0] ? [dist,x] : min
-      },
-      [norm(point, proj(list[0])), list[0]]
-    )[1]
-  }
-
-  let counter = 0;
-  let ws;
-  let id;
-
-  async function geoError(error) {
-    document.getElementById("status").innerText = "error";
-    alert(`_{MsgPermissionFailed}: \n${error.message}`);
-    console.log(error);
-  }
-
-  async function wsError(error) {
-    // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`);
-    console.log(error);
-    navigator.geolocation.clearWatch(id);
-  }
-
-  async function wsClose(error) {
-    console.log(error);
-    document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`;
-    navigator.geolocation.clearWatch(id);
-    setTimeout(openWebsocket, 1000);
-  }
-
-  function wsMsg(msg) {
-    let json = JSON.parse(msg.data);
-    console.log(json);
-    document.getElementById("delay").innerText =
-      `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
-    document.getElementById("sequence").innerText = json.sequence;
-  }
-
-
-  function initGeopos() {
-    document.getElementById("error").innerText = "";
-    id = navigator.geolocation.watchPosition(
-      geoPing,
-      geoError,
-      {enableHighAccuracy: true}
-    );
-  }
-
-
-  function openWebsocket () {
-    ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/ping/ws");
-    ws.onerror = wsError;
-    ws.onclose = wsClose;
-    ws.onmessage = wsMsg
-    ws.onopen = (event) => initGeopos();
-  }
-
-  async function geoPing(geoloc) {
-    console.log("got position update " + counter);
-    document.getElementById("lat").innerText = geoloc.coords.latitude;
-    document.getElementById("long").innerText = geoloc.coords.longitude;
-    document.getElementById("acc").innerText = geoloc.coords.accuracy;
-
-    ws.send(JSON.stringify({
-        token: token,
-        lat: geoloc.coords.latitude,
-        long: geoloc.coords.longitude,
-        timestamp: (new Date()).toISOString()
-    }));
-    counter += 1;
-    document.getElementById("status").innerText = `sent ${counter} pings`;
-  }
-
-
-  async function main() {
-    let trip = await (await fetch("/api/trip/#{ticketTripName}")).json();
-    console.log("got trip info");
-
-    token = await (await fetch("/api/train/register/#{UUID.toText ticketId}", {
-      method: "POST",
-      body: JSON.stringify({agent: "onboard-unit"}),
-      headers: {"Content-Type": "application/json"}
-    })).json();
-
-
-    if (token.error) {
-      alert("could not obtain token: \n" + token.msg);
-      document.getElementById("status").innerText = "_{MsgTokenFailed}";
-    } else {
-      console.log("got token");
-
-      document.getElementById("token").innerText = token;
-
-      openWebsocket();
-    }
-  }
-
-  main()
diff --git a/site/tracker.hamlet b/site/tracker.hamlet
deleted file mode 100644
index 2cc05e4..0000000
--- a/site/tracker.hamlet
+++ /dev/null
@@ -1,147 +0,0 @@
-<h1>_{MsgOBU}
-
-<section>
-  <h2>Tracker
-  <strong>Token:</strong> <span id="token">
-<section>
-  <h2>Status
-  <p id="status">_{MsgNone}
-  <p id>_{MsgError}: <span id="error">
-<section>
-  <h2>_{MsgLive}
-  <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
-  <p><strong>Accuracy: </strong><span id="acc">
-<section>
-  <h2>_{MsgEstimated}
-  <p><strong>_{MsgDelay}</strong>: <span id="delay">
-  <p><strong>_{MsgSequence}</strong>: <span id="sequence">
-
-
-<script>
-  var token = null;
-
-  let euclid = (a,b) => {
-    let x = a[0]-b[0];
-    let y = a[1]-b[1];
-    return x*x+y*y;
-  }
-
-  let minimalDist = (point, list, proj, norm) => {
-    return list.reduce (
-      (min, x) => {
-        let dist = norm(point, proj(x));
-        return dist < min[0] ? [dist,x] : min
-      },
-      [norm(point, proj(list[0])), list[0]]
-    )[1]
-  }
-
-  let counter = 0;
-  let ws;
-  let id;
-
-  function setStatus(msg) {
-    document.getElementById("status").innerText = msg
-  }
-
-  async function geoError(error) {
-    setStatus("error");
-    alert(`_{MsgPermissionFailed}: \n${error.message}`);
-    console.error(error);
-    main();
-  }
-
-  async function wsError(error) {
-    // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`);
-    console.log(error);
-    navigator.geolocation.clearWatch(id);
-  }
-
-  async function wsClose(error) {
-    console.log(error);
-    document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`;
-    navigator.geolocation.clearWatch(id);
-    setTimeout(openWebsocket, 1000);
-  }
-
-  function wsMsg(msg) {
-    let json = JSON.parse(msg.data);
-    console.log(json);
-    document.getElementById("delay").innerText =
-      `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
-    document.getElementById("sequence").innerText = json.sequence;
-  }
-
-
-  function initGeopos() {
-    document.getElementById("error").innerText = "";
-    id = navigator.geolocation.watchPosition(
-      geoPing,
-      geoError,
-      {enableHighAccuracy: true}
-    );
-  }
-
-
-  function openWebsocket () {
-    ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/tracker/ping/ws");
-    ws.onerror = wsError;
-    ws.onclose = wsClose;
-    ws.onmessage = wsMsg;
-    ws.onopen = (event) => {
-      setStatus("connected");
-    };
-  }
-
-  async function geoPing(geoloc) {
-    console.log("got position update " + counter);
-    document.getElementById("lat").innerText = geoloc.coords.latitude;
-    document.getElementById("long").innerText = geoloc.coords.longitude;
-    document.getElementById("acc").innerText = geoloc.coords.accuracy;
-
-    if (ws !== undefined && ws.readyState == 1) {
-        ws.send(JSON.stringify({
-            token: token,
-            geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ],
-            timestamp: (new Date()).toISOString()
-        }));
-        counter += 1;
-        setStatus(`sent ${counter} pings`);
-    } else {
-        setStatus(`websocket readystate ${ws.readyState}`);
-    }
-  }
-
-
-  async function main() {
-    initGeopos();
-
-    let urlparams = new URLSearchParams(window.location.search);
-
-    token = urlparams.get("token");
-
-    if (token === null) {
-        token = await (await fetch("/api/tracker/register/", {
-             method: "POST",
-             body: JSON.stringify({agent: "tracktrain-website"}),
-             headers: {"Content-Type": "application/json"}
-        })).json();
-
-        if (token.error) {
-            alert("could not obtain token: \n" + token.msg);
-            setStatus("_{MsgTokenFailed}");
-        } else {
-            console.log("got token");
-            window.location.search = `?token=${token}`;
-        }
-    }
-
-    console.log(token)
-
-    if (token !== null) {
-        document.getElementById("token").innerText = token;
-        openWebsocket();
-    }
-  }
-
-  main()
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 5bf213f..542f986 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -102,7 +102,7 @@ library
     exposed-modules: GTFS
                    , Server
                    , Server.GTFS_RT
-                   , Server.ControlRoom
+                   , Server.Frontend
                    , PersistOrphans
                    , Persist
                    , Extrapolation
@@ -112,6 +112,13 @@ library
                  , Yesod.Auth.Uffd
                  , Yesod.Orphans
                  , MultiLangText
+                 , Server.Base
+                 , Server.Ingest
+                 , Server.Subscribe
+                 , Server.Frontend.Routes
+                 , Server.Frontend.Tickets
+                 , Server.Frontend.OnboardUnit
+                 , Server.Frontend.Gtfs
     default-language: GHC2021
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables