update badges

zfoh · Jun 7, 2024 · ad2301f · ad2301f
1 parent c3ea8fe
commit ad2301f
Show file tree

Hide file tree

Showing 2 changed files with 65 additions and 43 deletions.
diff --git a/lib/Zureg/Main/Badges.hs b/lib/Zureg/Main/Badges.hs
@@ -2,52 +2,76 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Zureg.Main.Badges
-    ( Badge
-    , previewBadge
+    ( Badge (..)
     , registrantToBadge
-
     , main
     ) where
 
-import           Control.Monad        (guard)
-import qualified Data.Aeson           as A
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Csv             as Csv
-import           Data.Maybe           (maybeToList)
-import           Data.Maybe           (fromMaybe, mapMaybe)
-import qualified Data.Text            as T
-import           System.Environment   (getArgs, getProgName)
-import           System.Exit          (exitFailure)
-import qualified System.IO            as IO
-import           Zureg.Hackathon      (Hackathon)
+import qualified Data.Aeson                      as A
+import           Data.Foldable                   (for_)
+import           Data.Maybe                      (mapMaybe)
+import qualified Data.Text                       as T
+import           System.Environment              (getArgs, getProgName)
+import           System.Exit                     (exitFailure)
+import qualified System.IO                       as IO
+import qualified Text.Blaze.Html.Renderer.Pretty as H
+import qualified Text.Blaze.Html5                as H
+import qualified Text.Blaze.Html5.Attributes     as HA
+import           Zureg.Hackathon                 (Hackathon)
 import           Zureg.Model
 
-data Badge = Badge
-    { bLine1 :: T.Text
-    , bLine2 :: Maybe T.Text
-    }
-
-previewBadge :: Badge -> T.Text
-previewBadge Badge {..} = T.intercalate ", " $
-    [bLine1] ++ maybeToList bLine2
+newtype Badge = Badge String
 
-badgeCsvHeader :: Csv.Header
-badgeCsvHeader = Csv.header ["Line 1", "Line 2", "Line 3"]
+registrantToBadge :: Registrant a -> Maybe Badge
+registrantToBadge r
+    | rState r `elem` map Just [Confirmed, Registered] =
+        Badge . T.unpack . riName <$> rInfo r
+    | otherwise = Nothing
 
-instance Csv.ToNamedRecord Badge where
-    toNamedRecord Badge {..} = Csv.namedRecord
-        [ "Line 1" Csv..= bLine1
-        , "Line 2" Csv..= bLine2
-        ]
+renderBadges :: [Badge] -> H.Html
+renderBadges badges = H.docTypeHtml $ do
+    H.head $ do
+        H.style H.! HA.type_ "text/css" H.! HA.media "print" $ do
+            "@page {"
+            "    size: auto;"
+            "    margin: 0mm;"
+            "}"
+        H.style H.! HA.type_ "text/css" $ do
+            ":root {"
+            "    --badge-width: 70mm;"
+            "    --badge-height: 42.4mm;"
+            "    --badge-margin-side: 0.5cm;"
+            "}"
+            "body {"
+            "    font-size: 0.5cm;"
+            "    font-family: sans;"
+            "    font-stretch: condensed;"
+            "    font-weight: bold;"
+            "    margin: 0px;"
+            "    padding: 0px;"
+            "}"
+            ".page {"
+            "    page-break-after: always;"
+            "    display: flex;"
+            "    flex-wrap: wrap;"
+            "}"
+            ".badge {"
+            "    width: calc(var(--badge-width) - 2 * var(--badge-margin-side));"
+            "    height: var(--badge-height);"
+            "    padding-left: var(--badge-margin-side);"
+            "    padding-right: var(--badge-margin-side);"
+            "    text-align: center;"
+            "}"
+    H.body $ do
+        for_ (pages 21 badges) $ \page -> H.div H.! HA.class_ "page" $ do
+            for_ page $ \(Badge badge) -> H.div H.! HA.class_ "badge" $ do
+                H.toHtml badge
 
-registrantToBadge :: Registrant a -> Maybe Badge
-registrantToBadge Registrant {..} = do
-    state <- rState
-    guard $ state `elem` [Confirmed, Registered]
-    RegisterInfo {..} <- rInfo
-    let bLine1 = fromMaybe riName riBadgeName
-        bLine2 = riAffiliation
-    pure Badge {..}
+pages :: Int -> [a] -> [[a]]
+pages n ls = case splitAt n ls of
+    ([],   _)  -> []
+    (page, []) -> [page]
+    (page, t)  -> page : pages n t
 
 main :: forall a. A.FromJSON a => Hackathon a -> IO ()
 main _ = do
@@ -59,10 +83,8 @@ main _ = do
             registrantsOrError <- A.eitherDecodeFileStrict exportPath
             registrants <- either (fail . show) return registrantsOrError
                 :: IO [Registrant a]
-
-            BL.putStr $ Csv.encodeByName badgeCsvHeader $
+            putStrLn $ H.renderHtml $ renderBadges $
                 mapMaybe registrantToBadge registrants
-
         _ -> do
             IO.hPutStr IO.stderr $ unlines
                 [ "Usage: " ++ progName ++ " export.json"

diff --git a/lib/Zureg/Views.hs b/lib/Zureg/Views.hs
@@ -33,7 +33,7 @@ import qualified Zureg.Captcha               as Captcha
 import qualified Zureg.Form                  as Form
 import qualified Zureg.Hackathon             as Hackathon
 import           Zureg.Hackathon             (Hackathon)
-import           Zureg.Main.Badges           (previewBadge, registrantToBadge)
+import           Zureg.Main.Badges           (Badge (..), registrantToBadge)
 import           Zureg.Model
 
 template :: H.Html -> H.Html -> H.Html
@@ -238,8 +238,8 @@ scan hackathon registrant@Registrant {..} = H.ul $ do
 
     H.li $ case (registrantRegisteredAt registrant, registrantToBadge registrant) of
         (_, Nothing)                        -> red "No Badge"
-        (_, Just badge)                     ->
-            "Badge: " <> H.strong (H.toHtml $ previewBadge badge)
+        (_, Just (Badge badge))             ->
+            "Badge: " <> H.strong (H.toHtml badge)
 
     H.li $ Hackathon.scanView hackathon registrant
   where