extract Session module

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|
 <h1>Calendar

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

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]

souplesse.cabal

@@ -99,6 +99,7 @@ library souplesse-lib
         Track
         Store
         Point
+        Session
     hs-source-dirs:
         lib
     build-depends: