souplesse

commit 9a9c41a2baddb09f503652408702d199a8ac4c56
parent 8988bb5b6110cefc7e37329cc122ae2e46127d89
Author: Daniel Barlow <dan@telent.net>
Date:   Mon, 11 Nov 2024 19:14:21 +0000

export Session.duration as NominalDiffTime

Diffstat:
M
app/Main.hs
 | 
12
++++++------
M
lib/Session.hs
 | 
27
++++++++++++++++++++++-----
M
lib/Store.hs
 | 
6
+++---

3 files changed, 31 insertions(+), 14 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
@@ -16,9 +16,9 @@ import Data.Text.Lazy.Builder qualified as B
 import Data.Text.Lazy.Builder.Int qualified as B
 import Data.Time.Clock (nominalDiffTimeToSeconds)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
-import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, getPgInterval, runMigration, runSqlPool, withPostgresqlPool)
+import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
 import Debug.Trace (traceShow)
-import Session
+import Session qualified
 import Store
 import Track (parseBS)
 import Yesod.Core
@@ -59,13 +59,13 @@ instance YesodPersist Souplesse where
     Souplesse pool _ <- getYesod
     runSqlPool action pool
 
-intToText :: Integral a => a -> T.Text
+intToText :: (Integral a) => a -> T.Text
 intToText = T.toStrict . B.toLazyText . B.decimal
 
 getCalendarR :: Handler Html
 getCalendarR = do
   let fTime = intToText . floor . utcTimeToPOSIXSeconds
-      fDur = intToText . ceiling . nominalDiffTimeToSeconds . getPgInterval
+      fDur = intToText . ceiling . nominalDiffTimeToSeconds
   (formWidget, _) <- generateFormPost uploadForm
   sessions' <- runDB Session.recents
   defaultLayout
@@ -76,7 +76,7 @@ getCalendarR = do
 <ul>
     $forall s <- sessions'
         <li>
-             <a href=@?{(TimelineR, [("start", fTime $ sessionStartTime s), ("duration", fDur $ sessionDuration s)])} > #{show $ sessionStartTime s} #{show $ getPgInterval (sessionDuration s)}
+             <a href=@?{(TimelineR, [("start", fTime $ Session.startTime s), ("duration", fDur $ Session.duration s)])} > #{show $ Session.startTime s} #{show (Session.duration s)}
 
 <form action="/upload" method=post enctype="multipart/form-data">
     ^{formWidget}
@@ -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 migrateSession
+    runMigration Session.migrateSession
     runMigration migrateTrkpt
   static' <- static "frontend"
   warp 3000 $ Souplesse pool static'
diff --git a/lib/Session.hs b/lib/Session.hs
@@ -25,13 +25,15 @@ import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Reader (ReaderT)
 import Data.Text
 import Data.Time.Clock
-  ( UTCTime,
+  ( NominalDiffTime,
+    UTCTime,
   )
 import Database.Persist
 import Database.Persist.Postgresql
   ( PgInterval,
     SqlBackend,
-    rawExecute
+    getPgInterval,
+    rawExecute,
   )
 import Database.Persist.TH
 import Text.RawString.QQ (r)
@@ -39,13 +41,28 @@ import Text.RawString.QQ (r)
 share
   [mkPersist sqlSettings, mkMigrate "migrateSession"]
   [persistLowerCase|
-Session
+SessionRow sql=session
     startTime UTCTime
     duration PgInterval
     draft Bool default=True
     notes String Maybe
 |]
 
+data Session = Session
+  { startTime :: UTCTime,
+    duration :: NominalDiffTime,
+    draft :: Bool,
+    notes :: Maybe String
+  }
+
+fromEntity :: Entity SessionRow -> Session
+fromEntity (Entity _ row) =
+  Session
+    (sessionRowStartTime row)
+    (getPgInterval (sessionRowDuration row))
+    (sessionRowDraft row)
+    (sessionRowNotes row)
+
 updateSql :: Text
 updateSql =
   [r|
@@ -69,5 +86,5 @@ refreshDrafts =
 
 recents :: (MonadIO m) => ReaderT SqlBackend m [Session]
 recents = do
-  s <- selectList [SessionDraft !=. True] [Desc SessionStartTime, LimitTo 10]
-  return $ Prelude.map (\(Entity _ x) -> x) s
+  s <- selectList [SessionRowDraft !=. True] [Desc SessionRowStartTime, LimitTo 10]
+  return $ Prelude.map fromEntity s
diff --git a/lib/Store.hs b/lib/Store.hs
@@ -39,7 +39,7 @@ import Database.Persist.Postgresql
     runSqlPool,
   )
 import Database.Persist.TH
-import Session
+import Session qualified
 import Text.Read (readMaybe)
 import Track (Point (..), Pos (..))
 import Track as T
@@ -82,8 +82,8 @@ instance Exception OverlapExists
 
 save :: (MonadIO m) => Track -> ReaderT SqlBackend m (Either OverlapExists Track)
 save track = do
-  let start = startTime track
-      finish = addUTCTime (duration track) (startTime track)
+  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")