commit 5032c7408c94569def13b24be0a1acbd21418405
parent 9a9c41a2baddb09f503652408702d199a8ac4c56
Author: Daniel Barlow <dan@telent.net>
Date: Mon, 11 Nov 2024 21:13:32 +0000
merge Store into Point
Diffstat:
6 files changed, 112 insertions(+), 122 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
@@ -18,8 +18,8 @@ import Data.Time.Clock (nominalDiffTimeToSeconds)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
import Debug.Trace (traceShow)
+import Point qualified (fetch, migration, save)
import Session qualified
-import Store
import Track (parseBS)
import Yesod.Core
import Yesod.Form.Fields
@@ -118,7 +118,7 @@ getPointsR = do
<*> ireq intField "duration"
let start' = posixSecondsToUTCTime $ fromInteger $ toInteger $ start tr
duration' = fromInteger $ toInteger $ duration tr
- points <- runDB $ Store.fetch start' duration'
+ points <- runDB $ Point.fetch start' duration'
returnJson (traceShow tr points)
data FileForm = FileForm
@@ -143,7 +143,7 @@ postUploadR = do
bs <- fileSourceByteString $ fileInfo upload
case Track.parseBS (fromStrict bs) of
Right points -> do
- eitherPoints <- runDB $ Store.save points
+ eitherPoints <- runDB $ Point.save points
case eitherPoints of
Right points' ->
defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
@@ -170,7 +170,7 @@ connStr = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=sec
main :: IO ()
main = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
runResourceT $ flip runSqlPool pool $ do
- runMigration Session.migrateSession
- runMigration migrateTrkpt
+ runMigration Session.migration
+ runMigration Point.migration
static' <- static "frontend"
warp 3000 $ Souplesse pool static'
diff --git a/lib/Point.hs b/lib/Point.hs
@@ -1,13 +1,31 @@
+{-# 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
@@ -15,17 +33,35 @@ import Data.Functor ((<&>))
import Data.List as List
import Data.List qualified
import Data.Map as Map
-import Data.Maybe
+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
@@ -58,3 +94,71 @@ instance ToJSON Point where
"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
diff --git a/lib/Session.hs b/lib/Session.hs
@@ -17,7 +17,7 @@ module Session
( Session (..),
recents,
refreshDrafts,
- migrateSession,
+ migration,
)
where
@@ -39,7 +39,7 @@ import Database.Persist.TH
import Text.RawString.QQ (r)
share
- [mkPersist sqlSettings, mkMigrate "migrateSession"]
+ [mkPersist sqlSettings, mkMigrate "migration"]
[persistLowerCase|
SessionRow sql=session
startTime UTCTime
diff --git a/lib/Store.hs b/lib/Store.hs
@@ -1,99 +0,0 @@
-{-# 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
diff --git a/lib/Track.hs b/lib/Track.hs
@@ -8,8 +8,6 @@ module Track
parseFile,
parseBS,
Track.length,
- startTime,
- duration,
)
where
@@ -97,18 +95,6 @@ parse str = do
length :: Track -> Int
length = Data.List.length
-startTime :: Track -> UTCTime
-startTime (p : ps) = List.foldr (\a b -> min b (time a)) (time p) ps
-
-duration :: Track -> 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
-
-- parseFile :: FilePath -> IO [Point]
parseFile name = do
gpx <- Text.XML.readFile def name
diff --git a/souplesse.cabal b/souplesse.cabal
@@ -97,7 +97,6 @@ executable souplesse
library souplesse-lib
exposed-modules:
Track
- Store
Point
Session
hs-source-dirs:
