From b21eda22ada74849c6f39ddc4af410cfa8a15773 Mon Sep 17 00:00:00 2001
From: Daniel Barlow <dan@telent.net>
Date: Thu, 7 Nov 2024 18:59:56 +0000
Subject: [PATCH] chek for overlap when uploading file

---
 README.md       | 19 ++++++++++++++++++-
 app/Main.hs     | 16 ++++++++--------
 lib/Store.hs    | 17 ++++++++++++++++-
 lib/Track.hs    | 14 ++++++++++++++
 souplesse.cabal |  1 +
 5 files changed, 57 insertions(+), 10 deletions(-)

diff --git a/README.md b/README.md
index ae9a7a7..3e60100 100644
--- a/README.md
+++ b/README.md
@@ -67,12 +67,16 @@ _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
+* detect and refuse uploads which overlap an existing time frame
+ (http 409) so that we can script upload-all-the-tracks.
+
+
 
 
 ## Postgres
@@ -85,3 +89,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
diff --git a/app/Main.hs b/app/Main.hs
index ed539ec..0a15d32 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -10,14 +10,10 @@ 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 Debug.Trace (traceShow)
-import Store (fetch, migrateAll, save)
-import Text.Read (readMaybe)
+import Store
 import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
@@ -124,15 +120,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 $ 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 |]
diff --git a/lib/Store.hs b/lib/Store.hs
index 267c705..e1a80d1 100644
--- a/lib/Store.hs
+++ b/lib/Store.hs
@@ -15,8 +15,10 @@
 
 module Store (save, fetch, migrateAll) 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
@@ -66,7 +68,20 @@ toPoint entity =
         (trkptPower tkp)
         (trkptHeartRate tkp)
 
-save p = do mapM_ (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
+      return $ Right track
 
 fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point]
 fetch start duration = do
diff --git a/lib/Track.hs b/lib/Track.hs
index 7f12e1c..86415a9 100644
--- a/lib/Track.hs
+++ b/lib/Track.hs
@@ -10,6 +10,8 @@ module Track
     parseFile,
     parseBS,
     Track.length,
+    startTime,
+    duration,
   )
 where
 
@@ -129,6 +131,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
diff --git a/souplesse.cabal b/souplesse.cabal
index c0625d3..c309b54 100644
--- a/souplesse.cabal
+++ b/souplesse.cabal
@@ -79,6 +79,7 @@ executable souplesse
       , resourcet
       , monad-logger
       , time
+      , transformers
       , yesod-core == 1.6.25.1
       , yesod-static
       , yesod-form