commit b21eda22ada74849c6f39ddc4af410cfa8a15773
parent 4ca505ada115fd70b41b2fe2b250a2260d9edd60
Author: Daniel Barlow <dan@telent.net>
Date: Thu, 7 Nov 2024 18:59:56 +0000
chek for overlap when uploading file
Diffstat:
5 files changed, 57 insertions(+), 10 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -79,6 +79,7 @@ executable souplesse
, resourcet
, monad-logger
, time
+ , transformers
, yesod-core == 1.6.25.1
, yesod-static
, yesod-form
