165 lines
4.2 KiB
Haskell
165 lines
4.2 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE EmptyDataDecls #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Point
|
|
( Pos (..),
|
|
Point (..),
|
|
save,
|
|
fetch,
|
|
migration,
|
|
)
|
|
where
|
|
|
|
import Control.Exception
|
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
import Control.Monad.Trans.Reader (ReaderT)
|
|
import Data.Aeson
|
|
import Data.ByteString.Lazy.Char8 qualified as L
|
|
import Data.Either
|
|
import Data.Functor ((<&>))
|
|
import Data.List as List
|
|
import Data.List qualified
|
|
import Data.Map as Map
|
|
import Data.Maybe (isJust)
|
|
import Data.Text qualified
|
|
import Data.Text.Lazy as T
|
|
import Data.Time
|
|
import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, addUTCTime)
|
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
|
import Data.Time.ISO8601 qualified
|
|
import Database.Persist
|
|
import Database.Persist.Class
|
|
import Database.Persist.Postgresql
|
|
( ConnectionString,
|
|
SqlBackend,
|
|
createPostgresqlPool,
|
|
pgConnStr,
|
|
pgPoolSize,
|
|
rawExecute,
|
|
runMigration,
|
|
runSqlPool,
|
|
)
|
|
import Database.Persist.TH
|
|
import Debug.Trace (trace, traceShow)
|
|
import Session qualified
|
|
import Text.Read (readMaybe)
|
|
import Text.XML
|
|
import Text.XML.Cursor as Cursor
|
|
|
|
-- import Track (Point (..), Pos (..))
|
|
-- import Track as T
|
|
|
|
data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
|
|
|
|
type Power = Maybe Int
|
|
|
|
type Cadence = Maybe Int
|
|
|
|
type HeartRate = Maybe Int
|
|
|
|
data Point = Point
|
|
{ pos :: Pos,
|
|
time :: UTCTime,
|
|
cadence :: Cadence,
|
|
power :: Power,
|
|
heartRate :: HeartRate
|
|
}
|
|
deriving (Show)
|
|
|
|
instance ToJSON Pos where
|
|
toJSON (Pos lat lon ele) =
|
|
case ele of
|
|
Just e -> object ["lat" .= lat, "lon" .= lon, "ele" .= e]
|
|
Nothing -> object ["lat" .= lat, "lon" .= lon, "ele" .= Null]
|
|
|
|
instance ToJSON Point where
|
|
toJSON Point {..} =
|
|
object
|
|
[ "pos" .= pos,
|
|
"time" .= utcTimeToPOSIXSeconds time,
|
|
"cadence" .= cadence,
|
|
"power" .= power,
|
|
"heartRate" .= heartRate
|
|
]
|
|
|
|
share
|
|
[mkPersist sqlSettings, mkMigrate "migration"]
|
|
[persistLowerCase|
|
|
Trkpt
|
|
lat Double
|
|
lon Double
|
|
ele Double Maybe
|
|
time UTCTime
|
|
cadence Int Maybe
|
|
power Int Maybe
|
|
heartRate Int Maybe
|
|
|]
|
|
|
|
fromPoint :: Point -> Trkpt
|
|
fromPoint p =
|
|
let Pos lat lon ele = pos p
|
|
in Trkpt lat lon ele (time p) (cadence p) (power p) (heartRate p)
|
|
|
|
toPoint :: Entity Trkpt -> Point
|
|
toPoint entity =
|
|
let tkp = (\(Entity _ tkp) -> tkp) entity
|
|
pos = Pos (trkptLat tkp) (trkptLon tkp) (trkptEle tkp)
|
|
in Point
|
|
pos
|
|
(trkptTime tkp)
|
|
(trkptCadence tkp)
|
|
(trkptPower tkp)
|
|
(trkptHeartRate tkp)
|
|
|
|
data OverlapExists = OverlapExists String deriving (Show)
|
|
|
|
instance Exception OverlapExists
|
|
|
|
fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point]
|
|
fetch start duration = do
|
|
let finish = addUTCTime duration start
|
|
trkpts <- selectList [TrkptTime >. start, TrkptTime <. finish] []
|
|
return $ List.map toPoint trkpts
|
|
|
|
-- any :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m Bool
|
|
any start duration = do
|
|
let finish = addUTCTime duration start
|
|
exists <- selectFirst [TrkptTime >. start, TrkptTime <. finish] []
|
|
return $ isJust exists
|
|
|
|
startTime :: [Point] -> UTCTime
|
|
startTime (p : ps) = List.foldr (\a b -> min b (time a)) (time p) ps
|
|
|
|
duration :: [Point] -> NominalDiffTime
|
|
duration track =
|
|
case track of
|
|
[] -> 0
|
|
(p : ps) ->
|
|
let start = startTime track
|
|
finish = List.foldr (\a b -> max b (time a)) (time p) ps
|
|
in diffUTCTime finish start
|
|
|
|
save :: (MonadIO m) => [Point] -> ReaderT SqlBackend m (Either OverlapExists [Point])
|
|
save track = do
|
|
let start = startTime track
|
|
priors <- Point.any start (duration track)
|
|
if priors
|
|
then return $ Left (OverlapExists "track overlaps with existing data")
|
|
else do
|
|
mapM_ (Database.Persist.Class.insert . fromPoint) track
|
|
Session.refreshDrafts
|
|
return $ Right track
|