dan/souplesse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

merge Store into Point

Browse Source
This commit is contained in:
Daniel Barlow 2024-11-11 21:13:32 +00:00
parent 9a9c41a2ba
commit 5032c7408c
6 changed files with 112 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
app/Main.hs
View File

@ -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'

106
lib/Point.hs
View File

@ -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

4
lib/Session.hs
View File

@ -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

99
lib/Store.hs
View File

@ -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

14
lib/Track.hs
View File

@ -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

1
souplesse.cabal
View File

@ -97,7 +97,6 @@ executable souplesse
library souplesse-lib
exposed-modules:
Track
Store
Point
Session
hs-source-dirs: