add "session"
a session is a series of points which we assume (or the rider confirms) comprise a complete and continuous ride
This commit is contained in:
parent
b21eda22ad
commit
6c3eb694f0
@ -56,11 +56,16 @@ instance YesodPersist Souplesse where
|
||||
getCalendarR :: Handler Html
|
||||
getCalendarR = do
|
||||
(formWidget, _) <- generateFormPost uploadForm
|
||||
sessions' <- runDB Store.sessions
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
<h1>Calendar
|
||||
|
||||
<p>A calendar view goes here
|
||||
<ul>
|
||||
$forall s <- sessions'
|
||||
<li>#{show $ sessionStartTime s} #{show $ sessionDuration s}
|
||||
|
||||
|
||||
<form action="/upload" method=post enctype="multipart/form-data">
|
||||
^{formWidget}
|
||||
|
33
lib/Store.hs
33
lib/Store.hs
@ -13,7 +13,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Store (save, fetch, migrateAll) where
|
||||
module Store (save, fetch, sessions, sessionStartTime, sessionDuration, migrateAll) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
@ -30,11 +30,14 @@ import Database.Persist.Postgresql
|
||||
pgPoolSize,
|
||||
runMigration,
|
||||
runSqlPool,
|
||||
rawExecute,
|
||||
PgInterval
|
||||
)
|
||||
import Database.Persist.TH
|
||||
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"
|
||||
@ -50,6 +53,12 @@ Trkpt
|
||||
cadence Int Maybe
|
||||
power Int Maybe
|
||||
heartRate Int Maybe
|
||||
|
||||
Session
|
||||
startTime UTCTime
|
||||
duration PgInterval
|
||||
draft Bool default=True
|
||||
notes String Maybe
|
||||
|]
|
||||
|
||||
fromPoint :: Point -> Trkpt
|
||||
@ -68,10 +77,31 @@ 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
|
||||
@ -81,6 +111,7 @@ save track = do
|
||||
then return $ Left (OverlapExists "track overlaps with existing data")
|
||||
else do
|
||||
mapM_ (insert . fromPoint) track
|
||||
rawExecute updateSessions []
|
||||
return $ Right track
|
||||
|
||||
fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point]
|
||||
|
@ -108,6 +108,7 @@ library souplesse-lib
|
||||
, time
|
||||
, containers
|
||||
, text
|
||||
, raw-strings-qq
|
||||
, transformers
|
||||
, persistent
|
||||
, persistent-postgresql
|
||||
|
Loading…
Reference in New Issue
Block a user