diff options
| -rw-r--r-- | pages/calendar-day.mustache | 2 | ||||
| -rw-r--r-- | pages/log.mustache | 2 | ||||
| -rw-r--r-- | src/Main.hs | 28 | ||||
| -rw-r--r-- | tirclogv.cabal | 1 |
4 files changed, 30 insertions, 3 deletions
diff --git a/pages/calendar-day.mustache b/pages/calendar-day.mustache index a01113a..2782daa 100644 --- a/pages/calendar-day.mustache +++ b/pages/calendar-day.mustache @@ -20,7 +20,7 @@ {{#events}} <tr{{#classlist}} class="{{.}}"{{/classlist}}> <td><a href="/cal/{{alias}}/{{date}}?eid={{linkid}}#ev-{{linkid}}" name="ev-{{linkid}}">{{time}}</a></td> - <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}{{nick}}{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td> + <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}<span style="color:{{nickcolor}}">{{nick}}</span>{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td> <td>{{message}}</td> </tr> {{/events}} diff --git a/pages/log.mustache b/pages/log.mustache index 20b2fa2..b0b7e17 100644 --- a/pages/log.mustache +++ b/pages/log.mustache @@ -50,7 +50,7 @@ {{#events}} <tr{{#classlist}} class="{{.}}"{{/classlist}}> <td><a href="/log/{{alias}}?eid={{linkid}}#ev-{{linkid}}" name="ev-{{linkid}}">{{datetime}}</a></td> - <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}{{nick}}{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td> + <td>{{#nickwrap1}}<span class="nickwrap">{{nickwrap1}}</span>{{/nickwrap1}}<span style="color:{{nickcolor}}">{{nick}}</span>{{#nickwrap2}}<span class="nickwrap">{{nickwrap2}}</span>{{/nickwrap2}}</td> <td>{{message}}</td> </tr> {{/events}} diff --git a/src/Main.hs b/src/Main.hs index cc4ad7e..d315492 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,11 +6,12 @@ module Main (main) where import Control.Exception (mask_) import Control.Monad (when, forM, guard) +import Data.Bits (xor, shiftR, (.&.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as BSL -import Data.Char (isDigit, ord) +import Data.Char (isDigit, chr, ord) import Data.Function (on, (&)) import Data.IORef import Data.List.NonEmpty (NonEmpty((:|)), groupBy) @@ -21,6 +22,9 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.IO.Utf8 qualified as T import Data.Time (Day, toGregorian, fromGregorianValid) +import Data.Word +import Graphics.Color.Space +import Graphics.Color.Space.OKLAB.LCH import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (runSettings, defaultSettings, setFork, setPort) @@ -120,6 +124,7 @@ pageLog conf pages index req alias = ,"nickwrap1" ~> nickw1 ,"nick" ~> nick ,"nickwrap2" ~> nickw2 + ,"nickcolor" ~> nickColor nick ,"message" ~> msg] | ((time, eid, ev), dayidx) <- zip events [0..] , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] @@ -163,6 +168,7 @@ pageCalendarDay conf pages index req alias datestr = ,"nickwrap1" ~> nickw1 ,"nick" ~> nick ,"nickwrap2" ~> nickw2 + ,"nickcolor" ~> nickColor nick ,"message" ~> msg] | ((time, eid, ev), dayidx) <- zip events [0..] , let (classlist, (nickw1, nick, nickw2), msg) = renderEvent ev]] @@ -207,6 +213,26 @@ renderEvent = \case ParseError -> (j "ev-parseerror", (no, "", no), "<parse error>") where no = Nothing; j = Just +-- | Returns a CSS color string, including the @#@ +nickColor :: Text -> Text +nickColor nick = + let -- mix (just some random odd constants) + n1 = T.foldl' (\n c -> 0x678731a3 * (fromIntegral (ord c) `xor` n) + 0xbc3c0a93) 0xbb115003 nick :: Word32 + -- scramble (two steps from splitmix32) + n2 = let z1 = (n1 `xor` (n1 `shiftR` 16)) * 0x85ebca6b + in (z1 `xor` (z1 `shiftR` 13)) * 0xc2b2ae35 + in T.pack $ "hsl(" ++ show (floor @Double @Int (fromIntegral n2 / 2**32 * 360)) ++ " 60% 70%)" + -- -- construct the OKLCH color + -- clr1 = ColorOKLCH @Double 0.8256 0.0859 (fromIntegral n2 / 2**32 * 360) + -- -- convert to sRGB + -- ColorRGB r g b = convertColor @(SRGB NonLinear) clr1 + -- -- render as css color + -- toHex val = let byte = floor (max 0 (min 1 val) * 255.99) + -- toHexDig v | v < 10 = chr (ord '0' + v) + -- | otherwise = chr (ord 'a' + v - 10) + -- in [toHexDig (byte `shiftR` 4), toHexDig (byte .&. 15)] + -- in T.pack $ '#' : toHex r ++ toHex g ++ toHex b + pageCalendar :: Config -> Pages -> Index -> Text -> IO Response pageCalendar conf pages index alias = case econfAlias2Chan conf Map.!? alias of diff --git a/tirclogv.cabal b/tirclogv.cabal index 10a6939..2746bf7 100644 --- a/tirclogv.cabal +++ b/tirclogv.cabal @@ -24,6 +24,7 @@ executable tirclogv attoparsec, bytestring, clock, + Color >= 0.4.1, containers, directory, filepath, |