diff --git a/app/Main.hs b/app/Main.hs index 03a5c6f..e7b7dfa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,7 +12,7 @@ import Data.ByteString.Lazy as BS import Data.List as List import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool) import Debug.Trace (traceShow) -import Store (migrateAll, save) +import Store (fetch, migrateAll, save) import Track (parseBS) import Yesod.Core import Yesod.Form.Fields @@ -35,6 +35,7 @@ mkYesod /timeline TimelineR GET /upload UploadR POST /static StaticR Static getStatic +/points PointsR GET |] getStatic :: Souplesse -> Static @@ -87,6 +88,11 @@ var app = Elm.Main.init({

Copyright © 2024 Daniel Barlow |] +getPointsR :: Handler Value +getPointsR = do + points <- runDB Store.fetch + returnJson points + data FileForm = FileForm { fileInfo :: FileInfo } diff --git a/lib/Store.hs b/lib/Store.hs index 854d85a..503390f 100644 --- a/lib/Store.hs +++ b/lib/Store.hs @@ -13,12 +13,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Store (save, migrateAll) where +module Store (save, fetch, migrateAll) where -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Time.Clock (UTCTime) import Database.Persist +import Database.Persist.Class import Database.Persist.Postgresql ( ConnectionString, SqlBackend, @@ -29,6 +30,7 @@ import Database.Persist.Postgresql runSqlPool, ) import Database.Persist.TH +import Track (Point (..), Pos (..)) import Track as T connString :: ConnectionString @@ -52,4 +54,20 @@ 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) + Nothing + Nothing + Nothing + save p = do insert $ fromPoint p + +fetch :: (MonadIO m) => ReaderT SqlBackend m [Point] +fetch = do + trkpts <- selectList [TrkptLat <=. 360] [] -- Asc TrkptTime] + return $ map toPoint trkpts diff --git a/lib/Track.hs b/lib/Track.hs index 2a0a075..d5c0224 100644 --- a/lib/Track.hs +++ b/lib/Track.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Track ( Track, @@ -13,6 +14,8 @@ module Track 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 @@ -45,6 +48,19 @@ data Point = Point } 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 + ] + -- TODO do we even need this type? type Track = [Point] diff --git a/souplesse.cabal b/souplesse.cabal index 24a70be..cb202e0 100644 --- a/souplesse.cabal +++ b/souplesse.cabal @@ -70,6 +70,7 @@ executable souplesse -- Other library packages from which modules are imported. build-depends: base ^>=4.18.2.1 + , aeson , souplesse-lib , text , bytestring @@ -99,6 +100,8 @@ library souplesse-lib lib build-depends: base >=4.7 && <5 + , aeson + , bytestring , xml-conduit , time , containers