merge Store into Point

app/Main.hs

@@ -18,8 +18,8 @@ import Data.Time.Clock (nominalDiffTimeToSeconds)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
 import Debug.Trace (traceShow)
+import Point qualified (fetch, migration, save)
 import Session qualified
-import Store
 import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
@@ -118,7 +118,7 @@ getPointsR = do
         <*> ireq intField "duration"
   let start' = posixSecondsToUTCTime $ fromInteger $ toInteger $ start tr
       duration' = fromInteger $ toInteger $ duration tr
-  points <- runDB $ Store.fetch start' duration'
+  points <- runDB $ Point.fetch start' duration'
   returnJson (traceShow tr points)
 
 data FileForm = FileForm
@@ -143,7 +143,7 @@ postUploadR = do
       bs <- fileSourceByteString $ fileInfo upload
       case Track.parseBS (fromStrict bs) of
         Right points -> do
-          eitherPoints <- runDB $ Store.save points
+          eitherPoints <- runDB $ Point.save points
           case eitherPoints of
             Right points' ->
               defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
@@ -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 Session.migrateSession
+    runMigration Session.migration
-    runMigration migrateTrkpt
+    runMigration Point.migration
   static' <- static "frontend"
   warp 3000 $ Souplesse pool static'

lib/Point.hs

@@ -1,13 +1,31 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Point
   ( Pos (..),
     Point (..),
+    save,
+    fetch,
+    migration,
   )
 where
 
 import Control.Exception
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Reader (ReaderT)
 import Data.Aeson
 import Data.ByteString.Lazy.Char8 qualified as L
 import Data.Either
@@ -15,17 +33,35 @@ import Data.Functor ((<&>))
 import Data.List as List
 import Data.List qualified
 import Data.Map as Map
-import Data.Maybe
+import Data.Maybe (isJust)
 import Data.Text qualified
 import Data.Text.Lazy as T
 import Data.Time
+import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, addUTCTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Time.ISO8601 qualified
+import Database.Persist
+import Database.Persist.Class
+import Database.Persist.Postgresql
+  ( ConnectionString,
+    SqlBackend,
+    createPostgresqlPool,
+    pgConnStr,
+    pgPoolSize,
+    rawExecute,
+    runMigration,
+    runSqlPool,
+  )
+import Database.Persist.TH
 import Debug.Trace (trace, traceShow)
+import Session qualified
 import Text.Read (readMaybe)
 import Text.XML
 import Text.XML.Cursor as Cursor
 
+-- import Track (Point (..), Pos (..))
+-- import Track as T
+
 data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
 
 type Power = Maybe Int
@@ -58,3 +94,71 @@ instance ToJSON Point where
         "power" .= power,
         "heartRate" .= heartRate
       ]
+
+share
+  [mkPersist sqlSettings, mkMigrate "migration"]
+  [persistLowerCase|
+Trkpt
+    lat Double
+    lon Double
+    ele Double Maybe
+    time UTCTime
+    cadence Int Maybe
+    power Int Maybe
+    heartRate  Int Maybe
+|]
+
+fromPoint :: Point -> Trkpt
+fromPoint p =
+  let Pos lat lon ele = pos p
+   in Trkpt lat lon ele (time p) (cadence p) (power p) (heartRate p)
+
+toPoint :: Entity Trkpt -> Point
+toPoint entity =
+  let tkp = (\(Entity _ tkp) -> tkp) entity
+      pos = Pos (trkptLat tkp) (trkptLon tkp) (trkptEle tkp)
+   in Point
+        pos
+        (trkptTime tkp)
+        (trkptCadence tkp)
+        (trkptPower tkp)
+        (trkptHeartRate tkp)
+
+data OverlapExists = OverlapExists String deriving (Show)
+
+instance Exception OverlapExists
+
+fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point]
+fetch start duration = do
+  let finish = addUTCTime duration start
+  trkpts <- selectList [TrkptTime >. start, TrkptTime <. finish] []
+  return $ List.map toPoint trkpts
+
+-- any :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m Bool
+any start duration = do
+  let finish = addUTCTime duration start
+  exists <- selectFirst [TrkptTime >. start, TrkptTime <. finish] []
+  return $ isJust exists
+
+startTime :: [Point] -> UTCTime
+startTime (p : ps) = List.foldr (\a b -> min b (time a)) (time p) ps
+
+duration :: [Point] -> NominalDiffTime
+duration track =
+  case track of
+    [] -> 0
+    (p : ps) ->
+      let start = startTime track
+          finish = List.foldr (\a b -> max b (time a)) (time p) ps
+       in diffUTCTime finish start
+
+save :: (MonadIO m) => [Point] -> ReaderT SqlBackend m (Either OverlapExists [Point])
+save track = do
+  let start = startTime track
+  priors <- Point.any start (duration track)
+  if priors
+    then return $ Left (OverlapExists "track overlaps with existing data")
+    else do
+      mapM_ (Database.Persist.Class.insert . fromPoint) track
+      Session.refreshDrafts
+      return $ Right track

lib/Session.hs

@@ -17,7 +17,7 @@ module Session
   ( Session (..),
     recents,
     refreshDrafts,
-    migrateSession,
+    migration,
   )
 where
 
@@ -39,7 +39,7 @@ import Database.Persist.TH
 import Text.RawString.QQ (r)
 
 share
-  [mkPersist sqlSettings, mkMigrate "migrateSession"]
+  [mkPersist sqlSettings, mkMigrate "migration"]
   [persistLowerCase|
 SessionRow sql=session
     startTime UTCTime

lib/Store.hs

@@ -1,99 +0,0 @@
-{-# 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 Store
-  ( save,
-    fetch,
-    migrateTrkpt,
-    module Session,
-  )
-where
-
-import Control.Exception
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Trans.Reader (ReaderT)
-import Data.Maybe (isJust)
-import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, addUTCTime)
-import Database.Persist
-import Database.Persist.Class
-import Database.Persist.Postgresql
-  ( ConnectionString,
-    SqlBackend,
-    createPostgresqlPool,
-    pgConnStr,
-    pgPoolSize,
-    rawExecute,
-    runMigration,
-    runSqlPool,
-  )
-import Database.Persist.TH
-import Session qualified
-import Text.Read (readMaybe)
-import Track (Point (..), Pos (..))
-import Track as T
-
-connString :: ConnectionString
-connString = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
-
-share
-  [mkPersist sqlSettings, mkMigrate "migrateTrkpt"]
-  [persistLowerCase|
-Trkpt
-    lat Double
-    lon Double
-    ele Double Maybe
-    time UTCTime
-    cadence Int Maybe
-    power Int Maybe
-    heartRate  Int Maybe
-|]
-
-fromPoint :: Point -> Trkpt
-fromPoint p =
-  let Pos lat lon ele = T.pos p
-   in Trkpt lat lon ele (T.time p) (T.cadence p) (T.power p) (T.heartRate p)
-
-toPoint :: Entity Trkpt -> Point
-toPoint entity =
-  let tkp = (\(Entity _ tkp) -> tkp) entity
-      pos = Pos (trkptLat tkp) (trkptLon tkp) (trkptEle tkp)
-   in Point
-        pos
-        (trkptTime tkp)
-        (trkptCadence tkp)
-        (trkptPower tkp)
-        (trkptHeartRate tkp)
-
-data OverlapExists = OverlapExists String deriving (Show)
-
-instance Exception OverlapExists
-
-save :: (MonadIO m) => Track -> ReaderT SqlBackend m (Either OverlapExists Track)
-save track = do
-  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")
-    else do
-      mapM_ (insert . fromPoint) track
-      Session.refreshDrafts
-      return $ Right track
-
-fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point]
-fetch start duration = do
-  let finish = addUTCTime duration start
-  trkpts <- selectList [TrkptTime >. start, TrkptTime <. finish] []
-  return $ map toPoint trkpts

lib/Track.hs

@@ -8,8 +8,6 @@ module Track
     parseFile,
     parseBS,
     Track.length,
-    startTime,
-    duration,
   )
 where
 
@@ -97,18 +95,6 @@ parse str = do
 length :: Track -> Int
 length = Data.List.length
 
-startTime :: Track -> UTCTime
-startTime (p : ps) = List.foldr (\a b -> min b (time a)) (time p) ps
-
-duration :: Track -> NominalDiffTime
-duration track =
-  case track of
-    [] -> 0
-    (p : ps) ->
-      let start = startTime track
-          finish = List.foldr (\a b -> max b (time a)) (time p) ps
-       in diffUTCTime finish start
-
 -- parseFile :: FilePath -> IO [Point]
 parseFile name = do
   gpx <- Text.XML.readFile def name

souplesse.cabal

@@ -97,7 +97,6 @@ executable souplesse
 library souplesse-lib
     exposed-modules:
         Track
-        Store
         Point
         Session
     hs-source-dirs: