{-# 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, migrateTrkpt, module Session, ) 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, rawExecute, runMigration, runSqlPool, ) import Database.Persist.TH import Session qualified import Text.Read (readMaybe) import Track (Point (..), Pos (..)) import Track as T connString :: ConnectionString connString = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret" 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) data OverlapExists = OverlapExists String deriving (Show) instance Exception OverlapExists save :: (MonadIO m) => Track -> ReaderT SqlBackend m (Either OverlapExists Track) save track = do let start = T.startTime track finish = addUTCTime (T.duration track) (T.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 Session.refreshDrafts 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