{-# 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 (Text, unpack)
-- https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Static-file-subsite-Hello-World.md

import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
import Debug.Trace (traceShow)
import Store (fetch, migrateAll, save)
import Text.Read (readMaybe)
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

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

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 $ Store.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, _), _) <- runFormPost uploadForm

  case result of
    FormSuccess upload -> do
      bs <- fileSourceByteString $ fileInfo upload
      case Track.parseBS (fromStrict bs) of
        Right points -> do
          runDB $ 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'