Daniel Barlow
6c3eb694f0
a session is a series of points which we assume (or the rider confirms) comprise a complete and continuous ride
122 lines
3.8 KiB
Haskell
122 lines
3.8 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE EmptyDataDecls #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Store (save, fetch, sessions, sessionStartTime, sessionDuration, migrateAll) where
|
|
|
|
import Control.Exception
|
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
import Control.Monad.Trans.Reader (ReaderT)
|
|
import Data.Maybe (isJust)
|
|
import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, addUTCTime)
|
|
import Database.Persist
|
|
import Database.Persist.Class
|
|
import Database.Persist.Postgresql
|
|
( ConnectionString,
|
|
SqlBackend,
|
|
createPostgresqlPool,
|
|
pgConnStr,
|
|
pgPoolSize,
|
|
runMigration,
|
|
runSqlPool,
|
|
rawExecute,
|
|
PgInterval
|
|
)
|
|
import Database.Persist.TH
|
|
import Text.Read (readMaybe)
|
|
import Track (Point (..), Pos (..))
|
|
import Track as T
|
|
import Text.RawString.QQ (r)
|
|
|
|
connString :: ConnectionString
|
|
connString = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
|
|
|
|
share
|
|
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
|
[persistLowerCase|
|
|
Trkpt
|
|
lat Double
|
|
lon Double
|
|
ele Double Maybe
|
|
time UTCTime
|
|
cadence Int Maybe
|
|
power Int Maybe
|
|
heartRate Int Maybe
|
|
|
|
Session
|
|
startTime UTCTime
|
|
duration PgInterval
|
|
draft Bool default=True
|
|
notes String Maybe
|
|
|]
|
|
|
|
fromPoint :: Point -> Trkpt
|
|
fromPoint p =
|
|
let Pos lat lon ele = T.pos p
|
|
in Trkpt lat lon ele (T.time p) (T.cadence p) (T.power p) (T.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)
|
|
|
|
updateSessions = [r|
|
|
-- delete existing drafts as new data may extend one of them
|
|
delete from session where draft;
|
|
-- find all potential start points in the new data
|
|
insert into session(start_time, duration, draft) (select time as start_time, make_interval(0) as duration, true as draft from trkpt as p where not exists (select id from session where start_time <= p.time and (start_time + duration) > p.time) and not exists(select * from trkpt as p1 where time > p.time - '600 seconds'::interval and time < p.time));
|
|
-- reset durations
|
|
update session s1
|
|
set duration =
|
|
coalesce(
|
|
(select max(time) from trkpt t1
|
|
where t1.time < coalesce((select min(start_time) from session s2 where s2.start_time > s1.start_time), now())) - s1.start_time
|
|
, make_interval())
|
|
where draft;
|
|
|]
|
|
|
|
data OverlapExists = OverlapExists String deriving (Show)
|
|
|
|
instance Exception OverlapExists
|
|
|
|
sessions :: (MonadIO m) => ReaderT SqlBackend m [Session]
|
|
sessions = do
|
|
s <- selectList [SessionDraft !=. True] [Desc SessionStartTime, LimitTo 10]
|
|
return $ map (\(Entity _ x) -> x) s
|
|
|
|
|
|
save :: (MonadIO m) => Track -> ReaderT SqlBackend m (Either OverlapExists Track)
|
|
save track = do
|
|
let start = startTime track
|
|
finish = addUTCTime (duration track) (startTime track)
|
|
priors <- selectFirst [TrkptTime >. start, TrkptTime <. finish] []
|
|
if isJust priors
|
|
then return $ Left (OverlapExists "track overlaps with existing data")
|
|
else do
|
|
mapM_ (insert . fromPoint) track
|
|
rawExecute updateSessions []
|
|
return $ Right track
|
|
|
|
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 $ map toPoint trkpts
|