chipburners_web/app/Main.hs

{-# 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, addUTCTime, fromGregorian, getCurrentTime, secondsToNominalDiffTime, toGregorian)
import Data.String (fromString)
import Data.Time.LocalTime
import Ical
import Interested qualified
import Lucid (renderText)
import Network.HTTP.Simple
import Network.HTTP.Types (status400)
import Network.Wai.Middleware.Static (staticPolicy, addBase, noDots, (>->))
import Network.Wai.Handler.Warp (setPort, setHost)
import Options.Applicative
  ( Parser,
    auto,
    execParser,
    fullDesc,
    help,
    helper,
    info,
    long,
    metavar,
    option,
    progDesc,
    short,
    showDefault,
    strOption,
    value,
    (<**>),
  )
import Render
import Text.Printf (printf)
import Translation (Lang (EN, ES), getLangAsString)
import Web.Scotty
import Web.Scotty.Cookie (defaultSetCookie, getCookie, setCookie, setCookieExpires, setCookieName, setCookieValue)

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

getLanguageHeader :: Maybe TL.Text -> Lang
getLanguageHeader (Just h)
  | pre "es" h = ES
  | pre "en" h = EN
  | otherwise = ES
  where
    pre = TL.isPrefixOf
getLanguageHeader Nothing = ES

data Config = Config
  { configHost :: String,
    configPort :: Int
  }

configParser :: Parser Config
configParser =
  Config
    <$> strOption
      ( long "bind"
          <> short 'b'
          <> metavar "HOST"
          <> help "Interface to bind to"
          <> value "127.0.0.1"
          <> showDefault
      )
    <*> option
      auto
      ( long "port"
          <> short 'p'
          <> metavar "PORT"
          <> help "Port to listen on"
          <> value 3000
          <> showDefault
      )

main :: IO ()
main = do
  cfg <- execParser $ info (configParser <**> helper)
        ( fullDesc <> progDesc "A Scotty web server with custom bind/port" )

  let opts = defaultOptions 
                   { settings = setPort (configPort cfg) 
                              $ setHost (fromString (configHost cfg)) 
                              $ settings defaultOptions 
          }
  scottyOpts opts $ do
        middleware $ staticPolicy (noDots >-> addBase "static")

        get "/" $ do
          langHeader <- header "Accept-Language"
          let lang = getLanguageHeader langHeader

          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 lang validEvents
        get "/wiki" $ do
          langHeader <- header "Accept-Language"
          let lang = getLanguageHeader langHeader
              langString = getLangAsString lang
          redirect $ TL.pack $ printf "/%s/" langString
        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
          langHeader <- header "Accept-Language"
          let lang = getLanguageHeader langHeader
          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 lang (year, month) dayToday groupedEvents
        get "/api/interested/register/:event" $ do
          event <- pathParam "event"
          let cookieName = "interested-" <> event
          returnUri <- queryParam "return"
          cookie <- getCookie cookieName
          newCookie <- liftIO $ Interested.register event cookie
          currentTime <- (liftIO $ getCurrentTime)
          setCookie
            ( defaultSetCookie
                { setCookieName = TE.encodeUtf8 cookieName,
                  setCookieValue = TE.encodeUtf8 newCookie,
                  -- TODO: just adding one month of expire which is kind of weird
                  setCookieExpires = Just (addUTCTime (secondsToNominalDiffTime 60 * 60 * 24 * 30) currentTime)
                }
            )
          redirect returnUri