diff --git a/app/Main.hs b/app/Main.hs index 07f9028..93fc795 100644 --- a/app/Main.hs +++ b/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 = - scotty - 3456 - ( do +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 @@ -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 - ) diff --git a/chipburners-club.cabal b/chipburners-club.cabal index 9e3a036..4127445 100644 --- a/chipburners-club.cabal +++ b/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 diff --git a/flake.nix b/flake.nix index 2029728..de4743b 100644 --- a/flake.nix +++ b/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 { - buildInputs = with pkgs; [ - ghc + devShells.default = hpkgs.shellFor { + packages = p: [ haskellApp ]; + nativeBuildInputs = with pkgs; [ cabal-install haskell-language-server zlib diff --git a/src/Render.hs b/src/Render.hs index 7c50385..30a02f9 100644 --- a/src/Render.hs +++ b/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 = do +renderHead :: Lang -> Html () +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 active = +renderHeader :: Lang -> Int -> Html () +renderHeader lang active = header_ [class_ "site-header"] $ do nav_ [] $ do ul_ [class_ "nav-list"] $ do - li_ $ a_ [href_ "/", getActive 0] "Chip" - li_ $ a_ [href_ "/monthView", getActive 1] "Eventos" - li_ $ a_ [href_ "/wiki", getActive 2] "Wiki" - li_ $ a_ [href_ "/contact", getActive 3] "Contacto" + li_ $ a_ [href_ "/", getActive 0] (toHtml $ tr lang NavChip) + li_ $ a_ [href_ "/monthView", getActive 1] (toHtml $ tr lang NavEvents) + li_ $ a_ [href_ "/wiki", getActive 2] (toHtml $ tr lang NavWiki) + 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 (day, events) = +renderDayGroup :: Lang -> (Day, [Event]) -> Html () +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 () -renderFrontpage events = do - renderHead +trh :: Lang -> Msg -> Html () +trh lang m = toHtml $ tr lang m + +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 \ - \las technologias relacionadas. " + trh lang HomeP1 br_ [] - "Este hackerspace ha sido creado como manera d juntar gente con intereses \ - \similares y compartir conocimientos. " + trh lang HomeP2 br_ [] - "Contactanos en " - a_ [href_ "/contact"] "signal" + trh lang HomePContact + 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" - renderEventList events + h2_ $ trh lang NavEvents + 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 e = do +renderCalendarEvent :: Lang -> Event -> Html () +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 (year, month) today groupedEvents = do +renderMonthview :: Lang -> (Year, MonthOfYear) -> Day -> [(Day, [Event])] -> Html () +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" - th_ "Martes" - th_ "Miercoles" - th_ "Jueves" - th_ "Viernes" - th_ "Sabado" - th_ "Domingo" - + forM_ [1 .. 7] $ \i -> + th_ (trh lang (DayName i)) 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 diff --git a/src/Translation.hs b/src/Translation.hs new file mode 100644 index 0000000..fcff4f8 --- /dev/null +++ b/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