diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Persist.hs | 2 | ||||
| -rw-r--r-- | lib/Server.hs | 2 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 3 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 2 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 69 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 9 |
6 files changed, 72 insertions, 15 deletions
diff --git a/lib/Persist.hs b/lib/Persist.hs index d5dc712..7ff3f1d 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -134,7 +134,7 @@ Shape sql=tt_shape Tracker sql=tt_tracker Id UUID default=uuid_generate_v4() name Text Unique - expires UTCTime +-- expires UTCTime blocked Bool agent Text currentTicket TicketId Maybe diff --git a/lib/Server.hs b/lib/Server.hs index 4eb101d..3cff4c5 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -95,7 +95,7 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = {- handleDebugAPI handleDebugState = do now <- liftIO getCurrentTime runSql dbpool $ do - tracker <- selectList [TrackerBlocked ==. False, TrackerExpires >=. now] [] + tracker <- selectList [TrackerBlocked ==. False] [] --, TrackerExpires >=. now] [] pairs <- forM tracker $ \(Entity trackerId@(TrackerKey uuid) _) -> do entities <- selectList [PingTrackerId ==. trackerId] [] pure (uuid, fmap entityVal entities) diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index cf6e342..b84d49b 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -45,8 +45,9 @@ mkYesodData "Frontend" [parseRoutes| /ticket/announce/#UUID AnnounceR POST /ticket/del-announce/#UUID DelAnnounceR GET -/trackers TrackersR GET +/trackers TrackersR GET POST /tracker/#Text TrackerViewR GET +/tracker/#Text/delete TrackerDeleteR POST /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs index 76146df..915521d 100644 --- a/lib/Server/Frontend/Tickets.hs +++ b/lib/Server/Frontend/Tickets.hs @@ -311,7 +311,7 @@ $maybe spaceTime <- spaceTimeMaybe <tr :trackerBlocked:.blocked> <td title="#{trackerAgent}">#{trackerAgent} <td title="#{key}">#{key} - <td title="#{trackerExpires}">#{trackerExpires} + $if trackerBlocked <td title="_{MsgUnblockTrackerId}"><a href="@?{(TrackerIdBlock (TrackerKey key), [("unblock", "true")])}">_{MsgUnblockTrackerId}</a> $else diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs index e3d88ba..a6c3c46 100644 --- a/lib/Server/Frontend/Tracker.hs +++ b/lib/Server/Frontend/Tracker.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE QuasiQuotes #-} -module Server.Frontend.Tracker (getTrackerViewR, getTrackersR) where +module Server.Frontend.Tracker (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR) where import Data.Coerce (coerce) import Data.Function ((&)) import Data.Functor ((<&>)) @@ -14,7 +14,8 @@ import Database.Esqueleto.Experimental hiding ((<&>)) import Persist import Server.Frontend.Routes (FrontendMessage (..), Handler, Route (..), Widget) -import Yesod hiding (update, (=.), (==.)) +import Yesod hiding (delete, update, (=.), + (==.)) import OwnTracks.Status @@ -28,14 +29,53 @@ getTrackersR = do pure (t, p) & fmap associateJoin + createWidget <- trackerCreateWidget + defaultLayout [whamlet| <h1> Trackers - <section> - <ul> - $forall (trackerId, (Tracker{..}, status)) <- M.toList trackers - <li><a href="@{TrackerViewR trackerName}">#{trackerName}</a> + <section> + <ul> + $forall (trackerId, (Tracker{..}, status)) <- M.toList trackers + <li><a href="@{TrackerViewR trackerName}">#{trackerName}</a> + <section> + ^{createWidget} + |] + +trackerCreateForm + :: Html + -> MForm Handler (FormResult Tracker, Widget) +trackerCreateForm = renderDivs $ Tracker + <$> areq textField (fieldSettingsLabel MsgTrackerName) Nothing + <*> pure False + <*> areq textField (fieldSettingsLabel MsgTrackerAgent) Nothing + <*> pure Nothing + +trackerCreateWidget :: Handler Html +trackerCreateWidget = do + (widget, enctype) <- generateFormPost trackerCreateForm + defaultLayout [whamlet| + <h2> _{MsgCreateTracker} + <form method=post action="@{TrackersR}" enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} |] +postTrackersR :: Handler Html +postTrackersR = do + ((result, widget), enctype) <- runFormPost trackerCreateForm + case result of + FormSuccess ann -> do + runDB do + insert ann + redirect TrackersR + _ -> defaultLayout + [whamlet| + <p>_{MsgInvalidInput}. + <form method=post action=@{TrackersR} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + getTrackerViewR :: Text -> Handler Html getTrackerViewR name = runDB (selectOne do @@ -62,7 +102,14 @@ getTrackerViewR name = -- TODO: leaflet map; auto updates? defaultLayout [whamlet| <h1> _{MsgTracker name} - <em> (#{trackerId}) + <section> + <h1> _{MsgTracker name} + <p> + Agent: #{trackerAgent} <br> + UUID: #{trackerId} + <p> + <form action=@{TrackerDeleteR trackerName} method="post"> + <button> _{Msgdelete} <section> <h2> _{MsgLastTrackerStatus} $maybe Entity _ TrackerStatus{..} <- maybeStatus @@ -83,3 +130,11 @@ getTrackerViewR name = $nothing (none) |] + + +postTrackerDeleteR :: Text -> Handler Html +postTrackerDeleteR name = do + runDB $ delete do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + redirect TrackersR diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs index 8e122a7..edbce08 100644 --- a/lib/Server/Ingest.hs +++ b/lib/Server/Ingest.hs @@ -74,7 +74,7 @@ handleTrackerRegister dbpool RegisterJson{..} = do today <- liftIO getCurrentTime <&> utctDay expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod runSql dbpool $ do - TrackerKey tracker <- insert (Tracker "dummy" expires False registerAgent Nothing) + TrackerKey tracker <- insert (Tracker "dummy" {-expires-} False registerAgent Nothing) pure (coerce tracker) where validityPeriod :: NominalDiffTime @@ -332,9 +332,10 @@ spaceAndTimeDiff (pos1, time1) (pos2, time2) = isTrackerIdValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker) isTrackerIdValid dbpool trackerId = runSql dbpool $ get trackerId >>= \case Just tracker | not (trackerBlocked tracker) -> do - ifM (hasExpired (trackerExpires tracker)) - (pure Nothing) - (pure (Just tracker)) + pure (Just tracker) + -- ifM (hasExpired (trackerExpires tracker)) + -- (pure Nothing) + -- (pure (Just tracker)) _ -> pure Nothing hasExpired :: MonadIO m => UTCTime -> m Bool |