diff --git a/app/Main.hs b/app/Main.hs index 7a156bb..fe2377a 100644 --- 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|

#{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 index 39e6488..4e5c554 100644 --- 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 index 30d2fe3..9725595 100644 --- 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 deleted file mode 100644 index 7f142f0..0000000 --- a/lib/Store.hs +++ /dev/null @@ -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 index a0842fc..f00c237 100644 --- 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 index 1e69bb9..024f507 100644 --- a/souplesse.cabal +++ b/souplesse.cabal @@ -97,7 +97,6 @@ executable souplesse library souplesse-lib exposed-modules: Track - Store Point Session hs-source-dirs: