diff --git a/app/Main.hs b/app/Main.hs index 197d662..9cd42b3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,6 +13,7 @@ import Data.List as List import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool) import Debug.Trace (traceShow) +import Session import Store import Track (parseBS) import Yesod.Core @@ -56,7 +57,7 @@ instance YesodPersist Souplesse where getCalendarR :: Handler Html getCalendarR = do (formWidget, _) <- generateFormPost uploadForm - sessions' <- runDB Store.sessions + sessions' <- runDB Session.recents defaultLayout [whamlet|

Calendar diff --git a/lib/Session.hs b/lib/Session.hs new file mode 100644 index 0000000..1860307 --- /dev/null +++ b/lib/Session.hs @@ -0,0 +1,69 @@ +{-# 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 Session + ( Session(..) + , recents + , updateSessions + , migrateSession + ) where + +import Data.Text +import Text.RawString.QQ (r) +import Data.Time.Clock ( + UTCTime, + ) + +import Database.Persist +-- import Database.Persist.Class +import Database.Persist.TH +import Database.Persist.Postgresql + ( SqlBackend, + PgInterval + ) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Reader (ReaderT) + + +share + [mkPersist sqlSettings, mkMigrate "migrateSession"] + [persistLowerCase| +Session + startTime UTCTime + duration PgInterval + draft Bool default=True + notes String Maybe +|] + +updateSessions :: Text +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; +|] + +recents :: (MonadIO m) => ReaderT SqlBackend m [Session] +recents = do + s <- selectList [SessionDraft !=. True] [Desc SessionStartTime, LimitTo 10] + return $ Prelude.map (\(Entity _ x) -> x) s diff --git a/lib/Store.hs b/lib/Store.hs index 60250aa..e634180 100644 --- a/lib/Store.hs +++ b/lib/Store.hs @@ -13,9 +13,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Store (save, fetch, sessions, sessionStartTime, - sessionDuration, migrateSession, migrateTrkpt - ) where +module Store + ( save, + fetch, + migrateTrkpt, + module Session, + ) +where import Control.Exception import Control.Monad.IO.Class (MonadIO, liftIO) @@ -30,30 +34,19 @@ import Database.Persist.Postgresql createPostgresqlPool, pgConnStr, pgPoolSize, + rawExecute, runMigration, runSqlPool, - rawExecute, - PgInterval ) import Database.Persist.TH +import Session 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| @@ -67,7 +60,6 @@ Trkpt heartRate Int Maybe |] - fromPoint :: Point -> Trkpt fromPoint p = let Pos lat lon ele = T.pos p @@ -84,31 +76,10 @@ toPoint entity = (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 @@ -118,7 +89,7 @@ save track = do then return $ Left (OverlapExists "track overlaps with existing data") else do mapM_ (insert . fromPoint) track - rawExecute updateSessions [] + rawExecute Session.updateSessions [] return $ Right track fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point] diff --git a/souplesse.cabal b/souplesse.cabal index f59672e..1e69bb9 100644 --- a/souplesse.cabal +++ b/souplesse.cabal @@ -99,6 +99,7 @@ library souplesse-lib Track Store Point + Session hs-source-dirs: lib build-depends: