souplesse/lib/Store.hs

{-# 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, migrateSession, migrateTrkpt
             ) 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 "migrateSession"]
  [persistLowerCase|
Session
    startTime UTCTime
    duration PgInterval
    draft Bool default=True
    notes String Maybe
|]

share
  [mkPersist sqlSettings, mkMigrate "migrateTrkpt"]
  [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 = 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