souplesse

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

Main.hs (5028B)

      1 {-# LANGUAGE MultiParamTypeClasses #-}
      2 {-# LANGUAGE OverloadedStrings #-}
      3 {-# LANGUAGE QuasiQuotes #-}
      4 {-# LANGUAGE TemplateHaskell #-}
      5 {-# LANGUAGE TypeFamilies #-}
      6 
      7 module Main where
      8 
      9 import Control.Monad.Logger (runStderrLoggingT)
     10 import Control.Monad.Trans.Resource (runResourceT)
     11 import Data.ByteString.Lazy as BS
     12 import Data.List as List
     13 import Data.Text as T
     14 import Data.Text.Lazy qualified as T (toStrict)
     15 import Data.Text.Lazy.Builder qualified as B
     16 import Data.Text.Lazy.Builder.Int qualified as B
     17 import Data.Time.Clock (nominalDiffTimeToSeconds)
     18 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
     19 import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend, runMigration, runSqlPool, withPostgresqlPool)
     20 import Debug.Trace (traceShow)
     21 import Point qualified (fetch, migration, save)
     22 import Session qualified
     23 import Track (parseBS)
     24 import Yesod.Core
     25 import Yesod.Form.Fields
     26 import Yesod.Form.Functions
     27 import Yesod.Form.Input
     28 import Yesod.Form.Types
     29 import Yesod.Persist
     30 import Yesod.Static
     31 
     32 staticFiles "frontend" -- this param appears to be a pathname
     33 
     34 data Souplesse = Souplesse ConnectionPool Static
     35 
     36 -- ref https://www.yesodweb.com/book/routing-and-handlers
     37 -- for adding params (start/end) to the timeline route
     38 mkYesod
     39   "Souplesse"
     40   [parseRoutes|
     41 / CalendarR GET
     42 /timeline TimelineR GET
     43 /upload UploadR POST
     44 /static StaticR Static getStatic
     45 /points PointsR GET
     46 |]
     47 
     48 getStatic :: Souplesse -> Static
     49 getStatic y =
     50   let Souplesse _ s = y
     51    in s
     52 
     53 instance Yesod Souplesse
     54 
     55 instance YesodPersist Souplesse where
     56   type YesodPersistBackend Souplesse = SqlBackend
     57 
     58   runDB action = do
     59     Souplesse pool _ <- getYesod
     60     runSqlPool action pool
     61 
     62 intToText :: (Integral a) => a -> T.Text
     63 intToText = T.toStrict . B.toLazyText . B.decimal
     64 
     65 getCalendarR :: Handler Html
     66 getCalendarR = do
     67   let fTime = intToText . floor . utcTimeToPOSIXSeconds
     68       fDur = intToText . ceiling . nominalDiffTimeToSeconds
     69   (formWidget, _) <- generateFormPost uploadForm
     70   sessions' <- runDB Session.recents
     71   defaultLayout
     72     [whamlet|
     73 <h1>Calendar
     74 
     75 <p>A calendar view goes here
     76 <ul>
     77     $forall s <- sessions'
     78         <li>
     79              <a href=@?{(TimelineR, [("start", fTime $ Session.startTime s), ("duration", fDur $ Session.duration s)])} > #{show $ Session.startTime s} #{show (Session.duration s)}
     80 
     81 <form action="/upload" method=post enctype="multipart/form-data">
     82     ^{formWidget}
     83     <input type="submit" name="send" value="send">
     84 
     85 <a href="/timeline">timeline
     86 &copy; 2024 Daniel Barlow
     87 |]
     88 
     89 getTimelineR :: Handler Html
     90 -- what's this about? <img src=@{StaticR image_png}/>|]
     91 getTimelineR = defaultLayout $ do
     92   setTitle "timeline"
     93   addScriptRemote "/static/frontend.js"
     94   toWidgetBody
     95     [julius|
     96 window.addEventListener("load", function(){
     97 var app = Elm.Main.init({
     98   node: document.getElementById("elm")
     99 });
    100 })
    101 |]
    102   toWidget
    103     [hamlet|
    104 <pre id="elm">
    105 <p>Copyright &copy; 2024 Daniel Barlow
    106 |]
    107 
    108 type Form x = Html -> MForm (HandlerFor Souplesse) (FormResult x, Widget)
    109 
    110 data Timerange = Timerange {start :: Int, duration :: Int} deriving (Show)
    111 
    112 getPointsR :: Handler Value
    113 getPointsR = do
    114   tr <-
    115     runInputGet $
    116       Timerange
    117         <$> ireq intField "start"
    118         <*> ireq intField "duration"
    119   let start' = posixSecondsToUTCTime $ fromInteger $ toInteger $ start tr
    120       duration' = fromInteger $ toInteger $ duration tr
    121   points <- runDB $ Point.fetch start' duration'
    122   returnJson (traceShow tr points)
    123 
    124 data FileForm = FileForm
    125   { fileInfo :: FileInfo
    126   }
    127 
    128 uploadForm :: Form FileForm
    129 uploadForm =
    130   renderDivs $
    131     FileForm
    132       <$> fileAFormReq "choose file"
    133 
    134 instance RenderMessage Souplesse FormMessage where
    135   renderMessage _ _ = defaultFormMessage
    136 
    137 postUploadR :: Handler Html
    138 postUploadR = do
    139   ((result, _), _) <- runFormPostNoToken uploadForm
    140 
    141   case result of
    142     FormSuccess upload -> do
    143       bs <- fileSourceByteString $ fileInfo upload
    144       case Track.parseBS (fromStrict bs) of
    145         Right points -> do
    146           eitherPoints <- runDB $ Point.save points
    147           case eitherPoints of
    148             Right points' ->
    149               defaultLayout [whamlet|<p>#{List.length points'} points - thanks!|]
    150             Left _ ->
    151               defaultLayout [whamlet|<p>overlap error |]
    152         Left _ ->
    153           defaultLayout
    154             [whamlet|<p>parse error |]
    155     FormMissing ->
    156       defaultLayout [whamlet|<p>FormMissing  (?)|]
    157     FormFailure errors ->
    158       defaultLayout
    159         [whamlet|
    160                  <h1>Error uploading
    161                  <ul>
    162                      $forall err <- errors
    163                          <li>#{err}
    164 
    165             |]
    166 
    167 connStr :: ConnectionString
    168 connStr = "host=127.0.0.1 port=5432 user=souplesse dbname=souplesse password=secret"
    169 
    170 main :: IO ()
    171 main = runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
    172   runResourceT $ flip runSqlPool pool $ do
    173     runMigration Session.migration
    174     runMigration Point.migration
    175   static' <- static "frontend"
    176   warp 3000 $ Souplesse pool static'