85 lines
3 KiB
Haskell
85 lines
3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
import Control.Monad (when)
|
|
import Data.ByteString.Lazy qualified as BL
|
|
import Data.Either (lefts, rights)
|
|
import Data.Text qualified as T
|
|
import Data.Text.Encoding qualified as TE
|
|
import Data.Text.Lazy qualified as TL
|
|
import Data.Time (MonthOfYear, Year, addDays, fromGregorian, getCurrentTime, toGregorian)
|
|
import Data.Time.LocalTime
|
|
import Ical
|
|
import Lucid (renderText)
|
|
import Network.HTTP.Simple
|
|
import Network.HTTP.Types (status400)
|
|
import Network.Wai.Middleware.Static
|
|
import Render
|
|
import Text.Printf (printf)
|
|
import Web.Scotty
|
|
|
|
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
|
|
errors = lefts events
|
|
when (not $ null errors) $ do
|
|
liftIO $ print errors
|
|
|
|
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
|
|
errors = lefts events
|
|
when (not $ null errors) $ do
|
|
liftIO $ print errors
|
|
|
|
html $ renderText $ renderMonthview (year, month) dayToday groupedEvents
|
|
)
|