110 lines
4 KiB
Haskell
110 lines
4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
import Network.HTTP.Types (status400)
|
|
import Data.ByteString.Lazy qualified as BL
|
|
import Data.Either (rights)
|
|
import Data.Text qualified as T
|
|
import Data.Text.Encoding qualified as TE
|
|
import Data.Time (addDays, getCurrentTime)
|
|
import Data.Time (MonthOfYear, Year, fromGregorian, toGregorian)
|
|
import Data.Time.LocalTime
|
|
import Ical
|
|
import Lucid (renderText)
|
|
import Network.HTTP.Simple
|
|
import Network.Wai.Middleware.Static
|
|
import Render
|
|
import Web.Scotty
|
|
import qualified Data.Text.Lazy as TL
|
|
import Text.Printf (printf)
|
|
|
|
getFromUrl :: String -> IO T.Text
|
|
getFromUrl url = do
|
|
r <- parseRequest url
|
|
response <- httpLBS r
|
|
let rBody = getResponseBody response
|
|
let rText = TE.decodeUtf8 (BL.toStrict rBody)
|
|
pure $ T.replace "\n " " " $ T.replace "\r\n" "\n" rText
|
|
|
|
main :: IO ()
|
|
main =
|
|
scotty
|
|
3456
|
|
( do
|
|
middleware $ staticPolicy (noDots >-> addBase "static")
|
|
|
|
get "/" $ do
|
|
linesArray <- liftIO $ getFromUrl "https://cdav.chipburners.club/public/main/"
|
|
timeNow <- liftIO $ getCurrentTime
|
|
tmz <- liftIO $ getCurrentTimeZone
|
|
|
|
let today = utcToLocalTime tmz timeNow
|
|
dayToday = localDay today
|
|
endD = addDays 30 dayToday
|
|
events = readCalendar linesArray
|
|
validEvents = take 5 $ getEventsFromTo (rights events) dayToday endD
|
|
-- TODO: errors
|
|
-- errors = lefts events
|
|
|
|
html $ renderText $ renderFrontpage validEvents
|
|
get "/monthView/" $ do
|
|
timeNow <- liftIO $ getCurrentTime
|
|
tmz <- liftIO $ getCurrentTimeZone
|
|
|
|
let today = utcToLocalTime tmz timeNow
|
|
dayToday = localDay today
|
|
(y, m, _) = toGregorian dayToday
|
|
redirect $ TL.pack $ printf "/monthView/%s/%s" (show y) (show m)
|
|
|
|
get "/monthView/:year/:month" $ do
|
|
year :: Year <- pathParam "year"
|
|
month :: MonthOfYear <- pathParam "month"
|
|
|
|
if (year <= 2000 || year >= 3000 || month < 1 || month > 12)
|
|
then do
|
|
status status400
|
|
text "Invalid date"
|
|
else do
|
|
linesArray <- liftIO $ getFromUrl "https://cdav.chipburners.club/public/main/"
|
|
timeNow <- liftIO $ getCurrentTime
|
|
tmz <- liftIO $ getCurrentTimeZone
|
|
|
|
let firstOfMonth = fromGregorian year month 1
|
|
start = addDays (-7) firstOfMonth
|
|
end = addDays (37) firstOfMonth
|
|
today = utcToLocalTime tmz timeNow
|
|
dayToday = localDay today
|
|
events = readCalendar linesArray
|
|
validEvents = getEventsFromTo (rights events) start end
|
|
groupedEvents = groupEvents validEvents
|
|
-- dayToday = localDay today
|
|
-- (y, m, _) = toGregorian dayToday
|
|
-- errors = lefts events
|
|
|
|
html $ renderText $ renderMonthview (year, month) dayToday groupedEvents
|
|
|
|
|
|
-- get "/greet/:name" $ do
|
|
-- name <- param "name"
|
|
-- "Hello, " <> name <> "! Hope you're enjoying Haskell."
|
|
)
|
|
|
|
-- pure finalHtml
|
|
|
|
-- let event = toEvent ["SUMMARY:Hello!", "Random Line", "DTSTART:20260123T140000", "DTEND:20260123T140000", "RRULE:FREQ=WEEKLY;BYDAY=MO,TU,SA;COUNT=7"]
|
|
-- case event of
|
|
-- Right eve -> case parseDate "20260226T140000" of
|
|
-- Right c -> print $ expandEvent eve (localDay c)
|
|
-- _ -> print "Failed parse date"
|
|
-- _ -> print "failed event parse"
|
|
--
|
|
-- linesArray <- getFromUrl "https://cdav.chipburners.club/public/main/"
|
|
-- linesArray <- getFromUrl "http://www.upv.es/ical/3F60368113136708712FBB9C9243EDDC339D45EB9EAA9004F084E8DCF0F37A8F1AB9C2153EC8F12E1DFDFF671D7A52CE"
|
|
-- print (readCalendar linesArray)
|
|
-- end <- getCurrentTime
|
|
-- tmz <- getCurrentTimeZone
|
|
-- let today = utcToLocalTime tmz end
|
|
-- let endD = addDays 30 (localDay today)
|
|
-- let events = getNextEventsUntil (rights (readCalendar linesArray)) 10 endD
|
|
-- updateIndexHtml events
|
|
-- print
|
|
-- events
|