fix flake, add translation, add args
This commit is contained in:
parent
2804c90aba
commit
e382150986
5 changed files with 250 additions and 60 deletions
85
app/Main.hs
85
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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
123
src/Translation.hs
Normal file
123
src/Translation.hs
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue