add postgres

anticipating  that the storage will prefer doubles

README.md

@@ -73,3 +73,7 @@ _Do not look below this line_
 * frontend can get data from backend
 * for DX, backend can serve the js files needed by frontend
 * we only have yesod-core, may need other parts as well
+```
+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"
+```

app/Main.hs

@@ -6,13 +6,13 @@
 
 module Main where
 
+import Control.Monad.Logger (runStderrLoggingT)
 import Data.ByteString.Lazy as BS
 import Data.List as List
-import Data.Text as T
+import Database.Persist.Postgresql (ConnectionString, runMigration, runSqlPersistMPool, withPostgresqlPool)
 import Debug.Trace (traceShow)
+import Store (migrateAll, save)
 import Track (parseBS, parseFile)
--- import Import
-
 import Yesod.Core
 import Yesod.Form.Fields
 import Yesod.Form.Functions
@@ -41,7 +41,7 @@ instance Yesod Souplesse
 
 getCalendarR :: Handler Html
 getCalendarR = do
-  (formWidget, formEnctype) <- generateFormPost uploadForm
+  (formWidget, _) <- generateFormPost uploadForm
   defaultLayout
     [whamlet|
 <h1>Calendar
@@ -92,14 +92,14 @@ instance RenderMessage Souplesse FormMessage where
 
 postUploadR :: Handler Html
 postUploadR = do
-  ((result, widget), enctype) <- runFormPost uploadForm
+  ((result, _), _) <- runFormPost uploadForm
   case result of
     FormSuccess upload -> do
       bs <- fileSourceByteString $ fileInfo upload
       case Track.parseBS (fromStrict bs) of
         Right points ->
           defaultLayout [whamlet|<p>#{List.length points} points - thanks!|]
-        Left e ->
+        Left _ ->
           defaultLayout
             [whamlet|<p>parse error ]
     FormMissing ->
@@ -114,9 +114,16 @@ postUploadR = do
 
             |]
 
+connStr :: ConnectionString
+connStr = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
+
 main :: IO ()
-main = do
-  points <- Track.parseFile "track.gpx"
+main = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
+  flip runSqlPersistMPool pool $ do
+    runMigration migrateAll
+
+    p1 : _ <- liftIO $ Track.parseFile "track.gpx"
+    Store.save p1
   static'@(Static settings) <- static "frontend"
-  putStrLn ("loaded " ++ show (List.length points) ++ " points from GPX")
+  -- putStrLn ("loaded " ++ show (List.length points) ++ " points from GPX")
   warp 3000 $ Souplesse static'

lib/Store.hs

@@ -0,0 +1,55 @@
+{-# 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 Store (save, migrateAll) where
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.Time.Clock (UTCTime)
+import Database.Persist
+import Database.Persist.Postgresql
+  ( ConnectionString,
+    SqlBackend,
+    createPostgresqlPool,
+    pgConnStr,
+    pgPoolSize,
+    runMigration,
+    runSqlPool,
+  )
+import Database.Persist.TH
+import Track as T
+
+connString :: ConnectionString
+connString = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
+
+share
+  [mkPersist sqlSettings, mkMigrate "migrateAll"]
+  [persistLowerCase|
+Trkpt
+    lat Double
+    lon Double
+    ele Double Maybe
+    time UTCTime
+    cadence Int Maybe
+    power Int Maybe
+    heartRate  Int Maybe
+|]
+
+fromPoint :: Point -> Trkpt
+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)
+
+save p = do insert $ fromPoint p

lib/Track.hs

@@ -4,6 +4,7 @@ module Track
   ( Track,
     Pos (..),
     BadFile,
+    Point,
     pos,
     cadence,
     power,
@@ -32,7 +33,7 @@ import Text.Read (readMaybe)
 import Text.XML
 import Text.XML.Cursor as Cursor
 
-data Pos = Pos Float Float (Maybe Float) deriving (Show, Eq)
+data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
 
 type Power = Maybe Int
 
@@ -64,12 +65,12 @@ instance Exception BadFile
 
 elToPoint :: Cursor -> Either SomeException Point
 elToPoint c =
-  let lat = listToMaybe (attribute "lat" c) >>= asFloat
-      lon = listToMaybe (attribute "lon" c) >>= asFloat
+  let lat = listToMaybe (attribute "lat" c) >>= asDouble
+      lon = listToMaybe (attribute "lon" c) >>= asDouble
       ts =
         listToMaybe (child c >>= element (gpxNS "time") >>= child >>= content)
           >>= (Data.Time.ISO8601.parseISO8601 . Data.Text.unpack)
-      ele = listToMaybe (child c >>= element (gpxNS "ele") >>= child >>= content) >>= asFloat
+      ele = listToMaybe (child c >>= element (gpxNS "ele") >>= child >>= content) >>= asDouble
       gpxtpx =
         child c
           >>= element (gpxNS "extensions")
@@ -93,7 +94,7 @@ elToPoint c =
               (listToMaybe hr >>= asInt)
         else Left (toException (BadFile "missing a required attribute"))
   where
-    asFloat v = (readMaybe :: String -> Maybe Float) (Data.Text.unpack v)
+    asDouble v = (readMaybe :: String -> Maybe Double) (Data.Text.unpack v)
     asInt v = (readMaybe :: String -> Maybe Int) (Data.Text.unpack v)
 
 getPoints :: Cursor -> Either SomeException [Point]

souplesse.cabal

@@ -73,6 +73,9 @@ executable souplesse
       , souplesse-lib
       , text
       , bytestring
+      , persistent
+      , persistent-postgresql
+      , monad-logger
       , yesod-core == 1.6.25.1
       , yesod-static
       , yesod-form
@@ -89,6 +92,7 @@ executable souplesse
 library souplesse-lib
     exposed-modules:
         Track
+        Store
     hs-source-dirs:
         lib
     build-depends:
@@ -97,6 +101,9 @@ library souplesse-lib
       , time
       , containers
       , text
+      , transformers
+      , persistent
+      , persistent-postgresql
       , iso8601-time
     default-language: GHC2021