twiddle readme

we're not using it for anything yet, just parsing it

README.md

@@ -47,6 +47,8 @@ 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
 
@@ -59,8 +61,7 @@ _Do not look below this line_
 
 ## WIP, Puzzles and TODO
 
-* do we even need Track? will it ever be anything more than a collection
+* rename Track to Gpx, it deals only with parsing.
- 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
@@ -70,12 +71,22 @@ _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]
-* frontend can get data from backend
+* [done] 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
@@ -93,10 +104,10 @@ _Do not look below this line_
   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 or the timeline
+rider create sessions from the calendar page. However, that's a GET
-page. However, that's a GET and might be slow if it has to figure out
+and might be slow if it has to figure out what all the sessions would
-what all the sessions would be every time someone looks at it. So
+be every time someone looks at it. So the draft session is just to
-the draft session is just to precompute that and make the view easier
+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,12 +11,15 @@ import Control.Monad.Trans.Resource (runResourceT)
 import Data.ByteString.Lazy as BS
 import Data.List as List
 import Data.Text as T
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+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 Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, getPgInterval, withPostgresqlPool)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
 import Debug.Trace (traceShow)
-import Session
+import Point qualified (fetch, migration, save)
-import Store
+import Session qualified
 import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
@@ -56,10 +59,13 @@ 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 =  T.pack . show . floor . utcTimeToPOSIXSeconds
+  let fTime = intToText . floor . utcTimeToPOSIXSeconds
-      fDur = T.pack . show  . ceiling . nominalDiffTimeToSeconds . getPgInterval
+      fDur = intToText . ceiling . nominalDiffTimeToSeconds
   (formWidget, _) <- generateFormPost uploadForm
   sessions' <- runDB Session.recents
   defaultLayout
@@ -70,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}
@@ -112,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
@@ -137,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!|]
@@ -164,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.migration
-    runMigration migrateTrkpt
+    runMigration Point.migration
   static' <- static "frontend"
   warp 3000 $ Souplesse pool static'

elm.json

@@ -13,6 +13,7 @@
             "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",
@@ -23,7 +24,6 @@
             "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,6 +1,7 @@
 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)
@@ -8,24 +9,38 @@ 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)
+import Svg exposing (Svg, svg, rect, circle, g, polyline)
 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.element { init = init
+  Browser.application
-                  , update = update
+      { init = init
-                  , subscriptions = subscriptions
+      , update = update
-                  , view = view }
+      , subscriptions = subscriptions
+      , onUrlRequest = (\ ur ->  NewUrlRequest)
+      , onUrlChange = (\ u -> UrlChanged)
+      , view = view }
 
 
 
@@ -42,7 +57,7 @@ type alias TileNumber = { x: Int, y: Int }
 type alias Lat = Float
 type alias Lng = Float
 
--- project latling to co-ordinates based on pseudocode at
+-- project lat/long to co-ordinates based on pseudocode at
 -- https://wiki.openstreetmap.org/wiki/Slippy_map_tilenames#Zoom_levels
 
 sec x = 1 / (cos x)
@@ -113,10 +128,19 @@ type alias Model =
     { centre: Coord
     , zoom: Zoom
     , drag: Drag
+    , startTime : Int
+    , duration : Int
     , track: TrackState }
 
-init : () -> (Model, Cmd Msg)
+init : () -> Url -> Nav.Key -> (Model, Cmd Msg)
-init _ = ((Model (toCoord 51.60 -0.01) 13 None Empty), fetchTrack)
+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))
 
 -- SUBSCRIPTIONS
 
@@ -124,8 +148,11 @@ subscriptions : Model -> Sub Msg
 subscriptions model = Sub.none
 
 
-fetchTrack = Http.get
+fetchTrack start duration = Http.get
-        { url = "http://localhost:3000/points?start=1729668899&duration=2842"
+        { url = ("http://localhost:3000/points?start=" ++
+                     String.fromInt start ++
+                     "&duration=" ++
+                     String.fromInt duration)
         , expect = Http.expectJson Loaded trackDecoder
         }
 
@@ -139,6 +166,9 @@ type alias Pos =
 type alias Point =
     { time : Float
     , pos : Pos
+    , cadence : Maybe Int
+    , power : Maybe Int
+    , heartRate : Maybe Int
     }
 
 posDecoder : D.Decoder Pos
@@ -149,9 +179,12 @@ posDecoder = D.map3 Pos
 
 
 pointDecoder : D.Decoder Point
-pointDecoder = D.map2 Point
+pointDecoder = D.map5 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
@@ -168,6 +201,8 @@ type Msg
   | PointerMove (Int, Int)
   | PointerUp (Int, Int)
   | Loaded (Result Http.Error (List Point))
+  | NewUrlRequest
+  | UrlChanged
 
 
 update : Msg -> Model -> (Model, Cmd Msg)
@@ -200,6 +235,8 @@ 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
 
@@ -215,14 +252,15 @@ tileImg zoom tilenumber = img [ width 256,
                                 height 256,
                                 src (tileUrl tilenumber zoom) ] []
 
-trackView : List Point -> Int -> Int -> Svg Msg
+trackView : List Point -> Int -> Int -> Zoom -> Svg Msg
-trackView points leftedge topedge =
+trackView points leftedge topedge zoom =
     let plot p =
-            let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) 13
+            let (x, y) = pixelFromCoord (toCoord p.pos.lat p.pos.lon) zoom
                 x_ = x - leftedge
                 y_ = y - topedge
-            in circle [ cx (px x_), cy (px y_), r "2" ] []
+            in (String.fromInt x_) ++ ", " ++
-        line = List.map plot points
+                (String.fromInt y_) ++ ", "
+        line = String.concat (List.map plot points)
     in
     svg
     [ H.style "width" "100%"
@@ -234,8 +272,13 @@ trackView points leftedge topedge =
       , stroke "blue"
       , strokeWidth "7"
       , strokeOpacity "0.5"]
-      line
+      [
-     ]
+       polyline
+       [ fill "none"
+       , S.points  line
+       ] []
+      ]
+    ]
 
 
 px x = String.fromInt x ++ "px"
@@ -262,7 +305,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
+                 Present t -> trackView t leftedge topedge zoom
                  Failure f -> Debug.log f (div [] [ text "failure", text f])
                  Loading -> div [] [text "loading"]
                  Empty -> div [] [text "no points"]
@@ -280,8 +323,8 @@ canvas centre zoom width height track =
 portalWidth = 600
 portalHeight = 600
 
-view : Model -> Html Msg
+viewDiv : Model -> Html Msg
-view model =
+viewDiv model =
     let coord = translate model.centre (pixelsToCoord model.zoom (dragDelta model.drag))
         canvasV = canvas coord model.zoom portalWidth portalHeight model.track
     in div []
@@ -304,3 +347,7 @@ view 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,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,16 +33,34 @@ 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 Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+
+-- import Track (Point (..), Pos (..))
+-- import Track as T
 
 data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
 
@@ -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

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

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
-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,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Track
   ( Track,
@@ -9,8 +8,6 @@ module Track
     parseFile,
     parseBS,
     Track.length,
-    startTime,
-    duration,
   )
 where
 
@@ -28,10 +25,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]
@@ -98,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: