souplesse/app/Main.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Control.Monad.Logger (runStderrLoggingT)
import Data.ByteString.Lazy as BS
import Data.List as List
import Database.Persist.Postgresql (ConnectionString, runMigration, runSqlPersistMPool, withPostgresqlPool)
import Debug.Trace (traceShow)
import Store (migrateAll, save)
import Track (parseBS, parseFile)
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
  { getStatic :: Static
  }

-- ref https://www.yesodweb.com/book/routing-and-handlers
-- for adding params (start/end) to the timeline route
mkYesod
  "Souplesse"
  [parseRoutes|
/ CalendarR GET
/timeline TimelineR GET
/upload UploadR POST
/static StaticR Static getStatic
|]

instance Yesod Souplesse

getCalendarR :: Handler Html
getCalendarR = do
  (formWidget, _) <- generateFormPost uploadForm
  defaultLayout
    [whamlet|
<h1>Calendar

<p>A calendar view goes here

<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|
window.addEventListener("load", function(){
var app = Elm.Main.init({
  node: document.getElementById("elm")
});
})
|]
  toWidget
    [hamlet|
<pre id="elm">
<p>Copyright &copy; 2024 Daniel Barlow
|]

data FileForm = FileForm
  { fileInfo :: FileInfo
  }

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, _), _) <- 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 _ ->
          defaultLayout
            [whamlet|<p>parse error ]
    FormMissing ->
        defaultLayout [whamlet|<p>FormMissing  (?)|]
    FormFailure errors ->
      defaultLayout
        [whamlet|
                 <h1>Error uploading
                 <ul>
                     $forall err <- errors
                         <li>#{err}

            |]

connStr :: ConnectionString
connStr = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"

main :: IO ()
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")
  warp 3000 $ Souplesse static'