souplesse

commit 8bd67b2096b4abf52b94a35f4ff87450344eaa72
parent 7d2b669f3fe845c1847729a0cf519dbd5bffc686
Author: Daniel Barlow <dan@telent.net>
Date:   Tue,  5 Nov 2024 23:32:01 +0000

serve JSON fron db at /points

Diffstat:
M
app/Main.hs
 | 
8
+++++++-
M
lib/Store.hs
 | 
22
++++++++++++++++++++--
M
lib/Track.hs
 | 
16
++++++++++++++++
M
souplesse.cabal
 | 
3
+++

4 files changed, 46 insertions(+), 3 deletions(-)
diff --git 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({
 <p>Copyright &copy; 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
@@ -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
@@ -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
@@ -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