souplesse/app/Main.hs

146 lines
3.7 KiB
Haskell

{-# 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'