diff options
Diffstat (limited to 'lib/Server/Frontend')
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 2 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 65 |
2 files changed, 67 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index 75b1bda..fa3a9ce 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -45,6 +45,8 @@ mkYesodData "Frontend" [parseRoutes| /ticket/announce/#UUID AnnounceR POST /ticket/del-announce/#UUID DelAnnounceR GET +/tracker/#Text TrackerViewR GET + /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs new file mode 100644 index 0000000..23bbdb9 --- /dev/null +++ b/lib/Server/Frontend/Tracker.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} + +module Server.Frontend.Tracker (getTrackerViewR) where +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import qualified Data.UUID as UUID +import Database.Esqueleto.Experimental hiding ((<&>)) +import Persist +import Server.Frontend.Routes (FrontendMessage (..), Handler, + Route (..), Widget) +import Yesod hiding (update, (=.), (==.)) + +import OwnTracks.Status + +getTrackerViewR :: Text -> Handler Html +getTrackerViewR name = + runDB (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + pure tracker) + >>= \case + Nothing -> notFound + Just (Entity trackerId Tracker{..}) -> do + + (maybeStatus, maybePing) <- runDB $ do + status <- selectOne do + status <- from (table @TrackerStatus) + where_ (status ^. TrackerStatusTracker ==. val trackerId) + orderBy [desc $ status ^. TrackerStatusTimestamp] + pure status + ping <- selectOne do + ping <- from (table @Ping) + where_ (ping ^. PingTrackerId ==. val trackerId) + orderBy [desc $ ping ^. PingTimestamp] + pure ping + pure (status, ping) + + -- TODO: leaflet map; auto updates? + defaultLayout [whamlet| + <h1> _{MsgTracker name} + <em> (#{trackerId}) + <section> + <h2> _{MsgLastTrackerStatus} + $maybe Entity _ TrackerStatus{..} <- maybeStatus + LocationPermission: #{show $ statusLocationPermission trackerStatusStatus} <br> + BatteryOptimisations: #{show $ statusBatteryOptimizations trackerStatusStatus} <br> + Phone in power save mode: #{show $ statusPhonePowerSaveMode trackerStatusStatus} + $nothing + <em>Status unknown + <section> + <h2> _{MsgLastTrackerPosition} + $maybe Entity _ Ping{..} <- maybePing + Position: #{show pingGeopos} <br> + Timestamp: #{show pingTimestamp} <br> + $maybe ticketId <- pingTicket + Ticket: <a href="@{TicketViewR (coerce ticketId)}">#{UUID.toText (coerce ticketId)}</a> + $nothing + Ticket: (no assigned ticket) + $nothing + (none) + |] |
