130 lines
3.3 KiB
Haskell
130 lines
3.3 KiB
Haskell
{-# 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
|
|
© 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 © 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'
|