From 1b8293f93e37c8a2a17f40b45b77b640e35675fe Mon Sep 17 00:00:00 2001
From: Daniel Barlow <dan@telent.net>
Date: Sun, 3 Nov 2024 18:40:31 +0000
Subject: [PATCH] upload gpx file (cargo-culted, very rough)

---
 app/Main.hs     | 86 +++++++++++++++++++++++++++++++++++++++++--------
 lib/Track.hs    |  7 +++-
 souplesse.cabal |  3 ++
 3 files changed, 81 insertions(+), 15 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index c63729e..778d3c1 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,17 +1,25 @@
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Main where
 
-import Track(parseFile)
+import Data.ByteString.Lazy as BS
 import Data.List as List
+import Data.Text as T
+import Debug.Trace (traceShow)
+import Track (parseBS, parseFile)
+-- import Import
 
-import           Yesod.Core
-
+import Yesod.Core
+import Yesod.Form.Fields
+import Yesod.Form.Functions
+import Yesod.Form.Types
 -- 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
@@ -20,42 +28,92 @@ data Souplesse = Souplesse
 
 -- ref https://www.yesodweb.com/book/routing-and-handlers
 -- for adding params (start/end) to the timeline route
-mkYesod "Souplesse" [parseRoutes|
+mkYesod
+  "Souplesse"
+  [parseRoutes|
 / CalendarR GET
 /timeline TimelineR GET
+/upload UploadR POST
 /static StaticR Static getStatic
 |]
 
 instance Yesod Souplesse
 
 getCalendarR :: Handler Html
-getCalendarR = defaultLayout [whamlet|
-<h1>Calendar</h1>
+getCalendarR = do
+  (formWidget, formEnctype) <- generateFormPost uploadForm
+  defaultLayout
+    [whamlet|
+<h1>Calendar
 
 <p>A calendar view goes here
 
-<a href="/timeline">timeline</a>
+<form action="/upload" method=post enctype="multipart/form-data">
+    ^{formWidget}
+    <input type="submit" name="send" value="send">
+
+<a href="/timeline">timeline
 &copy; 2024 Daniel Barlow
 |]
 
 getTimelineR :: Handler Html
-
 -- what's this about? <img src=@{StaticR image_png}/>|]
 getTimelineR = defaultLayout $ do
   setTitle "timeline"
   addScriptRemote "/static/frontend.js"
-  toWidgetBody [julius|
+  toWidgetBody
+    [julius|
 window.addEventListener("load", function(){
 var app = Elm.Main.init({
   node: document.getElementById("elm")
 });
 })
 |]
-  toWidget [hamlet|
+  toWidget
+    [hamlet|
 <pre id="elm">
 <p>Copyright &copy; 2024 Daniel Barlow
 |]
 
+-- data File = File
+
+data FileForm = FileForm
+  { fileInfo :: FileInfo
+  --    , fileDescription :: Text
+  }
+
+type Form x = Html -> MForm (HandlerFor Souplesse) (FormResult x, Widget)
+
+uploadForm :: Form FileForm
+uploadForm =
+  renderDivs $
+    FileForm
+      <$> fileAFormReq "choose file"
+
+instance RenderMessage Souplesse FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
+postUploadR :: Handler Html
+postUploadR = do
+  ((result, widget), enctype) <- 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 ->
+          defaultLayout
+            [whamlet|<p>error ]
+        FormMissing  ->
+          traceShow "missing" $
+          defaultLayout [whamlet|<p>missing|]
+    FormFailure x ->
+      traceShow x $
+        defaultLayout
+          [whamlet|
+                <p>Nope, sorry
+            |]
 
 main :: IO ()
 main = do
diff --git a/lib/Track.hs b/lib/Track.hs
index 8a7cad5..e66e4bc 100644
--- a/lib/Track.hs
+++ b/lib/Track.hs
@@ -11,17 +11,18 @@ module Track
     time,
     parse,
     parseFile,
+    parseBS,
     Track.length,
   )
 where
 
 import Control.Exception
+import Data.Either
 import Data.Functor ((<&>))
 import Data.List as List
 import Data.List qualified
 import Data.Map as Map
 import Data.Maybe
-import Data.Either
 import Data.Text qualified
 import Data.Text.Lazy as T
 import Data.Time
@@ -119,3 +120,7 @@ parseFile name = do
   return $ case getPoints (fromDocument gpx) of
     Left err -> []
     Right points -> points
+
+parseBS bs = do
+  gpx <- parseLBS def bs
+  getPoints (fromDocument gpx)
diff --git a/souplesse.cabal b/souplesse.cabal
index b32bf61..b28d2b1 100644
--- a/souplesse.cabal
+++ b/souplesse.cabal
@@ -71,8 +71,11 @@ executable souplesse
     build-depends:
         base ^>=4.18.2.1
       , souplesse-lib
+      , text
+      , bytestring
       , yesod-core == 1.6.25.1
       , yesod-static
+      , yesod-form
 
     -- Directories containing source files.
     hs-source-dirs:   app