README.md

@@ -47,8 +47,6 @@ ratio, or ... some other weirdness)
 
 Use `nix-shell`. Inside the shell
 
-* use `make` to build frontend (Elm) and backend (Haskell/Yesod)
-
 * run tests with `cabal test --test-show-details=always`: if you don't
 ask for details it won't tell you about incomplete pattern matches
 
@@ -61,7 +59,8 @@ _Do not look below this line_
 
 ## WIP, Puzzles and TODO
 
-* rename Track to Gpx, it deals only with parsing.
+* do we even need Track? will it ever be anything more than a collection
+ of Points?
 * can we lose this "if isJust lat && isJust lon && isJust ts" wart?
 * probably we should store points in a more efficient form than
  a singly-linked list
@@ -71,22 +70,12 @@ _Do not look below this line_
  - [done] serves the data points in some format elm can digest easily
 * [done] need a database of some kind so the data can be saved
 * and boring stuff like auth[zn]
-* [done] frontend can get data from backend
+* frontend can get data from backend
 * [done] for DX, backend can serve the js files needed by frontend
 * [ad hoc] we only have yesod-core, may need other parts as well
 * [done] detect and refuse uploads which overlap an existing time frame
  (http 409) so that we can script upload-all-the-tracks.
 * could we converge the Point and Trkpt to make sql better?
-* [done] move Store into Point
-
-on timeline, show power, cadence, speed, height, ascent (checkboxes)
-zoom gesture on graphs causes map to adjust
-zooming map causes graphs to adjust
-
-threshold display: adjust vertical slider to show time spent at
-or above a particular intensity. Indicate somehow the length of
-each continuous stretch at that intensity
-
 
 * calendar displays sessions. a session is a sequence of measurements
   describing a ride or a race or a trip. we can extract potential
@@ -104,10 +93,10 @@ each continuous stretch at that intensity
   using information thy have but the computer doesn't
 
 in theory we don't even need draft sessions and we could have the
-rider create sessions from the calendar page. However, that's a GET
-and might be slow if it has to figure out what all the sessions would
-be every time someone looks at it. So the draft session is just to
-precompute that and make the view easier
+rider create sessions from the calendar page or the timeline
+page. However, that's a GET and might be slow if it has to figure out
+what all the sessions would be every time someone looks at it. So
+the draft session is just to precompute that and make the view easier
 
 the summary of a session is for display on the calendar and might
 change depending on the nature of the training effort. e.g.

app/Main.hs

@@ -11,15 +11,12 @@ import Control.Monad.Trans.Resource (runResourceT)
 import Data.ByteString.Lazy as BS
 import Data.List as List
 import Data.Text as T
-import Data.Text.Lazy qualified as T (toStrict)
-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, runMigration, runSqlPool, withPostgresqlPool)
+import Data.Time.Clock (nominalDiffTimeToSeconds)
+import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, getPgInterval, withPostgresqlPool)
 import Debug.Trace (traceShow)
-import Point qualified (fetch, migration, save)
-import Session qualified
+import Session
+import Store
 import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
@@ -59,13 +56,10 @@ instance YesodPersist Souplesse where
     Souplesse pool _ <- getYesod
     runSqlPool action pool
 
-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
+  let fTime =  T.pack . show . floor . utcTimeToPOSIXSeconds
+      fDur = T.pack . show  . ceiling . nominalDiffTimeToSeconds . getPgInterval
   (formWidget, _) <- generateFormPost uploadForm
   sessions' <- runDB Session.recents
   defaultLayout
@@ -76,7 +70,7 @@ getCalendarR = do
 <ul>
     $forall s <- sessions'
         <li>
-             <a href=@?{(TimelineR, [("start", fTime $ Session.startTime s), ("duration", fDur $ Session.duration s)])} > #{show $ Session.startTime s} #{show (Session.duration s)}
+             <a href=@?{(TimelineR, [("start", fTime $ sessionStartTime s), ("duration", fDur $ sessionDuration s)])} > #{show $ sessionStartTime s} #{show $ getPgInterval (sessionDuration s)}
 
 <form action="/upload" method=post enctype="multipart/form-data">
     ^{formWidget}
@@ -118,7 +112,7 @@ getPointsR = do
         <*> ireq intField "duration"
   let start' = posixSecondsToUTCTime $ fromInteger $ toInteger $ start tr
       duration' = fromInteger $ toInteger $ duration tr
-  points <- runDB $ Point.fetch start' duration'
+  points <- runDB $ Store.fetch start' duration'
   returnJson (traceShow tr points)
 
 data FileForm = FileForm
@@ -143,7 +137,7 @@ postUploadR = do
       bs <- fileSourceByteString $ fileInfo upload
       case Track.parseBS (fromStrict bs) of
         Right points -> do
-          eitherPoints <- runDB $ Point.save points
+          eitherPoints <- runDB $ Store.save points
           case eitherPoints of
             Right points' ->
               defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
@@ -170,7 +164,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.migration
-    runMigration Point.migration
+    runMigration migrateSession
+    runMigration migrateTrkpt
   static' <- static "frontend"
   warp 3000 $ Souplesse pool static'

elm.json

@@ -13,7 +13,6 @@
             "elm/json": "1.1.3",
             "elm/svg": "1.0.1",
             "elm/time": "1.0.0",
-            "elm/url": "1.0.0",
             "elm-explorations/test": "2.2.0",
             "mpizenberg/elm-pointer-events": "5.0.0",
             "rtfeldman/elm-iso8601-date-strings": "1.1.4",
@@ -24,6 +23,7 @@
             "elm/file": "1.0.5",
             "elm/parser": "1.1.0",
             "elm/random": "1.0.0",
+            "elm/url": "1.0.0",
             "elm/virtual-dom": "1.0.3",
             "miniBill/elm-xml-parser": "1.0.1",
             "rtfeldman/elm-hex": "1.0.0"

frontend/src/Main.elm

@@ -1,7 +1,6 @@
 module Main exposing (view)
 
 import Browser
-import Browser.Navigation as Nav
 import Html exposing (Html, button, div, span, text, img, pre)
 import Html.Attributes as H exposing (src, style, width, height)
 import Html.Events exposing (onClick)
@@ -9,38 +8,24 @@ import Html.Events.Extra.Pointer as Pointer
 import Maybe exposing (Maybe)
 import Json.Decode as D
 import Http
-import Svg exposing (Svg, svg, rect, circle, g, polyline)
+import Svg exposing (Svg, svg, rect, circle, g)
 import Svg.Attributes as S exposing
     ( viewBox
     , x, y
     , r, rx, ry
     , cx, cy
     , fill
-    , points
     , stroke, strokeWidth, strokeOpacity)
-import Url.Parser exposing (Parser, (</>), (<?>), int, map, oneOf, s, string)
-import Url.Parser.Query as Query
-import Url exposing (Url)
-
-
-type Route = Timeline (Maybe Int) (Maybe Int)
-
-routeParser : Parser (Route -> a) a
-routeParser =
-  map Timeline (s "timeline" <?> Query.int "start" <?> Query.int "duration")
 
 
 -- MAIN
 
 
 main =
-  Browser.application
-      { init = init
-      , update = update
-      , subscriptions = subscriptions
-      , onUrlRequest = (\ ur ->  NewUrlRequest)
-      , onUrlChange = (\ u -> UrlChanged)
-      , view = view }
+  Browser.element { init = init
+                  , update = update
+                  , subscriptions = subscriptions
+                  , view = view }
 
 
 
@@ -57,7 +42,7 @@ type alias TileNumber = { x: Int, y: Int }
 type alias Lat = Float
 type alias Lng = Float
 
--- project lat/long to co-ordinates based on pseudocode at
+-- project latling to co-ordinates based on pseudocode at
 -- https://wiki.openstreetmap.org/wiki/Slippy_map_tilenames#Zoom_levels
 
 sec x = 1 / (cos x)
@@ -128,19 +113,10 @@ type alias Model =
     { centre: Coord
     , zoom: Zoom
     , drag: Drag
-    , startTime : Int
-    , duration : Int
     , track: TrackState }
 
-init : () -> Url -> Nav.Key -> (Model, Cmd Msg)
-init _ url navKey =
-    let (start, duration) =
-            case Url.Parser.parse routeParser url of
-                Just (Timeline (Just s) (Just d)) -> (s, d)
-                _ -> (10,10)
-    in
-        ((Model (toCoord 51.60 -0.01) 13 None start duration Empty),
-             (fetchTrack start duration))
+init : () -> (Model, Cmd Msg)
+init _ = ((Model (toCoord 51.60 -0.01) 13 None Empty), fetchTrack)
 
 -- SUBSCRIPTIONS
 
@@ -148,11 +124,8 @@ subscriptions : Model -> Sub Msg
 subscriptions model = Sub.none
 
 
-fetchTrack start duration = Http.get
-        { url = ("http://localhost:3000/points?start=" ++
-                     String.fromInt start ++
-                     "&duration=" ++
-                     String.fromInt duration)
+fetchTrack = Http.get
+        { url = "http://localhost:3000/points?start=1729668899&duration=2842"
         , expect = Http.expectJson Loaded trackDecoder
         }
 
@@ -166,9 +139,6 @@ type alias Pos =
 type alias Point =
     { time : Float
     , pos : Pos
-    , cadence : Maybe Int
-    , power : Maybe Int
-    , heartRate : Maybe Int
     }
 
 posDecoder : D.Decoder Pos
@@ -179,12 +149,9 @@ posDecoder = D.map3 Pos
 
 
 pointDecoder : D.Decoder Point
-pointDecoder = D.map5 Point
+pointDecoder = D.map2 Point
                (D.field "time" D.float)
                (D.field "pos" posDecoder)
-               (D.field "cadence" (D.maybe D.int))
-               (D.field "power" (D.maybe D.int))
-               (D.field "heartRate" (D.maybe D.int))
 
 trackDecoder : D.Decoder (List Point)
 trackDecoder = D.list pointDecoder
@@ -201,8 +168,6 @@ type Msg
   | PointerMove (Int, Int)
   | PointerUp (Int, Int)
   | Loaded (Result Http.Error (List Point))
-  | NewUrlRequest
-  | UrlChanged
 
 
 update : Msg -> Model -> (Model, Cmd Msg)
@@ -235,8 +200,6 @@ newModel msg model =
                 Ok trk -> { model | track = Present trk }
                 Err (Http.BadBody e) -> { model | track = Debug.log e (Failure "e") }
                 Err e -> { model | track = Debug.log "unknown error" (Failure "e") }
-        NewUrlRequest -> model
-        UrlChanged ->  model
 
 -- VIEW
 
@@ -252,15 +215,14 @@ tileImg zoom tilenumber = img [ width 256,
                                 height 256,
                                 src (tileUrl tilenumber zoom) ] []
 
-trackView : List Point -> Int -> Int -> Zoom -> Svg Msg
-trackView points leftedge topedge zoom =
+trackView : List Point -> Int -> Int -> Svg Msg
+trackView points leftedge topedge =
     let plot p =
-            let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) zoom
+            let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) 13
                 x_ = x - leftedge
                 y_ = y - topedge
-            in (String.fromInt x_) ++ ", " ++
-                (String.fromInt y_) ++ ", "
-        line = String.concat (List.map plot points)
+            in circle [ cx (px x_), cy (px y_), r "2" ] []
+        line = List.map plot points
     in
     svg
     [ H.style "width" "100%"
@@ -272,13 +234,8 @@ trackView points leftedge topedge zoom =
       , stroke "blue"
       , strokeWidth "7"
       , strokeOpacity "0.5"]
-      [
-       polyline
-       [ fill "none"
-       , S.points  line
-       ] []
-      ]
-    ]
+      line
+     ]
 
 
 px x = String.fromInt x ++ "px"
@@ -305,7 +262,7 @@ canvas centre zoom width height track =
         ys = List.range mintile.y maxtile.y
         epos e = Tuple.mapBoth floor floor e.pointer.clientPos
         tv = case track of
-                 Present t -> trackView t leftedge topedge zoom
+                 Present t -> trackView t leftedge topedge
                  Failure f -> Debug.log f (div [] [ text "failure", text f])
                  Loading -> div [] [text "loading"]
                  Empty -> div [] [text "no points"]
@@ -323,8 +280,8 @@ canvas centre zoom width height track =
 portalWidth = 600
 portalHeight = 600
 
-viewDiv : Model -> Html Msg
-viewDiv model =
+view : Model -> Html Msg
+view model =
     let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta model.drag))
         canvasV = canvas coord model.zoom portalWidth portalHeight model.track
     in div []
@@ -347,7 +304,3 @@ viewDiv model =
         , button [ onClick (Scroll 10 0) ] [ text ">" ]
 --        , div [] [ text (Debug.toString (List.length model.track)) ]
         ]
-
-view : Model -> Browser.Document Msg
-view model =
-    Browser.Document  "Souplesse elm" [  (viewDiv model) ]

lib/Point.hs

@@ -1,31 +1,13 @@
-{-# 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
@@ -33,34 +15,16 @@ import Data.Functor ((<&>))
 import Data.List as List
 import Data.List qualified
 import Data.Map as Map
-import Data.Maybe (isJust)
+import Data.Maybe
 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
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 
 data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
 
@@ -94,71 +58,3 @@ 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

@@ -14,58 +14,41 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Session
-  ( Session (..),
-    recents,
-    refreshDrafts,
-    migration,
-  )
-where
+  ( 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)
-import Data.Text
-import Data.Time.Clock
-  ( NominalDiffTime,
-    UTCTime,
-  )
-import Database.Persist
-import Database.Persist.Postgresql
-  ( PgInterval,
-    SqlBackend,
-    getPgInterval,
-    rawExecute,
-  )
-import Database.Persist.TH
-import Text.RawString.QQ (r)
+
 
 share
-  [mkPersist sqlSettings, mkMigrate "migration"]
+  [mkPersist sqlSettings, mkMigrate "migrateSession"]
   [persistLowerCase|
-SessionRow sql=session
+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|
+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
@@ -80,11 +63,7 @@ insert into session(start_time, duration, draft) (select time as start_time, mak
 where draft;
 |]
 
-refreshDrafts :: (MonadIO m) => ReaderT SqlBackend m ()
-refreshDrafts =
-  rawExecute updateSql []
-
-recents :: (MonadIO m) => ReaderT SqlBackend m [Session]
+recents :: (MonadIO m) =>  ReaderT SqlBackend m [Session]
 recents = do
-  s <- selectList [SessionRowDraft !=. True] [Desc SessionRowStartTime, LimitTo 10]
-  return $ Prelude.map fromEntity s
+  s <- selectList [SessionDraft !=. True] [Desc SessionStartTime, LimitTo 10]
+  return $ Prelude.map (\(Entity _ x) -> x) s

lib/Store.hs

@@ -0,0 +1,99 @@
+{-# 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
+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 = startTime track
+      finish = addUTCTime (duration track) (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
+      rawExecute Session.updateSessions []
+      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

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Track
   ( Track,
@@ -8,6 +9,8 @@ module Track
     parseFile,
     parseBS,
     Track.length,
+    startTime,
+    duration,
   )
 where
 
@@ -25,10 +28,10 @@ import Data.Text.Lazy as T
 import Data.Time
 import Data.Time.ISO8601 qualified
 import Debug.Trace (trace, traceShow)
-import Point
 import Text.Read (readMaybe)
 import Text.XML
 import Text.XML.Cursor as Cursor
+import Point
 
 -- TODO do we even need this type?
 type Track = [Point]
@@ -95,6 +98,18 @@ 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,6 +97,7 @@ executable souplesse
 library souplesse-lib
     exposed-modules:
         Track
+        Store
         Point
         Session
     hs-source-dirs: