souplesse

commit 798ded7541fc2fd19cd76810c67318acab7305fe
parent 81fa7346d3ff0febd32577d7deb69c5893471dac
Author: Daniel Barlow <dan@telent.net>
Date:   Tue,  5 Nov 2024 19:35:34 +0000

save points to postgres in upload handler

Diffstat:
M
README.md
 | 
16
++++++++++++----
M
app/Main.hs
 | 
35
+++++++++++++++++++++++------------
M
souplesse.cabal
 | 
2
++

3 files changed, 37 insertions(+), 16 deletions(-)
diff --git a/README.md b/README.md
@@ -66,13 +66,21 @@ _Do not look below this line_
  a singly-linked list
 
 * need a web server in haskell that
- - accepts file upload and parses the gpx file
+ - [done] accepts file upload and parses the gpx file
  - serves the data points in some format elm can digest easily
-* need a database of some kind so the data can be saved
+* [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
-* for DX, backend can serve the js files needed by frontend
-* we only have yesod-core, may need other parts as well
+* [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
+
+
+## Postgres
+
+I run the postgresql devel server using Docker instead of changing my
+global NixOS configuration, so that it's self-contained and I can
+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"
diff --git a/app/Main.hs b/app/Main.hs
@@ -7,24 +7,24 @@
 module Main where
 
 import Control.Monad.Logger (runStderrLoggingT)
+import Control.Monad.Trans.Resource (runResourceT)
 import Data.ByteString.Lazy as BS
 import Data.List as List
-import Database.Persist.Postgresql (ConnectionString, runMigration, runSqlPersistMPool, withPostgresqlPool)
+import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
 import Debug.Trace (traceShow)
 import Store (migrateAll, save)
-import Track (parseBS, parseFile)
+import Track (parseBS)
 import Yesod.Core
 import Yesod.Form.Fields
 import Yesod.Form.Functions
 import Yesod.Form.Types
+import Yesod.Persist
 -- https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Static-file-subsite-Hello-World.md
 import Yesod.Static
 
 staticFiles "frontend" -- this param appears to be a pathname
 
-data Souplesse = Souplesse
-  { getStatic :: Static
-  }
+data Souplesse = Souplesse ConnectionPool Static
 
 -- ref https://www.yesodweb.com/book/routing-and-handlers
 -- for adding params (start/end) to the timeline route
@@ -37,8 +37,20 @@ mkYesod
 /static StaticR Static getStatic
 |]
 
+getStatic :: Souplesse -> Static
+getStatic y =
+  let Souplesse _ s = y
+   in s
+
 instance Yesod Souplesse
 
+instance YesodPersist Souplesse where
+  type YesodPersistBackend Souplesse = SqlBackend
+
+  runDB action = do
+    Souplesse pool _ <- getYesod
+    runSqlPool action pool
+
 getCalendarR :: Handler Html
 getCalendarR = do
   (formWidget, _) <- generateFormPost uploadForm
@@ -93,17 +105,19 @@ instance RenderMessage Souplesse FormMessage where
 postUploadR :: Handler Html
 postUploadR = do
   ((result, _), _) <- runFormPost uploadForm
+
   case result of
     FormSuccess upload -> do
       bs <- fileSourceByteString $ fileInfo upload
       case Track.parseBS (fromStrict bs) of
-        Right points ->
+        Right points -> do
+          runDB $ mapM_ Store.save points
           defaultLayout [whamlet|<p>#{List.length points} points - thanks!|]
         Left _ ->
           defaultLayout
             [whamlet|<p>parse error |]
     FormMissing ->
-        defaultLayout [whamlet|<p>FormMissing  (?)|]
+      defaultLayout [whamlet|<p>FormMissing  (?)|]
     FormFailure errors ->
       defaultLayout
         [whamlet|
@@ -119,10 +133,7 @@ connStr = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=sec
 
 main :: IO ()
 main = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
-  flip runSqlPersistMPool pool $ do
+  runResourceT $ flip runSqlPool pool $ do
     runMigration migrateAll
-
-    p1 : _ <- liftIO $ Track.parseFile "track.gpx"
-    Store.save p1
   static' <- static "frontend"
-  warp 3000 $ Souplesse static'
+  warp 3000 $ Souplesse pool static'
diff --git a/souplesse.cabal b/souplesse.cabal
@@ -75,10 +75,12 @@ executable souplesse
       , bytestring
       , persistent
       , persistent-postgresql
+      , resourcet
       , monad-logger
       , yesod-core == 1.6.25.1
       , yesod-static
       , yesod-form
+      , yesod-persistent
 
     -- Directories containing source files.
     hs-source-dirs:   app