fix flake, add translation, add args

app/Main.hs

@@ -7,17 +7,38 @@ 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
+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))
 import Web.Scotty
-import Web.Scotty.Cookie (defaultSetCookie, setCookieExpires, setCookieName, setCookieValue)
+import Web.Scotty.Cookie (defaultSetCookie, getCookie, setCookie, setCookieExpires, setCookieName, setCookieValue)
 
 getFromUrl :: String -> IO T.Text
 getFromUrl url = do
@@ -27,14 +48,59 @@ getFromUrl url = do
   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
+  }
+
+-- Build the parser
+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 =
+main = do
-  scotty
+  cfg <- execParser $ info (configParser <**> helper)
-    3456
+        ( fullDesc <> progDesc "A Scotty web server with custom bind/port" )
-    ( do
+
+  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
@@ -48,7 +114,7 @@ main =
           when (not $ null errors) $ do
             liftIO $ print errors
 
-          html $ renderText $ renderFrontpage validEvents
+          html $ renderText $ renderFrontpage lang validEvents
         get "/monthView/" $ do
           timeNow <- liftIO $ getCurrentTime
           tmz <- liftIO $ getCurrentTimeZone
@@ -59,6 +125,8 @@ main =
           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"
 
@@ -83,7 +151,7 @@ main =
               when (not $ null errors) $ do
                 liftIO $ print errors
 
-              html $ renderText $ renderMonthview (year, month) dayToday groupedEvents
+              html $ renderText $ renderMonthview lang (year, month) dayToday groupedEvents
         get "/api/interested/register/:event" $ do
           event <- pathParam "event"
           let cookieName = "interested-" <> event
@@ -100,4 +168,3 @@ main =
                 }
             )
           redirect returnUri
-    )

chipburners-club.cabal

@@ -54,6 +54,7 @@ executable chipburners-club
     Ical
     Interested
     Render
+    Translation
 
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:
@@ -70,7 +71,9 @@ executable chipburners-club
     http-conduit,
     http-types,
     lucid,
+    optparse-applicative,
     scotty,
+    warp,
     text,
     time,
     uuid,
@@ -82,4 +85,4 @@ executable chipburners-club
     src
 
   -- Base language which the package is written in.
-  default-language: GHC2024
+  default-language: GHC2021

flake.nix

@@ -10,16 +10,17 @@
     flake-utils.lib.eachDefaultSystem (system:
       let
         pkgs = import nixpkgs { inherit system; };
-        haskellApp = pkgs.haskellPackages.callCabal2nix "chipburners-club" ./. {
+        hpkgs = pkgs.haskell.packages.ghc910;
+        haskellApp = hpkgs.callCabal2nix "chipburners-club" ./. {
           inherit (pkgs) zlib zstd;
         };
       in
       {
         packages.default = haskellApp;
 
-        devShells.default = pkgs.mkShell {
+        devShells.default = hpkgs.shellFor {
-          buildInputs = with pkgs; [
+          packages = p: [ haskellApp ];
-            ghc
+          nativeBuildInputs = with pkgs; [
             cabal-install
             haskell-language-server
             zlib

src/Render.hs

@@ -10,9 +10,10 @@ import Data.Time (Day, MonthOfYear, Year, addDays, addGregorianMonthsClip, dayOf
 import Ical
 import Lucid
 import Text.Printf (printf)
+import Translation
 
-renderHead :: Html ()
+renderHead :: Lang -> Html ()
-renderHead = do
+renderHead lang = do
   doctype_
   html_ [lang_ "es"] $ do
     head_ $ do
@@ -23,23 +24,22 @@ renderHead = do
         ]
       meta_
         [ name_ "description",
-          content_ "Chipburners home page"
+          content_ $ tr lang PageDesc
         ]
       title_ "Chipburners"
       link_ [rel_ "stylesheet", href_ "/style.css"]
 
-renderHeader :: Int -> Html ()
+renderHeader :: Lang -> Int -> Html ()
-renderHeader active =
+renderHeader lang active =
   header_ [class_ "site-header"] $ do
     nav_ [] $ do
       ul_ [class_ "nav-list"] $ do
-        li_ $ a_ [href_ "/", getActive 0] "Chip"
+        li_ $ a_ [href_ "/", getActive 0] (toHtml $ tr lang NavChip)
-        li_ $ a_ [href_ "/monthView", getActive 1] "Eventos"
+        li_ $ a_ [href_ "/monthView", getActive 1] (toHtml $ tr lang NavEvents)
-        li_ $ a_ [href_ "/wiki", getActive 2] "Wiki"
+        li_ $ a_ [href_ "/wiki", getActive 2] (toHtml $ tr lang NavWiki)
-        li_ $ a_ [href_ "/contact", getActive 3] "Contacto"
+        li_ $ a_ [href_ "/wiki/contact", getActive 3] (toHtml $ tr lang NavContact)
   where
     getActive cur = if cur == active then class_ "active" else class_ "inactive"
-
 renderImage :: T.Text -> T.Text -> T.Text -> Html ()
 renderImage url caption alt =
   figure_ $ do
@@ -59,46 +59,48 @@ renderSideEvent e =
       let uid = euid e
       a_ [href_ ("/monthView#" <> uid), class_ "event-link"] $ toHtml (summary e)
 
-renderDayGroup :: (Day, [Event]) -> Html ()
+renderDayGroup :: Lang -> (Day, [Event]) -> Html ()
-renderDayGroup (day, events) =
+renderDayGroup lang (day, events) =
   li_ [class_ "event-group"] $ do
     time_
       [ datetime_ $ T.pack (formatTime defaultTimeLocale "%Y-%m-%d" day),
         class_ "date-header"
       ]
       $ toHtml
-      $ T.pack (formatTime defaultTimeLocale "%A %d.%m.%y" day)
+      $ T.pack (formatTime (getLocale lang) "%A %d.%m.%y" day)
     ul_ [class_ "daily-events"] $
       mapM_ renderSideEvent events
 
-renderEventList :: [Event] -> Html ()
+
+renderEventList :: Lang -> [Event] -> Html ()
 -- mapM_ only cares about the monad I think? So it throws away the () part
 -- mapM applies the monad to everz element of the list and returns monad with a list?
-renderEventList events = mapM_ renderDayGroup (groupEvents events)
+renderEventList lang events = mapM_ (renderDayGroup lang) (groupEvents events)
 
-renderFrontpage :: [Event] -> Html ()
+trh :: Lang -> Msg -> Html ()
-renderFrontpage events = do
+trh lang m = toHtml $ tr lang m
-  renderHead
+
+renderFrontpage :: Lang -> [Event] -> Html ()
+renderFrontpage lang events = do
+  renderHead lang
   body_ $ do
-    renderHeader 0
+    renderHeader lang 0
     div_ [class_ "wrapper"] $ do
       div_ [class_ "layout"] $ do
         main_ [id_ "main-content", class_ "content"] $ do
           section_ [class_ "intro"] $ do
             h1_ "Chipburners_"
             p_ [class_ "lead"] $
-              "Frase motivadora aqui"
+              trh lang Lead
             p_ $ do
-              "Buenos dias, "
+              trh lang HomeGreeting
               br_ []
-              "Somos un grupo d personas y entidades interesados en infromatica y \
+              trh lang HomeP1
-              \las technologias relacionadas. "
               br_ []
-              "Este hackerspace ha sido creado como manera d juntar gente con intereses \
+              trh lang HomeP2
-              \similares y compartir conocimientos. "
               br_ []
-              "Contactanos en "
+              trh lang HomePContact
-              a_ [href_ "/contact"] "signal"
+              a_ [href_ "/contact"] $ trh lang HomeContactHere
               "!"
 
           section_ [class_ "image-gallery"] $ do
@@ -106,8 +108,8 @@ renderFrontpage events = do
 
         aside_ [class_ "sidebar"] $ do
           section_ [class_ "events-panel"] $ do
-            h2_ "Eventos"
+            h2_ $ trh lang NavEvents
-            renderEventList events
+            renderEventList lang events
 
 chunksOf :: Int -> [a] -> [[a]]
 chunksOf _ [] = []
@@ -118,8 +120,8 @@ chunksOf n xs =
 padZero :: Int -> String
 padZero n = if n < 10 then "0" ++ show n else show n
 
-renderCalendarEvent :: Event -> Html ()
+renderCalendarEvent :: Lang -> Event -> Html ()
-renderCalendarEvent e = do
+renderCalendarEvent lang e = do
   let uid = euid e
   li_ [class_ "event-item"] $ do
     -- (toHtml $ summary e)
@@ -137,7 +139,7 @@ renderCalendarEvent e = do
           T.pack $
             printf
               "%s -> %s - %s"
-              (formatTime defaultTimeLocale "%A %d.%m.%y" $ dtStart e)
+              (formatTime (getLocale lang) "%A %d.%m.%y" $ dtStart e)
               (formatTime defaultTimeLocale "%H:%M" $ dtStart e)
               (formatTime defaultTimeLocale "%H:%M" $ dtEnd e)
 
@@ -145,8 +147,8 @@ renderCalendarEvent e = do
         toHtml $
           description e
 
-renderMonthview :: (Year, MonthOfYear) -> Day -> [(Day, [Event])] -> Html ()
+renderMonthview :: Lang -> (Year, MonthOfYear) -> Day -> [(Day, [Event])] -> Html ()
-renderMonthview (year, month) today groupedEvents = do
+renderMonthview lang (year, month) today groupedEvents = do
   let firstOfMonth = fromGregorian year month 1
       wd = dayOfWeek firstOfMonth
 
@@ -169,9 +171,9 @@ renderMonthview (year, month) today groupedEvents = do
           ]
           label
 
-  renderHead
+  renderHead lang
   body_ $ do
-    renderHeader 1
+    renderHeader lang 1
     div_ [class_ "calendar-wrapper"] $ do
       header_ [class_ "calendar-header"] $ do
         h1_ [class_ "view-title"] "Vista mensual"
@@ -183,20 +185,14 @@ renderMonthview (year, month) today groupedEvents = do
 
         h2_ [class_ "month-name"] $
           toHtml $
-            formatTime defaultTimeLocale "%B %Y" $
+            formatTime (getLocale lang) "%B %Y" $
               fromGregorian year month 1
 
       table_ [class_ "calendar-table"] $ do
         thead_ $ do
           tr_ $ do
-            th_ "Lunes"
+            forM_ [1 .. 7] $ \i ->
-            th_ "Martes"
+              th_ (trh lang (DayName i))
-            th_ "Miercoles"
-            th_ "Jueves"
-            th_ "Viernes"
-            th_ "Sabado"
-            th_ "Domingo"
-
         tbody_ $ do
           forM_ weeks $ \week -> do
             tr_ $ do
@@ -221,4 +217,4 @@ renderMonthview (year, month) today groupedEvents = do
                     then return ()
                     else ul_ [class_ "event-list"] $ do
                       forM_ dayEvents $ \e ->
-                        renderCalendarEvent e
+                        renderCalendarEvent lang e

src/Translation.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Translation where
+
+import Data.Text (Text)
+import Data.Time.Format (TimeLocale (..), defaultTimeLocale)
+
+data Lang = ES | EN deriving (Show, Eq)
+
+data Msg
+  = PageDesc
+  | NavChip
+  | NavEvents
+  | NavWiki
+  -- Calendar
+  | NavContact
+  | NavMonthView
+  | NavPrevMonth
+  | NavThisMonth
+  | NavNextMonth
+  -- Home page text
+  | Lead
+  | HomeGreeting
+  | HomeP1
+  | HomeP2
+  | HomePContact
+  | HomeContactHere
+
+  | SignalLink
+  | ImgCaption
+  | ImgAlt
+  | SidebarEvents
+  | DayName Int
+
+tr :: Lang -> Msg -> Text
+tr ES msg = case msg of
+  PageDesc -> "Pagina inicial de chipburners"
+  NavChip -> "Chip"
+  NavEvents -> "Eventos"
+  NavWiki -> "Wiki"
+  NavContact -> "Contacto"
+  NavMonthView -> "Vista mensual"
+  NavPrevMonth -> "« Mes pasado"
+  NavThisMonth -> "Este mes"
+  NavNextMonth -> "Mes siguiente »"
+  Lead -> "Los chips estan burning"
+  HomeGreeting -> "Buenos dias,"
+  HomeP1 -> "Somos un grupo de personas y entidades interesados en infromatica y las technologias relacionadas. Este hackerspace ha sido creado como manera d juntar gente con intereses similares y compartir conocimientos. Mas que nada intentamos hacer una variedad de charlas y talleres sobre temas mas profundos, organizar espacios de trabajo colaborativo, ayudar con projectos personales y lo mas importnate:"
+  HomeP2 -> "Creer una comunidad amigable y respetuosa de gente interesante"
+  HomePContact -> "Contactanos "
+  HomeContactHere -> "aqui!"
+  SidebarEvents -> "Eventos"
+  ImgCaption -> "Imagen sobre algo"
+  ImgAlt -> "Imagen interesante"
+  SignalLink -> "signal"
+  DayName 1 -> "Lunes"
+  DayName 2 -> "Martes"
+  DayName 3 -> "Miércoles"
+  DayName 4 -> "Jueves"
+  DayName 5 -> "Viernes"
+  DayName 6 -> "Sábado"
+  DayName 7 -> "Domingo"
+  DayName _ -> ""
+tr EN msg = case msg of
+  PageDesc -> "Chipbuerns home page"
+  NavChip -> "Chip"
+  NavEvents -> "Events"
+  NavWiki -> "Wiki"
+  NavContact -> "Contact"
+  NavMonthView -> "Monthly View"
+  NavPrevMonth -> "« Last Month"
+  NavThisMonth -> "This Month"
+  NavNextMonth -> "Next Month »"
+  Lead -> "The chips are burning"
+  HomeGreeting -> "Good morning,"
+  HomeP1 -> "We are a group of people and entities interested in computer science and related technologies. This hacerpsace was created as a way to meet individuals with similar interests and share knowledge. We host a variety of workshops and talks about, goind in-depth into more obscure topics. Apart from that we facilitate community work spaces to share and help with personal projects. Hoever, most importantly we want to:"
+  HomeP2 -> "Create a friendly and respectful community of interesting people"
+  HomePContact -> "You can contact us "
+  HomeContactHere -> "here!"
+  SidebarEvents -> "Events"
+  ImgCaption -> "Image about something"
+  ImgAlt -> "Interesting image"
+  SignalLink -> "signal"
+  DayName 1 -> "Monday"
+  DayName 2 -> "Tuesday"
+  DayName 3 -> "Wednesday"
+  DayName 4 -> "Thursday"
+  DayName 5 -> "Friday"
+  DayName 6 -> "Saturday"
+  DayName 7 -> "Sunday"
+  DayName _ -> ""
+
+esLocale :: TimeLocale
+esLocale =
+  defaultTimeLocale
+    { wDays =
+        [ ("Domingo", "Dom"),
+          ("Lunes", "Lun"),
+          ("Martes", "Mar"),
+          ("Miércoles", "Mié"),
+          ("Jueves", "Jue"),
+          ("Viernes", "Vie"),
+          ("Sábado", "Sáb")
+        ],
+      months =
+        [ ("Enero", "Ene"),
+          ("Febrero", "Feb"),
+          ("Marzo", "Mar"),
+          ("Abril", "Abr"),
+          ("Mayo", "May"),
+          ("Junio", "Jun"),
+          ("Julio", "Jul"),
+          ("Agosto", "Ago"),
+          ("Septiembre", "Sep"),
+          ("Octubre", "Oct"),
+          ("Noviembre", "Nov"),
+          ("Diciembre", "Dic")
+        ]
+    }
+
+getLocale :: Lang -> TimeLocale
+getLocale ES = esLocale
+getLocale EN = defaultTimeLocale