souplesse

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

Session.hs (2551B)

      1 {-# LANGUAGE DataKinds #-}
      2 {-# LANGUAGE DerivingStrategies #-}
      3 {-# LANGUAGE EmptyDataDecls #-}
      4 {-# LANGUAGE FlexibleContexts #-}
      5 {-# LANGUAGE FlexibleInstances #-}
      6 {-# LANGUAGE GADTs #-}
      7 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
      8 {-# LANGUAGE MultiParamTypeClasses #-}
      9 {-# LANGUAGE OverloadedStrings #-}
     10 {-# LANGUAGE QuasiQuotes #-}
     11 {-# LANGUAGE StandaloneDeriving #-}
     12 {-# LANGUAGE TemplateHaskell #-}
     13 {-# LANGUAGE TypeFamilies #-}
     14 {-# LANGUAGE UndecidableInstances #-}
     15 
     16 module Session
     17   ( Session (..),
     18     recents,
     19     refreshDrafts,
     20     migration,
     21   )
     22 where
     23 
     24 import Control.Monad.IO.Class (MonadIO)
     25 import Control.Monad.Trans.Reader (ReaderT)
     26 import Data.Text
     27 import Data.Time.Clock
     28   ( NominalDiffTime,
     29     UTCTime,
     30   )
     31 import Database.Persist
     32 import Database.Persist.Postgresql
     33   ( PgInterval,
     34     SqlBackend,
     35     getPgInterval,
     36     rawExecute,
     37   )
     38 import Database.Persist.TH
     39 import Text.RawString.QQ (r)
     40 
     41 share
     42   [mkPersist sqlSettings, mkMigrate "migration"]
     43   [persistLowerCase|
     44 SessionRow sql=session
     45     startTime UTCTime
     46     duration PgInterval
     47     draft Bool default=True
     48     notes String Maybe
     49 |]
     50 
     51 data Session = Session
     52   { startTime :: UTCTime,
     53     duration :: NominalDiffTime,
     54     draft :: Bool,
     55     notes :: Maybe String
     56   }
     57 
     58 fromEntity :: Entity SessionRow -> Session
     59 fromEntity (Entity _ row) =
     60   Session
     61     (sessionRowStartTime row)
     62     (getPgInterval (sessionRowDuration row))
     63     (sessionRowDraft row)
     64     (sessionRowNotes row)
     65 
     66 updateSql :: Text
     67 updateSql =
     68   [r|
     69 -- delete existing drafts as new data may extend one of them
     70 delete from session where draft;
     71 -- find all potential start points in the new data
     72 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));
     73 -- reset durations
     74  update session s1
     75  set duration =
     76     coalesce(
     77     (select max(time) from trkpt t1
     78      where t1.time < coalesce((select min(start_time) from session s2 where s2.start_time > s1.start_time), now())) - s1.start_time
     79      , make_interval())
     80 where draft;
     81 |]
     82 
     83 refreshDrafts :: (MonadIO m) => ReaderT SqlBackend m ()
     84 refreshDrafts =
     85   rawExecute updateSql []
     86 
     87 recents :: (MonadIO m) => ReaderT SqlBackend m [Session]
     88 recents = do
     89   s <- selectList [SessionRowDraft !=. True] [Desc SessionRowStartTime, LimitTo 10]
     90   return $ Prelude.map fromEntity s