souplesse/app/Main.hs

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

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 (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
import Debug.Trace (traceShow)
import Store (fetch, migrateAll, save)
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 ConnectionPool 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
/points PointsR GET
|]

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
  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
|]

getPointsR :: Handler Value
getPointsR = do
  points <- runDB Store.fetch
  returnJson points

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 -> 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  (?)|]
    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
  runResourceT $ flip runSqlPool pool $ do
    runMigration migrateAll
  static' <- static "frontend"
  warp 3000 $ Souplesse pool static'