fetch and parse json from frontend

a session is a series of points which we assume (or the
rider confirms) comprise a complete and continuous ride

README.md

@@ -67,12 +67,41 @@ _Do not look below this line_
 
 * need a web server in haskell that
  - [done] accepts file upload and parses the gpx file
- - serves the data points in some format elm can digest easily
+ - [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] 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?
+
+* calendar displays sessions. a session is a sequence of measurements
+  describing a ride or a race or a trip. we can extract potential
+  sessions from the data by looking for series of points not more than
+  x (10?)  minutes apart, but the rider may override that. Consider: I
+  ride solo to the start point of a group ride, join a tandem partner
+  to do the group ride, then ride solo home. There is not necessarily
+  ten minutes between them.
+
+  after a new track is uploaded, we look at all the points covered by
+  draft sessions, and rearrange them to cover the new points.  Draft
+  sessions are then presented to the rider who may approve them
+  as-is - perhaps involving other data collection as well ("perceived
+  effort" or "which bike setup was this" or ...) - or chop them up
+  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
+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.
+for a long slow ride we show total distance, for interval training
+we show time spent in HR zones ...
 
 
 ## Postgres
@@ -85,3 +114,16 @@ start and stop it when I want to
 docker run -p 5432:5432 --name souplesse-postgres -e POSTGRES_USER=souplesse  -e POSTGRES_PASSWORD=secret -d postgres
 nix-shell -p postgresql --run "psql -h localhost -U souplesse   -p 5432"
 ```
+
+## Sample data
+
+The upload form deliberately doesn't have CSRF (for now, at least) so
+that you can chuck a bunch of GPX files at it using curl
+
+```
+ for i in tmp/Tracks/*.gpx ; do curl --form  f1=@$i 'http://localhost:3000/upload'; done
+```
+
+This should be safe to do repeatedly because it will refuse upload of
+tracks where the database already contains any points in the time
+range of the uploaded track

app/Main.hs

@@ -10,14 +10,13 @@ import Control.Monad.Logger (runStderrLoggingT)
 import Control.Monad.Trans.Resource (runResourceT)
 import Data.ByteString.Lazy as BS
 import Data.List as List
-import Data.Text (Text, unpack)
--- https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Static-file-subsite-Hello-World.md
-
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
+import Data.Text as T
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Data.Time.Clock (nominalDiffTimeToSeconds)
+import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, getPgInterval, withPostgresqlPool)
 import Debug.Trace (traceShow)
-import Store (fetch, migrateAll, save)
-import Text.Read (readMaybe)
+import Session
+import Store
 import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
@@ -59,12 +58,19 @@ instance YesodPersist Souplesse where
 
 getCalendarR :: Handler Html
 getCalendarR = do
+  let fTime =  T.pack . show . floor . utcTimeToPOSIXSeconds
+      fDur = T.pack . show  . ceiling . nominalDiffTimeToSeconds . getPgInterval
   (formWidget, _) <- generateFormPost uploadForm
+  sessions' <- runDB Session.recents
   defaultLayout
     [whamlet|
 <h1>Calendar
 
 <p>A calendar view goes here
+<ul>
+    $forall s <- sessions'
+        <li>
+             <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}
@@ -124,15 +130,19 @@ instance RenderMessage Souplesse FormMessage where
 
 postUploadR :: Handler Html
 postUploadR = do
-  ((result, _), _) <- runFormPost uploadForm
+  ((result, _), _) <- runFormPostNoToken uploadForm
 
   case result of
     FormSuccess upload -> do
       bs <- fileSourceByteString $ fileInfo upload
       case Track.parseBS (fromStrict bs) of
         Right points -> do
-          runDB $ mapM_ Store.save points
-          defaultLayout [whamlet|<p>#{List.length points} points - thanks!|]
+          eitherPoints <- runDB $ Store.save points
+          case eitherPoints of
+            Right points' ->
+              defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
+            Left _ ->
+              defaultLayout [whamlet|<p>overlap error |]
         Left _ ->
           defaultLayout
             [whamlet|<p>parse error |]
@@ -154,6 +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 migrateAll
+    runMigration migrateSession
+    runMigration migrateTrkpt
   static' <- static "frontend"
   warp 3000 $ Souplesse pool static'

elm.json

@@ -10,6 +10,7 @@
             "elm/core": "1.0.5",
             "elm/html": "1.0.0",
             "elm/http": "2.0.0",
+            "elm/json": "1.1.3",
             "elm/svg": "1.0.1",
             "elm/time": "1.0.0",
             "elm-explorations/test": "2.2.0",
@@ -20,7 +21,6 @@
         "indirect": {
             "elm/bytes": "1.0.8",
             "elm/file": "1.0.5",
-            "elm/json": "1.1.3",
             "elm/parser": "1.1.0",
             "elm/random": "1.0.0",
             "elm/url": "1.0.0",

frontend/src/Main.elm

@@ -6,6 +6,7 @@ import Html.Attributes as H exposing (src, style, width, height)
 import Html.Events exposing (onClick)
 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.Attributes as S exposing
@@ -16,9 +17,6 @@ import Svg.Attributes as S exposing
     , fill
     , stroke, strokeWidth, strokeOpacity)
 
-import Track exposing (Track)
--- import ExampleTrack
-
 
 -- MAIN
 
@@ -110,7 +108,7 @@ dragDelta d =
         None -> (0,0)
         Dragging (fx,fy) (tx,ty) -> (fx-tx, fy-ty)
 
-type TrackState = Empty | Loading | Failure String | Present Track
+type TrackState = Empty | Loading | Failure String | Present (List Point)
 type alias Model =
     { centre: Coord
     , zoom: Zoom
@@ -118,7 +116,7 @@ type alias Model =
     , track: TrackState }
 
 init : () -> (Model, Cmd Msg)
-init _ = ((Model (toCoord 51.60 -0.01) 16 None Empty), fetchTrack)
+init _ = ((Model (toCoord 51.60 -0.01) 13 None Empty), fetchTrack)
 
 -- SUBSCRIPTIONS
 
@@ -127,10 +125,38 @@ subscriptions model = Sub.none
 
 
 fetchTrack = Http.get
-        { url = "/track.gpx.xml"
-        , expect = Http.expectString Loaded
+        { url = "http://localhost:3000/points?start=1729668899&duration=2842"
+        , expect = Http.expectJson Loaded trackDecoder
         }
 
+type alias Pos =
+    { lat : Float
+    , lon : Float
+    , ele : Maybe Float
+    }
+
+
+type alias Point =
+    { time : Float
+    , pos : Pos
+    }
+
+posDecoder : D.Decoder Pos
+posDecoder = D.map3 Pos
+             (D.field "lat" D.float)
+             (D.field "lon" D.float)
+             (D.field "ele" (D.maybe D.float))
+
+
+pointDecoder : D.Decoder Point
+pointDecoder = D.map2 Point
+               (D.field "time" D.float)
+               (D.field "pos" posDecoder)
+
+trackDecoder : D.Decoder (List Point)
+trackDecoder = D.list pointDecoder
+
+
 
 -- UPDATE
 
@@ -141,7 +167,7 @@ type Msg
   | PointerDown (Int, Int)
   | PointerMove (Int, Int)
   | PointerUp (Int, Int)
-  | Loaded (Result Http.Error String)
+  | Loaded (Result Http.Error (List Point))
 
 
 update : Msg -> Model -> (Model, Cmd Msg)
@@ -171,12 +197,9 @@ newModel msg model =
 
         Loaded result ->
             case result of
-                Ok trk -> { model
-                              | track = case Track.parse trk of
-                                            Ok track -> Present track
-                                            Err _ -> Failure "parse failed"
-                          }
-                Err e -> { model | track = Failure "e" }
+                Ok trk -> { model | track = Debug.log "LOADED" (Present trk) }
+                Err (Http.BadBody e) -> { model | track = Debug.log e (Failure "e") }
+                Err e -> { model | track = Debug.log "unknown error" (Failure "e") }
 
 -- VIEW
 
@@ -192,7 +215,7 @@ tileImg zoom tilenumber = img [ width 256,
                                 height 256,
                                 src (tileUrl tilenumber zoom) ] []
 
-trackView : Track -> Svg Msg
+trackView : List Point -> Svg Msg
 
 
 trackView track =
@@ -248,7 +271,7 @@ canvas centre zoom width height track =
         epos e = Tuple.mapBoth floor floor e.pointer.clientPos
         tv = case track of
                  Present t -> trackView t
-                 Failure f -> div [] [ text "failure", text f]
+                 Failure f -> Debug.log f (div [] [ text "failure", text f])
                  Loading -> div [] [text "loading"]
                  Empty -> div [] [text "no points"]
     in  div [style "position" "absolute"
@@ -278,7 +301,7 @@ view model =
                [canvasV])
         , div [] [ text (String.fromInt model.zoom ) ]
         , div [] [ case model.track of
-                       Present tk -> text (String.fromInt (List.length tk))
+                       -- Present tk -> text (String.fromInt (List.length tk))
                        _ -> text "dgdfg"
                  ]
         , button [ onClick ZoomOut ] [ text "-" ]

lib/Point.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Point
+  ( Pos (..),
+    Point (..),
+  )
+where
+
+import Control.Exception
+import Data.Aeson
+import Data.ByteString.Lazy.Char8 qualified as L
+import Data.Either
+import Data.Functor ((<&>))
+import Data.List as List
+import Data.List qualified
+import Data.Map as Map
+import Data.Maybe
+import Data.Text qualified
+import Data.Text.Lazy as T
+import Data.Time
+import Data.Time.ISO8601 qualified
+import Debug.Trace (trace, traceShow)
+import Text.Read (readMaybe)
+import Text.XML
+import Text.XML.Cursor as Cursor
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+
+data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
+
+type Power = Maybe Int
+
+type Cadence = Maybe Int
+
+type HeartRate = Maybe Int
+
+data Point = Point
+  { pos :: Pos,
+    time :: UTCTime,
+    cadence :: Cadence,
+    power :: Power,
+    heartRate :: HeartRate
+  }
+  deriving (Show)
+
+instance ToJSON Pos where
+  toJSON (Pos lat lon ele) =
+    case ele of
+      Just e -> object ["lat" .= lat, "lon" .= lon, "ele" .= e]
+      Nothing -> object ["lat" .= lat, "lon" .= lon, "ele" .= Null]
+
+instance ToJSON Point where
+  toJSON Point {..} =
+    object
+      [ "pos" .= pos,
+        "time" .= utcTimeToPOSIXSeconds time,
+        "cadence" .= cadence,
+        "power" .= power,
+        "heartRate" .= heartRate
+      ]

lib/Session.hs

@@ -0,0 +1,69 @@
+{-# 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 Session
+  ( 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)
+
+
+share
+  [mkPersist sqlSettings, mkMigrate "migrateSession"]
+  [persistLowerCase|
+Session
+    startTime UTCTime
+    duration PgInterval
+    draft Bool default=True
+    notes String Maybe
+|]
+
+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
+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));
+-- reset durations
+ update session s1
+ set duration =
+    coalesce(
+    (select max(time) from trkpt t1
+     where t1.time < coalesce((select min(start_time) from session s2 where s2.start_time > s1.start_time), now())) - s1.start_time
+     , make_interval())
+where draft;
+|]
+
+recents :: (MonadIO m) =>  ReaderT SqlBackend m [Session]
+recents = do
+  s <- selectList [SessionDraft !=. True] [Desc SessionStartTime, LimitTo 10]
+  return $ Prelude.map (\(Entity _ x) -> x) s

lib/Store.hs

@@ -13,10 +13,18 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Store (save, fetch, migrateAll) where
+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
@@ -26,10 +34,12 @@ import Database.Persist.Postgresql
     createPostgresqlPool,
     pgConnStr,
     pgPoolSize,
+    rawExecute,
     runMigration,
     runSqlPool,
   )
 import Database.Persist.TH
+import Session
 import Text.Read (readMaybe)
 import Track (Point (..), Pos (..))
 import Track as T
@@ -38,7 +48,7 @@ connString :: ConnectionString
 connString = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
 
 share
-  [mkPersist sqlSettings, mkMigrate "migrateAll"]
+  [mkPersist sqlSettings, mkMigrate "migrateTrkpt"]
   [persistLowerCase|
 Trkpt
     lat Double
@@ -66,7 +76,21 @@ toPoint entity =
         (trkptPower tkp)
         (trkptHeartRate tkp)
 
-save p = do insert $ fromPoint p
+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

lib/Track.hs

@@ -3,13 +3,14 @@
 
 module Track
   ( Track,
-    Pos (..),
+    module Point,
     BadFile,
-    Point (..),
     parse,
     parseFile,
     parseBS,
     Track.length,
+    startTime,
+    duration,
   )
 where
 
@@ -30,39 +31,7 @@ import Debug.Trace (trace, traceShow)
 import Text.Read (readMaybe)
 import Text.XML
 import Text.XML.Cursor as Cursor
-
-data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
-
-type Power = Maybe Int
-
-type Cadence = Maybe Int
-
-type HeartRate = Maybe Int
-
-data Point = Point
-  { pos :: Pos,
-    time :: UTCTime,
-    cadence :: Cadence,
-    power :: Power,
-    heartRate :: HeartRate
-  }
-  deriving (Show)
-
-instance ToJSON Pos where
-  toJSON (Pos lat lon ele) =
-    case ele of
-      Just e -> object ["lat" .= lat, "lon" .= lon, "ele" .= e]
-      Nothing -> object ["lat" .= lat, "lon" .= lon, "ele" .= Null]
-
-instance ToJSON Point where
-  toJSON Point {..} =
-    object
-      [ "pos" .= pos,
-        "time" .= time,
-        "cadence" .= cadence,
-        "power" .= power,
-        "heartRate" .= heartRate
-      ]
+import Point
 
 -- TODO do we even need this type?
 type Track = [Point]
@@ -129,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

@@ -79,6 +79,7 @@ executable souplesse
       , resourcet
       , monad-logger
       , time
+      , transformers
       , yesod-core == 1.6.25.1
       , yesod-static
       , yesod-form
@@ -97,6 +98,8 @@ library souplesse-lib
     exposed-modules:
         Track
         Store
+        Point
+        Session
     hs-source-dirs:
         lib
     build-depends:
@@ -107,6 +110,7 @@ library souplesse-lib
       , time
       , containers
       , text
+      , raw-strings-qq
       , transformers
       , persistent
       , persistent-postgresql