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 Data.Text as T
import Data.Text.Lazy qualified as T (toStrict)
import Data.Text.Lazy.Builder qualified as B
import Data.Text.Lazy.Builder.Int qualified as B
import Data.Time.Clock (nominalDiffTimeToSeconds)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
import Debug.Trace (traceShow)
import Point qualified (fetch, migration, save)
import Session qualified
import Track (parseBS)
import Yesod.Core
import Yesod.Form.Fields
import Yesod.Form.Functions
import Yesod.Form.Input
import Yesod.Form.Types
import Yesod.Persist
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

intToText :: (Integral a) => a -> T.Text
intToText = T.toStrict . B.toLazyText . B.decimal

getCalendarR :: Handler Html
getCalendarR = do
  let fTime = intToText . floor . utcTimeToPOSIXSeconds
      fDur = intToText . ceiling . nominalDiffTimeToSeconds
  (formWidget, _) <- generateFormPost uploadForm
  sessions' <- runDB Session.recents
  defaultLayout
    [whamlet|
<h1>Calendar

<p>A calendar view goes here
<ul>
    $forall s <- sessions'
        <li>
             <a href=@?{(TimelineR, [("start", fTime $ Session.startTime s), ("duration", fDur $ Session.duration s)])} > #{show $ Session.startTime s} #{show (Session.duration s)}

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

type Form x = Html -> MForm (HandlerFor Souplesse) (FormResult x, Widget)

data Timerange = Timerange {start :: Int, duration :: Int} deriving (Show)

getPointsR :: Handler Value
getPointsR = do
  tr <-
    runInputGet $
      Timerange
        <$> ireq intField "start"
        <*> ireq intField "duration"
  let start' = posixSecondsToUTCTime $ fromInteger $ toInteger $ start tr
      duration' = fromInteger $ toInteger $ duration tr
  points <- runDB $ Point.fetch start' duration'
  returnJson (traceShow tr points)

data FileForm = FileForm
  { fileInfo :: FileInfo
  }

uploadForm :: Form FileForm
uploadForm =
  renderDivs $
    FileForm
      <$> fileAFormReq "choose file"

instance RenderMessage Souplesse FormMessage where
  renderMessage _ _ = defaultFormMessage

postUploadR :: Handler Html
postUploadR = do
  ((result, _), _) <- runFormPostNoToken uploadForm

  case result of
    FormSuccess upload -> do
      bs <- fileSourceByteString $ fileInfo upload
      case Track.parseBS (fromStrict bs) of
        Right points -> do
          eitherPoints <- runDB $ Point.save points
          case eitherPoints of
            Right points' ->
              defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
            Left _ ->
              defaultLayout [whamlet|<p>overlap error |]
        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 Session.migration
    runMigration Point.migration
  static' <- static "frontend"
  warp 3000 $ Souplesse pool static'