aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs8
-rw-r--r--lib/Extrapolation.hs3
-rw-r--r--lib/GTFS.hs2
-rw-r--r--lib/OwnTracks.hs34
-rw-r--r--lib/OwnTracks/Command.hs44
-rw-r--r--lib/OwnTracks/Location.hs5
-rw-r--r--lib/Persist.hs5
-rw-r--r--lib/Server.hs6
-rw-r--r--lib/Server/Frontend/Ticker.hs18
-rw-r--r--lib/Server/Frontend/Tickets.hs75
-rw-r--r--lib/Server/GTFS_RT.hs10
-rw-r--r--lib/Server/Ingest.hs20
-rw-r--r--lib/Server/Subscribe.hs37
13 files changed, 134 insertions, 133 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 3962f73..ce1f7e8 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -28,8 +28,8 @@ import Servant (Application, FormUrlEncoded,
import Servant.API (Accept, Capture, Get, JSON,
MimeRender, MimeUnrender,
NoContent, OctetStream, PlainText,
- Post, QueryParam, Raw, ReqBody,
- type (:<|>) (..), QueryFlag)
+ Post, QueryFlag, QueryParam, Raw,
+ ReqBody, type (:<|>) (..))
import Servant.API.WebSocket (WebSocket)
import Servant.Swagger (HasSwagger (..))
import Web.Internal.FormUrlEncoded (Form)
@@ -47,15 +47,15 @@ import GTFS (Depth (Deep), GTFSFile (..),
StationID, Trip, TripId,
aesonOptions, swaggerOptions)
import Network.HTTP.Media ((//))
+import qualified OwnTracks as OT
import Persist
import Prometheus
import Proto.GtfsRealtime (FeedMessage)
import Servant.API.ContentTypes (Accept (..))
-import qualified OwnTracks as OT
-- | a bare ping as sent by a tracker device
data SentPing = SentPing
- { sentPingTrackerId :: TrackerId
+ { sentPingTrackerId :: TrackerId
, sentPingGeopos :: Geopos
, sentPingTimestamp :: UTCTime
} deriving (Generic)
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 071e5fa..3d19393 100644
--- a/lib/Extrapolation.hs
+++ b/lib/Extrapolation.hs
@@ -29,7 +29,8 @@ import Persist (Geopos (..),
ShapePoint (shapePointGeopos),
Station (..), Stop (..),
Ticket (..), TicketId,
- TrackerId (..), Tracker (..),
+ Tracker (..),
+ TrackerId (..),
TrainAnchor (..))
import Server.Util (utcToSeconds)
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index bec519f..c4e2093 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -409,7 +409,7 @@ intAsBool r field = do
pure $ case int :: Maybe Int of
Just 1 -> Just True
Just 0 -> Just False
- _ -> Nothing
+ _ -> Nothing
intAsBool' :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser Bool
intAsBool' r field = intAsBool r field >>= maybe
diff --git a/lib/OwnTracks.hs b/lib/OwnTracks.hs
index 25b0ae9..c39a3bc 100644
--- a/lib/OwnTracks.hs
+++ b/lib/OwnTracks.hs
@@ -1,9 +1,9 @@
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ApplicativeDo #-}
module OwnTracks
@@ -16,24 +16,22 @@ module OwnTracks
) where
import Data.Aeson
-import Data.Aeson.Types (Parser)
-import Data.ByteString (ByteString)
+import Data.Aeson.Types (Parser)
+import Data.ByteString (ByteString)
import Data.ByteString.Base64
-import Data.Functor ((<&>))
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Data.Time (
- UTCTime,
- defaultTimeLocale,
- parseTimeM)
+import Data.Functor ((<&>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time (UTCTime, defaultTimeLocale,
+ parseTimeM)
import Database.Persist
-import GHC.Generics (Generic)
+import GHC.Generics (Generic)
+import OwnTracks.Command
+import OwnTracks.Configuration
import OwnTracks.Location
import OwnTracks.Status
-import OwnTracks.Configuration
-import OwnTracks.Command
import OwnTracks.Waypoint
data Message =
@@ -47,8 +45,8 @@ instance FromJSON Message where
parseJSON v@(Object o) = do
ty :: Text <- o .: "_type"
case ty of
- "location" -> MsgLocation <$> parseJSON v
- "status" -> MsgStatus <$> parseJSON v
+ "location" -> MsgLocation <$> parseJSON v
+ "status" -> MsgStatus <$> parseJSON v
"configuration" -> MsgConfig <$> parseJSON v
- "waypoints" -> MsgWaypoints <$> o .: "waypoints"
- _ -> fail "unknown _type of owntracks message."
+ "waypoints" -> MsgWaypoints <$> o .: "waypoints"
+ _ -> fail "unknown _type of owntracks message."
diff --git a/lib/OwnTracks/Command.hs b/lib/OwnTracks/Command.hs
index 5468379..257d3e3 100644
--- a/lib/OwnTracks/Command.hs
+++ b/lib/OwnTracks/Command.hs
@@ -10,22 +10,20 @@ module OwnTracks.Command
(Command(..)) where
import Data.Aeson
-import Data.Aeson.Types (Parser)
-import Data.ByteString (ByteString)
+import Data.Aeson.Types (Parser)
+import Data.ByteString (ByteString)
import Data.ByteString.Base64
-import Data.Functor ((<&>))
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Data.Time (
- UTCTime,
- defaultTimeLocale,
- parseTimeM)
+import Data.Functor ((<&>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time (UTCTime, defaultTimeLocale,
+ parseTimeM)
import Database.Persist
-import GHC.Generics (Generic)
+import GHC.Generics (Generic)
-import OwnTracks.Configuration
-import OwnTracks.Waypoint
+import OwnTracks.Configuration
+import OwnTracks.Waypoint
data Command =
Dump
@@ -50,16 +48,16 @@ instance ToJSON Command where
: "action" .= String action
: others )
where action = case c of
- Dump -> "dump"
- GetStatus -> "status"
- ReportSteps _ _ -> "reportSteps"
- ReportLocation -> "reportLocation"
- ClearWaypoints -> "clearWaypoints"
- SetWaypoints _ -> "setWaypoints"
+ Dump -> "dump"
+ GetStatus -> "status"
+ ReportSteps _ _ -> "reportSteps"
+ ReportLocation -> "reportLocation"
+ ClearWaypoints -> "clearWaypoints"
+ SetWaypoints _ -> "setWaypoints"
SetConfiguration _ -> "setConfiguration"
- GetWaypoints -> "waypoints"
+ GetWaypoints -> "waypoints"
others = case c of
- ReportSteps f t -> [ "from" .= f, "to" .= t ]
- SetWaypoints ws -> [ "waypoints" .= ws ]
+ ReportSteps f t -> [ "from" .= f, "to" .= t ]
+ SetWaypoints ws -> [ "waypoints" .= ws ]
SetConfiguration c -> [ "configuration" .= c ]
- _ -> []
+ _ -> []
diff --git a/lib/OwnTracks/Location.hs b/lib/OwnTracks/Location.hs
index 987de73..6a0fbde 100644
--- a/lib/OwnTracks/Location.hs
+++ b/lib/OwnTracks/Location.hs
@@ -17,10 +17,7 @@ import Data.Functor ((<&>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
-import Data.Time (
- UTCTime,
- defaultTimeLocale,
- parseTimeM)
+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM)
import Database.Persist
import GHC.Generics (Generic)
diff --git a/lib/Persist.hs b/lib/Persist.hs
index 405e815..d5dc712 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -10,7 +10,8 @@
-- also a few little convenience functions for using persistent.
module Persist where
-import Data.Aeson (FromJSON, ToJSON, ToJSONKey, Value)
+import Data.Aeson (FromJSON, ToJSON, ToJSONKey,
+ Value)
import Data.Swagger (ToParamSchema (..), ToSchema (..),
genericDeclareNamedSchema)
import Data.Text (Text)
@@ -47,10 +48,10 @@ import Database.Persist.Postgresql (SqlBackend, runSqlPool)
import Fmt
import GHC.Generics (Generic)
import MultiLangText (MultiLangText)
+import qualified OwnTracks
import Server.Util (runLogging)
import Web.PathPieces (PathPiece)
import Yesod (Lang)
-import qualified OwnTracks
-- newtype TrackerId = TrackerId UUID
diff --git a/lib/Server.hs b/lib/Server.hs
index e418226..4eb101d 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -43,9 +43,9 @@ import Servant.Swagger (toSwagger)
import Server.Base (ServerState)
import Server.Frontend (Frontend (..))
import Server.GTFS_RT (gtfsRealtimeServer)
-import Server.Ingest (handleTrackerRegister,
- handlePing, handleWS,
- handleOwntracksMessage)
+import Server.Ingest (handleOwntracksMessage,
+ handlePing, handleTrackerRegister,
+ handleWS)
import Server.Subscribe (handleSubscribe)
import Server.Util (Service, runLogging, runService,
serveDirectoryFileServer)
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs
index 7fc2874..8813200 100644
--- a/lib/Server/Frontend/Ticker.hs
+++ b/lib/Server/Frontend/Ticker.hs
@@ -1,15 +1,15 @@
-{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE QuasiQuotes #-}
module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where
-import Data.Functor ((<&>))
-import Data.Time (getCurrentTime)
-import Persist (EntityField (TickerAnnouncementArchived),
- TickerAnnouncement (..))
-import Server.Frontend.Routes (FrontendMessage (..), Handler,
- Route (..), Widget)
-import Yesod hiding ((==.), (=.), update)
-import Database.Esqueleto.Experimental hiding ((<&>))
+import Data.Functor ((<&>))
+import Data.Time (getCurrentTime)
+import Database.Esqueleto.Experimental hiding ((<&>))
+import Persist (EntityField (TickerAnnouncementArchived),
+ TickerAnnouncement (..))
+import Server.Frontend.Routes (FrontendMessage (..), Handler,
+ Route (..), Widget)
+import Yesod hiding (update, (=.), (==.))
tickerAnnounceForm
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index fc7d777..76146df 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -1,8 +1,8 @@
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE BlockArguments #-}
module Server.Frontend.Tickets
( getTicketsR
@@ -16,47 +16,50 @@ module Server.Frontend.Tickets
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 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.Frontend.SpaceTime (mkSpaceTimeDiagram,
- mkSpaceTimeDiagramHandler)
-import Server.Frontend.Ticker (tickerWidget)
-import Server.Util (Service, secondsNow)
-import Text.Read (readMaybe)
-import Yesod hiding ((==.), (||.), delete, update, (=.))
+import Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
+ mkSpaceTimeDiagramHandler)
+import Server.Frontend.Ticker (tickerWidget)
+import Server.Util (Service, secondsNow)
+import Text.Read (readMaybe)
import qualified Yesod
+import Yesod hiding (delete, update, (=.),
+ (==.), (||.))
import Yesod.Auth
-import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
-import Database.Esqueleto.Experimental hiding ((<&>), on) -- , on, delete, update, (=.))
+import Database.Esqueleto.Experimental (asc, associateJoin, orderBy,
+ where_, (:&) (..), (^.))
+import Database.Esqueleto.Experimental hiding (on, (<&>))
import qualified Database.Esqueleto.Experimental as E
-import Database.Esqueleto.Experimental ((^.), (:&)(..), where_, orderBy, asc, associateJoin)
getTicketsR :: Handler Html
getTicketsR = do
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index 532af89..4b16a5b 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -8,6 +8,7 @@
module Server.GTFS_RT (gtfsRealtimeServer) where
import API (GtfsRealtimeAPI)
+import Config (ServerConfig (..))
import Control.Lens ((&), (.~))
import Control.Monad (forM)
import Control.Monad.Extra (mapMaybeM)
@@ -45,16 +46,15 @@ import GTFS (Depth (..), GTFS (..),
toSeconds, toUTC, tripsOnDay)
import Persist (Announcement (..),
EntityField (..), Key (..),
- Station (..), Stop (..),
- Ticket (..), TrackerId (..),
- Tracker (..), TrainAnchor (..),
- Ping (..), latitude,
+ Ping (..), Station (..),
+ Stop (..), Ticket (..),
+ Tracker (..), TrackerId (..),
+ TrainAnchor (..), latitude,
longitude, runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
import Servant.API ((:<|>) (..))
import Server.Util (Service, secondsNow)
-import Config (ServerConfig (..))
-- | formats a day in the "stupid" format used by gtfs realtime
toStupidDate :: Day -> Text
diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs
index 363088c..8e122a7 100644
--- a/lib/Server/Ingest.hs
+++ b/lib/Server/Ingest.hs
@@ -13,9 +13,9 @@ import Control.Monad.Catch (handle)
import Control.Monad.Extra (ifM, mapMaybeM, whenJust,
whenJustM)
import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Logger (LoggingT, logInfoN,
- logErrorN,
- logWarnN, logDebugN)
+import Control.Monad.Logger (LoggingT, logDebugN,
+ logErrorN, logInfoN,
+ logWarnN)
import Control.Monad.Reader (ReaderT)
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as C8
@@ -37,7 +37,8 @@ import Fmt ((+|), (|+))
import qualified GTFS
import qualified Network.WebSockets as WS
import Persist
-import Servant (err400, err401, throwError)
+import Servant (err400, err401,
+ throwError)
import Servant.Server (Handler)
import Server.Util (ServiceM, getTzseries,
utcToSeconds)
@@ -49,20 +50,21 @@ import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Foldable (find, minimumBy)
import Data.Function (on, (&))
+import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
import qualified Data.UUID as UUID
+import Database.Esqueleto.Experimental (from, selectOne, table,
+ val, where_, (^.))
+import qualified Database.Esqueleto.Experimental as E
import Extrapolation (Extrapolator (..),
LinearExtrapolator (..),
euclid)
import GHC.Generics (Generic)
import GTFS (seconds2Double)
+import OwnTracks hiding (Ping)
import Prometheus (decGauge, incGauge)
import Server.Base (ServerState)
-import OwnTracks hiding (Ping)
-import Database.Esqueleto.Experimental (selectOne, where_, (^.), table, from, val)
-import qualified Database.Esqueleto.Experimental as E
-import Data.Maybe (fromJust)
handleTrackerRegister
:: Pool SqlBackend
@@ -128,7 +130,7 @@ handleOwntracksMessage
handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do
user <- case maybeUser of
Just user -> pure user
- Nothing -> throwError err401
+ Nothing -> throwError err401
-- TODO: maybe get the basic json here, and put it into a log-msg table?
diff --git a/lib/Server/Subscribe.hs b/lib/Server/Subscribe.hs
index 5b0edb5..86b67a6 100644
--- a/lib/Server/Subscribe.hs
+++ b/lib/Server/Subscribe.hs
@@ -1,25 +1,26 @@
-{-# LANGUAGE BlockArguments#-}
+{-# LANGUAGE BlockArguments #-}
module Server.Subscribe where
-import Conduit (MonadIO (..))
-import Control.Concurrent.STM (atomically, newTQueue, readTQueue,
- readTVar, writeTVar)
-import Control.Exception (handle)
-import Control.Monad.Extra (forever, whenJust)
-import qualified Data.Aeson as A
-import qualified Data.ByteString.Char8 as C8
-import Data.Coerce (coerce)
-import Data.Functor ((<&>))
-import Data.Map (Map)
-import qualified Data.Map as M
+import Conduit (MonadIO (..))
+import Control.Concurrent.STM (atomically, newTQueue,
+ readTQueue, readTVar,
+ writeTVar)
+import Control.Exception (handle)
+import Control.Monad.Extra (forever, whenJust)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as C8
+import Data.Coerce (coerce)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import qualified Data.Map as M
import Data.Pool
-import Data.UUID (UUID)
-import Database.Persist.Sql (SqlBackend)
-import qualified Network.WebSockets as WS
+import Data.UUID (UUID)
+import Database.Esqueleto.Experimental hiding ((<&>))
+import Database.Persist.Sql (SqlBackend)
+import qualified Network.WebSockets as WS
import Persist
-import Server.Base (ServerState)
-import Server.Util (ServiceM)
-import Database.Esqueleto.Experimental hiding ((<&>))
+import Server.Base (ServerState)
+import Server.Util (ServiceM)
handleSubscribe
:: Pool SqlBackend
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-16 19:22:08 +0000