README.md

@@ -67,41 +67,12 @@ _Do not look below this line_
 
 * need a web server in haskell that
  - [done] accepts file upload and parses the gpx file
- - [done] serves the data points in some format elm can digest easily
+ - 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
@@ -114,16 +85,3 @@ 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,13 +10,14 @@ 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 as T
+import Data.Text (Text, unpack)
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+-- https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Static-file-subsite-Hello-World.md
-import Data.Time.Clock (nominalDiffTimeToSeconds)
+
-import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, getPgInterval, withPostgresqlPool)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
 import Debug.Trace (traceShow)
-import Session
+import Store (fetch, migrateAll, save)
-import Store
+import Text.Read (readMaybe)
 import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
@@ -58,19 +59,12 @@ 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}
@@ -130,19 +124,15 @@ instance RenderMessage Souplesse FormMessage where
 
 postUploadR :: Handler Html
 postUploadR = do
-  ((result, _), _) <- runFormPostNoToken uploadForm
+  ((result, _), _) <- runFormPost uploadForm
 
   case result of
     FormSuccess upload -> do
       bs <- fileSourceByteString $ fileInfo upload
       case Track.parseBS (fromStrict bs) of
         Right points -> do
-          eitherPoints <- runDB $ Store.save points
+          runDB $ mapM_ Store.save points
-          case eitherPoints of
+          defaultLayout [whamlet|<p>#{List.length points} points - thanks!|]
-            Right points' ->
-              defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
-            Left _ ->
-              defaultLayout [whamlet|<p>overlap error |]
         Left _ ->
           defaultLayout
             [whamlet|<p>parse error |]
@@ -164,7 +154,6 @@ 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 migrateAll
-    runMigration migrateTrkpt
   static' <- static "frontend"
   warp 3000 $ Souplesse pool static'

elm.json

@@ -10,7 +10,6 @@
             "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",
@@ -21,6 +20,7 @@
         "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,7 +6,6 @@ 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
@@ -17,6 +16,9 @@ import Svg.Attributes as S exposing
     , fill
     , stroke, strokeWidth, strokeOpacity)
 
+import Track exposing (Track)
+-- import ExampleTrack
+
 
 -- MAIN
 
@@ -108,7 +110,7 @@ dragDelta d =
         None -> (0,0)
         Dragging (fx,fy) (tx,ty) -> (fx-tx, fy-ty)
 
-type TrackState = Empty | Loading | Failure String | Present (List Point)
+type TrackState = Empty | Loading | Failure String | Present Track
 type alias Model =
     { centre: Coord
     , zoom: Zoom
@@ -116,7 +118,7 @@ type alias Model =
     , track: TrackState }
 
 init : () -> (Model, Cmd Msg)
-init _ = ((Model (toCoord 51.60 -0.01) 13 None Empty), fetchTrack)
+init _ = ((Model (toCoord 51.60 -0.01) 16 None Empty), fetchTrack)
 
 -- SUBSCRIPTIONS
 
@@ -125,38 +127,10 @@ subscriptions model = Sub.none
 
 
 fetchTrack = Http.get
-        { url = "http://localhost:3000/points?start=1729668899&duration=2842"
+        { url = "/track.gpx.xml"
-        , expect = Http.expectJson Loaded trackDecoder
+        , expect = Http.expectString Loaded
         }
 
-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
 
@@ -167,7 +141,7 @@ type Msg
   | PointerDown (Int, Int)
   | PointerMove (Int, Int)
   | PointerUp (Int, Int)
-  | Loaded (Result Http.Error (List Point))
+  | Loaded (Result Http.Error String)
 
 
 update : Msg -> Model -> (Model, Cmd Msg)
@@ -197,9 +171,12 @@ newModel msg model =
 
         Loaded result ->
             case result of
-                Ok trk -> { model | track = Debug.log "LOADED" (Present trk) }
+                Ok trk -> { model
-                Err (Http.BadBody e) -> { model | track = Debug.log e (Failure "e") }
+                              | track = case Track.parse trk of
-                Err e -> { model | track = Debug.log "unknown error" (Failure "e") }
+                                            Ok track -> Present track
+                                            Err _ -> Failure "parse failed"
+                          }
+                Err e -> { model | track = Failure "e" }
 
 -- VIEW
 
@@ -215,7 +192,7 @@ tileImg zoom tilenumber = img [ width 256,
                                 height 256,
                                 src (tileUrl tilenumber zoom) ] []
 
-trackView : List Point -> Svg Msg
+trackView : Track -> Svg Msg
 
 
 trackView track =
@@ -271,7 +248,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 -> Debug.log f (div [] [ text "failure", text f])
+                 Failure f -> div [] [ text "failure", text f]
                  Loading -> div [] [text "loading"]
                  Empty -> div [] [text "no points"]
     in  div [style "position" "absolute"
@@ -301,7 +278,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

@@ -1,60 +0,0 @@
-{-# 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

@@ -1,69 +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 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,18 +13,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Store
+module Store (save, fetch, migrateAll) where
-  ( 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
@@ -34,12 +26,10 @@ 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
@@ -48,7 +38,7 @@ connString :: ConnectionString
 connString = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
 
 share
-  [mkPersist sqlSettings, mkMigrate "migrateTrkpt"]
+  [mkPersist sqlSettings, mkMigrate "migrateAll"]
   [persistLowerCase|
 Trkpt
     lat Double
@@ -76,21 +66,7 @@ toPoint entity =
         (trkptPower tkp)
         (trkptHeartRate tkp)
 
-data OverlapExists = OverlapExists String deriving (Show)
+save p = do insert $ fromPoint p
-
-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,14 +3,13 @@
 
 module Track
   ( Track,
-    module Point,
+    Pos (..),
     BadFile,
+    Point (..),
     parse,
     parseFile,
     parseBS,
     Track.length,
-    startTime,
-    duration,
   )
 where
 
@@ -31,7 +30,39 @@ import Debug.Trace (trace, traceShow)
 import Text.Read (readMaybe)
 import Text.XML
 import Text.XML.Cursor as Cursor
-import Point
+
+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
+      ]
 
 -- TODO do we even need this type?
 type Track = [Point]
@@ -98,18 +129,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

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