#!/usr/bin/env stack > -- stack script --resolver lts-22.6 --package sqlite-simple --package text --package time --package bytestring bujo.lhs: a bullet journal over gopher ====================================== A dead-simple bullet journal that lives entirely in gopherspace. No app, no account, no loading screen --- a gopher client (or `nc`, or `curl`) is the whole client. The design target is the lowest possible threshold to use: every action is either a single click (navigating to a selector that mutates state and re-renders) or a single typed line (the type-7 "add a task" box). Nothing takes more than a second. (This file is markdown-flavoured literate Haskell. Headings use setext underlines rather than ATX-style `#` because GHC's literate parser reads a `#` at column 1 of a non-code line as a pragma.) The model --------- One running list per calendar month, grouped by the day each task was filed. Two verbs day to day: *add* (type one line) and *toggle done* (click the task). At month's end the journal greets you with a *migration* ritual --- review what is still open and pick what to carry forward; whatever you don't carry settles into the *archive*, where it stays viewable and can be pulled back. On top of that: a star/focus view, a monthly habit tracker, a stats dashboard, and a whole-journal text export. Task bullets, in a fixed bracket column so the list reads like a checklist: `[ ]` open, `[x]` done, `[>]` carried forward. Settled (left-behind) and note rows render plainly in the archive. Ownership without accounts -------------------------- A journal is keyed by a 32-hex-digit secret minted from `/dev/urandom` on first use. The whole journal lives under `$SCRIPT/k//...`; you bookmark that once and it is one click back in forever. Anyone holding the link can read and edit --- it is a bearer capability, not a login --- so the bookmark page says so plainly. URL design ---------- `$SCRIPT` is whatever routes.toml mounts this file at; the script derives it from `$selector - $pathinfo`, so the mount point is free to move. $SCRIPT front door (explainer + create link) $SCRIPT/new mint a key, show the bookmark page $SCRIPT/k/ the journal (normal OR migration view) $SCRIPT/k//add + query file a task under today $SCRIPT/k//done/ mark a task done (append /s to return to the starred view) $SCRIPT/k//open/ re-open a task (likewise /s) $SCRIPT/k//mig/ check a task to carry forward (migration) $SCRIPT/k//unmig/ uncheck it $SCRIPT/k//start finish migration: carry checked, settle rest $SCRIPT/k//restore/ pull a settled task back from the archive $SCRIPT/k//focus prioritise: click stars/unstars $SCRIPT/k//starred do-list: only starred, click checks off $SCRIPT/k//star/ star a task (mark important) $SCRIPT/k//unstar/ unstar a task $SCRIPT/k//txt whole journal as one text page $SCRIPT/k//diary your notes, set as a keepsake diary (text) $SCRIPT/k//stats dashboard: streaks, averages, insights $SCRIPT/k//habits habit grid; tap a row to toggle today $SCRIPT/k//habits/add + query: add a habit $SCRIPT/k//hcheck/ tick today (huncheck/ to untick) $SCRIPT/k//habits/manage archive / restore habits $SCRIPT/k//delete select tasks, then soft-delete them $SCRIPT/k//untrash/ restore a soft-deleted task $SCRIPT/k//archive list past months $SCRIPT/k//archive/ one past month, frozen and read-only A note on mutation via navigation: gopher has no POST, so clicks mutate. Every mutating selector *names the state it moves to* --- `done`, `open`, `star`, `unstar`, `mig`, `unmig`, `restore` --- rather than toggling, so a client refresh or a crawler re-fetch is idempotent and lands on the same result; `start` (finish migration) acts only on still-open tasks, so a repeat is a no-op too. Each also requires a valid key a crawler will not possess, and `/new` (the only keyless mutator) just creates an empty journal. This matches house norms --- diggings already mutates on navigation. Running the doctests -------------------- doctest-lhs bujo.lhs reuses this file's own `-- stack` directive and language pragmas. Module header and imports ------------------------- > {-# LANGUAGE OverloadedStrings #-} > module Main (main) where > > import Control.Exception (SomeException, try) > import Control.Monad (forM, forM_, when) > import qualified Data.ByteString as BS > import Data.Char (chr, digitToInt, intToDigit, isDigit, > isHexDigit, ord) > import Data.Function (on) > import Data.List (group, groupBy, intercalate, intersperse, sort, sortOn) > import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) > import qualified Data.Text as T > import qualified Data.Text.Encoding as TE > import Data.Text.Encoding.Error (lenientDecode) > import qualified Data.Text.IO as TIO > import Data.Time.Calendar (Day, addDays, gregorianMonthLength, > toModifiedJulianDay) > import Data.Time.Calendar.WeekDate (toWeekDate) > import Data.Time.Format (defaultTimeLocale, formatTime, > parseTimeM) > import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, > utcTimeToPOSIXSeconds) > import Data.Time.LocalTime (LocalTime(..), TimeZone, getCurrentTimeZone, > getZonedTime, localDay, localTimeToUTC, > midnight, timeZoneMinutes, utc, > utcToLocalTime) > import Database.SQLite.Simple > import System.Environment (getArgs, lookupEnv) > import System.IO (BufferMode (..), IOMode (..), hClose, > hSetBuffering, hSetEncoding, > openBinaryFile, stdout, utf8) > import Text.Read (readMaybe) Configuration ------------- Host/port are overridable via `GOPHER_HOST` / `GOPHER_PORT` so the same script runs on staging and production unedited; the DB path via `BUJO_DB`. The hidden default lands beside the script, so the directory must be group-writable (setgid) for the daemon to create `.bujo.db` and its `-wal`/`-shm` sidecars. > defaultHost, defaultPort :: T.Text > defaultHost = "gopher.someodd.zip" > defaultPort = "70" > > -- | Absolute by default so the store can never be orphaned if the > -- daemon's working directory ever changes (a relative ".bujo.db" > -- would then create a fresh empty DB elsewhere and every journal > -- would appear to vanish). Override with BUJO_DB. > defaultDb :: FilePath > defaultDb = "/var/gopher/applets/bujo/.bujo.db" > > bodyMax :: Int > bodyMax = 200 -- a task body is clamped to this on the way in > > -- | How many soft-deleted rows stay restorable. The trash is a > -- bounded undo buffer: anything beyond the most-recently-deleted > -- 'trashKeep' is hard-purged (it could never be restored anyway), > -- so the table never fills with un-restorable rows. The recycle bin > -- shows the live count against this cap (e.g. 7/30). > trashKeep :: Int > trashKeep = 30 Pure helpers ------------ The spine of the script is pure and doctested: state-to-bullet rendering, lexical month arithmetic, key validation, and the date-label formatters. Bullet-journal months sort correctly as `YYYY-MM` strings, so "is it a new month?" is just a string compare. > tshow :: Show a => a -> T.Text > tshow = T.pack . show > > -- | Count with a naively-pluralised noun. > -- > -- >>> map (`plural` "month") [1, 3] > -- ["1 month","3 months"] > plural :: Int -> T.Text -> T.Text > plural n word = tshow n <> " " <> word <> if n == 1 then "" else "s" > > -- | The @YYYY-MM@ month a @YYYY-MM-DD@ day belongs to. > -- > -- >>> monthOf "2026-05-22" > -- "2026-05" > monthOf :: T.Text -> T.Text > monthOf = T.take 7 > > -- | True when the real month is ahead of the journal's active month. > -- > -- >>> needsMigration "2026-04" "2026-05" > -- True > -- > -- >>> needsMigration "2026-05" "2026-05" > -- False > -- > -- >>> needsMigration "2025-12" "2026-01" > -- True > needsMigration :: T.Text -> T.Text -> Bool > needsMigration active real = real > active > > -- | The bracket bullet for a task state. A note's dash sits in the > -- same four-column width, centered where the checkbox would be, so > -- with the leading marker space it renders as @ - text@ and lines > -- up with @ [ ] text@. > -- > -- >>> map bullet ["open","done","migrated","dropped","note"] > -- ["[ ] ","[x] ","[>] ","[~] "," - "] > bullet :: T.Text -> T.Text > bullet "done" = "[x] " > bullet "migrated" = "[>] " > bullet "dropped" = "[~] " > bullet "note" = " - " > bullet _ = "[ ] " > > -- | A row's leading marker (ASCII): @*@ for an important open task, > -- else a space. Used for archive/export rows (plain text, no trim). > -- The live journal uses a non-breaking-space variant instead (see > -- 'normalView') because some clients trim ASCII whitespace off > -- clickable menu lines. > -- > -- >>> map (uncurry mark) [(1,"open"),(0,"open"),(1,"done")] > -- ["*"," "," "] > mark :: Int -> T.Text -> T.Text > mark imp st = if imp == 1 && st == "open" then "*" else " " > > -- | The state a click moves an open/done task TO --- the idempotent > -- toggle target. Naming the destination (not "flip") is what makes > -- the done/open selectors safe to refetch. > -- > -- >>> map nextState ["open","done"] > -- ["done","open"] > nextState :: T.Text -> T.Text > nextState "done" = "open" > nextState _ = "done" > > -- | Read the add-box leading signifier into @(state, important, body)@. > -- A bare line is an open task; @*@ stars it (the same mark it shows > -- with); @-@ files it as a note. The signifier is stripped from the > -- stored body. > -- > -- >>> classify "buy milk" > -- ("open",0,"buy milk") > -- > -- >>> classify "* finish taxes" > -- ("open",1,"finish taxes") > -- > -- >>> classify "- had a good call" > -- ("note",0,"had a good call") > -- > -- >>> classify "" > -- ("open",0,"") > -- > -- >>> classify "*" > -- ("open",1,"") > -- > -- >>> classify "- " > -- ("note",0,"") > classify :: T.Text -> (T.Text, Int, T.Text) > classify raw = case T.uncons (T.stripStart raw) of > Just ('*', rest) -> ("open", 1, T.stripStart rest) > Just ('-', rest) -> ("note", 0, T.stripStart rest) > _ -> ("open", 0, T.stripStart raw) > > -- | A "(carried Nx)" nudge, shown only once a task has been carried > -- forward at least twice --- the classic sign a task is not real. > -- > -- >>> carryNote 1 > -- "" > -- > -- >>> carryNote 3 > -- " (carried 3x)" > carryNote :: Int -> T.Text > carryNote n > | n >= 2 = " (carried " <> tshow n <> "x)" > | otherwise = "" > > -- | Clamp a display string to @n@ characters with an ellipsis. > -- > -- >>> clamp 5 "hello world" > -- "he..." > -- > -- >>> clamp 5 "hi" > -- "hi" > clamp :: Int -> T.Text -> T.Text > clamp n t > | T.length t <= n = t > | otherwise = T.take (max 0 (n - 3)) t <> "..." > > -- | A journal key is exactly 32 lowercase-hex digits. > -- > -- >>> validKey "0123456789abcdef0123456789abcdef" > -- True > -- > -- >>> validKey "short" > -- False > validKey :: T.Text -> Bool > validKey k = T.length k == 32 && T.all isHexDigit k > > -- | A @YYYY-MM@ archive segment, validated before it reaches SQL. > -- > -- >>> validMonth "2026-05" > -- True > -- > -- >>> validMonth "2026-5" > -- False > validMonth :: T.Text -> Bool > validMonth m = case T.splitOn "-" m of > [y, mo] -> T.length y == 4 && T.length mo == 2 > && T.all isDigit y && T.all isDigit mo > _ -> False > > -- | A task id from a path segment; non-numeric or negative is rejected. > -- > -- >>> readId "42" > -- Just 42 > -- > -- >>> readId "x" > -- Nothing > readId :: T.Text -> Maybe Int > readId t = case readMaybe (T.unpack t) of > Just n | n >= 0 -> Just n > _ -> Nothing > > -- | Lowercase-hex-encode a 'BS.ByteString'. > -- > -- >>> hexEncode (BS.pack [0, 15, 255]) > -- "000fff" > hexEncode :: BS.ByteString -> T.Text > hexEncode = T.pack . concatMap byte . BS.unpack > where > digits = "0123456789abcdef" > byte w = [ digits !! fromIntegral (w `div` 16) > , digits !! fromIntegral (w `mod` 16) ] > > -- | A day header label, e.g. "fri, may 22". Falls back to the raw > -- string if it does not parse. > -- > -- >>> dayLabel "2026-05-22" > -- "fri, may 22" > dayLabel :: T.Text -> T.Text > dayLabel d = case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack d) :: Maybe Day of > Just day -> T.toLower (T.pack (formatTime defaultTimeLocale "%a, %b %-d" day)) > Nothing -> d > > -- | A month label, e.g. "may 2026". Falls back to the raw string. > -- > -- >>> monthLabel "2026-05" > -- "may 2026" > monthLabel :: T.Text -> T.Text > monthLabel m = case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack m ++ "-01") :: Maybe Day of > Just day -> T.toLower (T.pack (formatTime defaultTimeLocale "%B %Y" day)) > Nothing -> m The stats arithmetic -------------------- The `/stats` view is a pure projection of the task table --- read-only, so it adds no daily friction and can never lose data. These are the doctested pure pieces (percentages, bars, averages, date math, and the forgiving streak); the IO half just counts rows and gathers dates. > -- | Safe integer percentage; 0 when the denominator is 0. > -- > -- >>> map (uncurry pct) [(3,4),(0,0),(1,3)] > -- [75,0,33] > pct :: Int -> Int -> Int > pct _ 0 = 0 > pct n d = (n * 100) `div` d > > -- | A @w@-cell '#'/'.' bar from @v@ out of @m@; empty when max is 0. > -- > -- >>> barW 20 3 4 > -- "###############....." > barW :: Int -> Int -> Int -> T.Text > barW w v m = T.replicate filled "#" <> T.replicate (w - filled) "." > where filled = if m <= 0 then 0 else min w ((v * w) `div` m) > > -- | The inline 10-cell bar used by the vitals rows. > -- > -- >>> bar 72 100 > -- "#######..." > -- > -- >>> bar 0 0 > -- ".........." > bar :: Int -> Int -> T.Text > bar = barW 10 > > -- | A modest ASCII checkmark for "goal reached." Avoids unicode in the > -- gopher feed so older clients render it the same. Six bytes vs one > -- pictograph, but reliable everywhere. > checkmark :: T.Text > checkmark = "(done)" > > -- | Greedy word-wrap to a column width (long single words overflow > -- their own line); always at least one (possibly empty) line. > -- > -- >>> wrapTo 10 "the quick brown fox" > -- ["the quick","brown fox"] > -- > -- >>> wrapTo 10 "" > -- [""] > wrapTo :: Int -> T.Text -> [T.Text] > wrapTo width t = finish (foldl step ("", []) (T.words t)) > where > step (cur, acc) w > | T.null cur = (w, acc) > | T.length cur + 1 + T.length w <= width = (cur <> " " <> w, acc) > | otherwise = (w, acc ++ [cur]) > finish (cur, acc) = acc ++ [cur] > > -- | Round @n\/d@ to one decimal place as text; "0.0" when d is 0. > -- > -- >>> map (uncurry avg1) [(32,10),(7,3),(0,0)] > -- ["3.2","2.3","0.0"] > avg1 :: Int -> Int -> T.Text > avg1 _ 0 = "0.0" > avg1 n d = tshow (t `div` 10) <> "." <> tshow (t `mod` 10) > where t = (n * 10 + d `div` 2) `div` d > > -- | A @YYYY-MM-DD@ day as its modified-Julian ordinal (so consecutive > -- calendar days differ by exactly 1). > dayNum :: T.Text -> Maybe Integer > dayNum t = toModifiedJulianDay <$> > (parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack t) :: Maybe Day) > > -- | The date @n@ days from a @YYYY-MM-DD@ date (negative = earlier); > -- the input unchanged if it does not parse. > -- > -- >>> shiftDay (-6) "2026-05-22" > -- "2026-05-16" > shiftDay :: Int -> T.Text -> T.Text > shiftDay n t = case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack t) :: Maybe Day of > Just d -> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" (addDays (fromIntegral n) d)) > Nothing -> t > > -- | Whole days from date @a@ to date @b@ (b - a); 0 if either fails. > -- > -- >>> daysBetween "2026-05-10" "2026-05-22" > -- 12 > daysBetween :: T.Text -> T.Text -> Int > daysBetween a b = case (dayNum a, dayNum b) of > (Just x, Just y) -> fromIntegral (y - x) > _ -> 0 > > -- | Longest run of consecutive days in a set of day ordinals --- the > -- "best ever" streak, a record that never decreases. > -- > -- >>> longestStreak [10,9,8,6,5] > -- 3 > -- > -- >>> longestStreak [] > -- 0 > longestStreak :: [Integer] -> Int > longestStreak = thrd . foldl step (Nothing, 0, 0) . map head . group . sort > where > step (prev, cur, best) d = > let cur' = case prev of Just p | d == p + 1 -> cur + 1 > _ -> 1 > in (Just d, cur', max best cur') > thrd (_, _, b) = b > > -- | Forgiving current streak ending today (or yesterday, so it does > -- not read 0 before you have logged today) plus grace days spent. You > -- may skip about one day per week without breaking it: a gap costs a > -- grace if fewer than @streak \/ 7 + 1@ have been used, else the run > -- ends. > -- > -- >>> currentStreak 10 [10,9,8,7] > -- (4,0) > -- > -- >>> currentStreak 10 [10,8,6,4] > -- (2,1) > -- > -- >>> currentStreak 10 [7,6,5] > -- (0,0) > currentStreak :: Integer -> [Integer] -> (Int, Int) > currentStreak today active > | null active = (0, 0) > | today `elem` active = walk today 0 0 > | (today - 1) `elem` active = walk (today - 1) 0 0 > | otherwise = (0, 0) > where > lo = minimum active > walk d streak grace > | d < lo = (streak, grace) > | d `elem` active = walk (d - 1) (streak + 1) grace > | grace < streak `div` 7 + 1 = walk (d - 1) streak (grace + 1) > | otherwise = (streak, grace) The habit grid -------------- The `/habits` grid is a pure projection too: how many day-columns the current month has, the two stacked header rows that number them, and a habit's row of done/not cells with today's tappable column called out. > -- | Days in a @YYYY-MM@ month (leap-aware); 31 if it does not parse. > -- > -- >>> map daysInMonth ["2026-02","2024-02","2026-04","2026-05"] > -- [28,29,30,31] > daysInMonth :: T.Text -> Int > daysInMonth m = case T.splitOn "-" m of > (y:mo:_) | Just yy <- readMaybe (T.unpack y) > , Just mm <- readMaybe (T.unpack mo) -> gregorianMonthLength yy mm > _ -> 31 > > -- | ISO weekday (1=Mon..7=Sun) of day @d@ given the month's first > -- day's weekday. > dowOf :: Int -> Int -> Int > dowOf fdow d = (fdow - 1 + d - 1) `mod` 7 + 1 > > -- | A blank spacer column is inserted before each Monday (but not the > -- very first day), so weeks read as separate blocks. > sepBefore :: Int -> Int -> Bool > sepBefore fdow d = d > 1 && dowOf fdow d == 1 > > -- | The tens and units header strings numbering @n@ day-columns, with > -- the week separators woven in (given the first day's weekday). > -- > -- >>> snd (gridHead 7 9) > -- "1 2345678 9" > gridHead :: Int -> Int -> (T.Text, T.Text) > gridHead fdow n = (row tens, row units) > where > tens d = if d < 10 then ' ' else head (show (d `div` 10)) > units d = head (show (d `mod` 10)) > row f = T.concat [ (if sepBefore fdow d then " " else "") <> T.singleton (f d) | d <- [1 .. n] ] > > -- | A habit's cell row. @fdow@ = the month's first weekday, @n@ days, > -- the weekly @target@, today's day-of-month (0 = a historical month, > -- no \"today\"), and the done day-of-months. @X@ = done; @O@ = a > -- not-done day in a week whose target was *met* (earned rest, so an > -- on-target frequency week reads complete instead of sparse); @.@ = a > -- not-done day in a week that fell short (gentle, honest); @_@ = today > -- not yet done; a future day is blank. A blank spacer precedes each > -- Monday. (For a daily habit, target 7, a week is only \"met\" at 7/7, > -- which has no gaps --- so daily habits never show @O@.) > -- > -- >>> cells 1 7 4 0 [1,2,3,4] > -- "XXXXOOO" > -- > -- >>> cells 1 7 4 0 [1,3,5,7] > -- "XOXOXOX" > -- > -- >>> cells 1 7 4 0 [1,2] > -- "XX....." > -- > -- >>> cells 1 7 7 0 [1,2,3,4,5] > -- "XXXXX.." > -- > -- >>> cells 1 14 4 0 [1,2,3,4,8,9] > -- "XXXXOOO XX....." > cells :: Int -> Int -> Int -> Int -> [Int] -> T.Text > cells fdow n target today done = T.concat [ sep d <> T.singleton (glyph d) | d <- [1 .. n] ] > where > sep d = if sepBefore fdow d then " " else "" > -- count this week's completions (its Monday through Sunday) > weekMet d = let ws = d - (dowOf fdow d - 1) > in target <= length [ x | x <- done, x >= ws, x <= ws + 6 ] > glyph d > | d `elem` done = 'X' -- done > | today > 0 && d > today = ' ' -- future > | today > 0 && d == today = '_' -- today, not yet done > | weekMet d = 'O' -- earned rest (week's goal met) > | otherwise = '.' -- missed (week fell short) > > -- | Day-of-month from a @YYYY-MM-DD@ string; 0 if it does not parse. > -- > -- >>> domOf "2026-05-22" > -- 22 > domOf :: T.Text -> Int > domOf = fromMaybe 0 . readMaybe . T.unpack . T.drop 8 > > -- | ISO weekday (1=Mon..7=Sun) of the first day of a @YYYY-MM@ month. > -- > -- >>> firstDow "2026-05" > -- 5 > firstDow :: T.Text -> Int > firstDow m = case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack m ++ "-01") :: Maybe Day of > Just d -> let (_, _, dow) = toWeekDate d in dow > Nothing -> 1 > > -- | ISO weekday (1=Mon..7=Sun) of a @YYYY-MM-DD@ date. > -- > -- >>> weekdayOf "2026-05-22" > -- 5 > weekdayOf :: T.Text -> Int > weekdayOf t = case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack t) :: Maybe Day of > Just d -> let (_, _, dow) = toWeekDate d in dow > Nothing -> 1 > > -- | A completion rate (0--100) vs a weekly target over a window of > -- days: checks against expected = @target * windowDays \/ 7@, ROUNDED > -- to nearest (the @+3@) and capped. Rounding (not flooring) the > -- expectation is what stops a young frequency habit from reading 100% > -- off a single check: a @4|@ habit three days in expects > -- @round(4*3\/7) = 2@, so one check is 50%, not @floor = 1@ -> 100%. > -- The window stays age-sized (see 'rate30'), so a brand-new habit is > -- still judged against its own short life, never penalised for youth. > -- > -- >>> map (\(c,t,w) -> rateOf c t w) [(4,4,7),(2,4,7),(8,4,14),(7,7,7)] > -- [100,50,100,100] > -- > -- The frequency-habit fix (was the saturation bug): three days into a > -- 4x\/week habit, one check is half-way, not a full bar. > -- > -- >>> map (\(c,t,w) -> rateOf c t w) [(1,4,3),(2,4,3),(0,7,3),(16,4,30)] > -- [50,100,0,94] > rateOf :: Int -> Int -> Int -> Int > rateOf checks target windowDays = > min 100 (checks * 100 `div` max 1 ((target * windowDays + 3) `div` 7)) > > -- | Read an optional @N|@ weekly-target prefix off a habit name > -- (N in 1..7); default 7 (daily). The marker is stripped. > -- > -- >>> parseHabit "4|exercise" > -- (4,"exercise") > -- > -- >>> parseHabit "meditate" > -- (7,"meditate") > -- > -- >>> parseHabit "9|nope" > -- (7,"9|nope") > parseHabit :: T.Text -> (Int, T.Text) > parseHabit raw = case T.uncons (T.stripStart raw) of > Just (c, rest) | c >= '1' && c <= '7', Just ('|', nm) <- T.uncons rest > -> (read [c], T.strip nm) > _ -> (7, T.strip raw) The overall grade ----------------- A fair, never-shaming grade: scored relative to your own context and trajectory, not an absolute productivity bar, and deliberately volume-blind --- showing up and direction are 65% of it, so two meaningful things a day done consistently earns top marks and any slump is recoverable purely by showing up. New journals "warm up" first so they never get an unfair early letter, and a low grade always ships with the single highest-leverage next action. All pure, all doctested. > -- | Already-computed counts the grade rests on; separated from 'Stats' > -- so the grade math is pure and testable in isolation. > data GradeIn = GradeIn > { giDaysKept :: Int > , giActiveDays :: Int > , giActive14 :: Int > , giActive7 :: Int > , giActivePrev7 :: Int > , giDoneRecent :: Int > , giLingering :: Int > , giStale :: Int > , giHabits :: Int -- active habit count (0 = habits unused) > , giHabitScore :: Int -- 0--100 recent habit completion > } deriving (Eq, Show) > > data Grade > = Warming Int -- ^ days left until the grade unlocks > | Graded { gLetter :: T.Text, gScore :: Int, gTrend :: T.Text > , gStrong :: T.Text, gAction :: T.Text > , gGap :: Int, gNext :: T.Text } > deriving (Eq, Show) > > -- | The four component scores (0--100): consistency, trajectory, > -- follow-through, hygiene --- each generous and volume-blind. > -- > -- >>> components (GradeIn 30 20 10 5 5 8 2 0 0 0) > -- (100,70,80,100) > components :: GradeIn -> (Int, Int, Int, Int) > components g = (consistency, trajectory, follow, hygiene) > where > windowDays = min 14 (giDaysKept g) > target = max 1 ((windowDays + 1) `div` 2) > consistency = min 100 (giActive14 g * 100 `div` target) > trajectory > | giActive7 g > giActivePrev7 g = 100 > | giActive7 g == giActivePrev7 g = 70 > | otherwise = min 60 (70 * giActive7 g `div` max 1 (giActivePrev7 g)) > follow > | giDoneRecent g + giLingering g == 0 = 100 > | otherwise = pct (giDoneRecent g) (giDoneRecent g + giLingering g) > hygiene = max 0 (100 - 34 * giStale g) > > -- | Weighted 0--100 score. With no active habits the four task > -- components carry the whole grade (consistency + trajectory = 65%); > -- once you track habits they take a 20% slice and the rest scale down, > -- so non-users are entirely unaffected. > -- > -- >>> gradeScore (GradeIn 30 20 10 5 5 8 2 0 0 0) > -- 88 > -- > -- >>> gradeScore (GradeIn 30 20 10 5 5 8 2 0 2 50) > -- 80 > gradeScore :: GradeIn -> Int > gradeScore g > | giHabits g == 0 = (40 * c + 25 * t + 20 * f + 15 * h) `div` 100 > | otherwise = (32 * c + 20 * t + 16 * f + 12 * h + 20 * giHabitScore g) `div` 100 > where (c, t, f, h) = components g > > -- | Letter bands as (min score, letter), highest first. A generous > -- curve --- the components are already generous, so F is rare. > gradeBands :: [(Int, T.Text)] > gradeBands = > [ (90,"A"), (85,"A-"), (80,"B+"), (73,"B"), (67,"B-"), (60,"C+") > , (53,"C"), (46,"C-"), (39,"D+"), (32,"D"), (0,"F") ] > > -- | Score to letter. > -- > -- >>> map letterOf [95,86,74,55,33,10] > -- ["A","A-","B","C","D","F"] > letterOf :: Int -> T.Text > letterOf s = snd (head (dropWhile ((> s) . fst) gradeBands)) > > -- | Points to the next grade up and that grade's letter; (0,"") at A. > -- > -- >>> gapToNext 78 > -- (2,"B+") > -- > -- >>> gapToNext 95 > -- (0,"") > gapToNext :: Int -> (Int, T.Text) > gapToNext s = case takeWhile ((> s) . fst) gradeBands of > [] -> (0, "") > bs -> let (cut, lt) = last bs in (cut - s, lt) > > -- | A plain-English level to sit beside the letter grade, so the headline > -- reads as a state ("strong") not only a school grade. > -- > -- >>> map stateWord [90, 72, 58, 42, 20] > -- ["thriving","strong","steady","finding your feet","warming up"] > stateWord :: Int -> T.Text > stateWord s > | s >= 85 = "thriving" > | s >= 70 = "strong" > | s >= 55 = "steady" > | s >= 40 = "finding your feet" > | otherwise = "warming up" > > -- | The overall grade: warm-up for new journals, else a letter, trend > -- word, strongest area, and the single highest-leverage next action > -- with the band it would reach. > -- > -- >>> overallGrade (GradeIn 3 2 2 1 1 0 0 0 0 0) > -- Warming 4 > -- > -- >>> gLetter (overallGrade (GradeIn 30 20 10 5 5 8 2 0 0 0)) > -- "A-" > overallGrade :: GradeIn -> Grade > overallGrade g > | giDaysKept g < 7 || giActiveDays g < 3 = Warming (max 1 need) > | otherwise = Graded (letterOf score) score trend (label strongIx) > (action weakIx) gap next > where > need = max (7 - giDaysKept g) (3 - giActiveDays g) > (c, t, f, h) = components g > score = gradeScore g > (gap, next) = gapToNext score > -- habits join the strongest/weakest ranking only when in use > scored = [(c, 0), (t, 1), (f, 2), (h, 3)] > ++ [ (giHabitScore g, 4) | giHabits g > 0 ] :: [(Int, Int)] > strongIx = snd (maximum scored) > weakIx = snd (minimum scored) > trend | giActive7 g > giActivePrev7 g = "improving" > | giActive7 g == giActivePrev7 g = "steady" > | otherwise = "easing" > label 0 = "showing up" > label 1 = "momentum" > label 2 = "follow-through" > label 3 = "what matters" > label _ = "habits" > action 0 = "show up tomorrow" > action 1 = "edge past last week" > action 2 = "finish or migrate a carried task" > action 3 = "knock out a stale star" > action _ = "tick a habit today" The wire -------- Gophermap rows: every display field passes through `sanitize` so a value carrying a TAB or newline cannot smuggle extra fields onto the wire; every row ends `\r\n`; `putLine` flushes so output reaches the client even mid-crash. `page` writes a list of rows followed by the gophermap terminator. > putLine :: T.Text -> IO () > putLine t = TIO.putStr (t <> "\r\n") > > -- | Build the top-of-page headers. The last-action / refresh warning > -- ONLY shows when the current route is non-idempotent (creates, > -- counter tick/undo, migrate commits) --- the whole point of the > -- header is to keep a refresh from re-doing the action. Idempotent > -- routes (task done/star, habit check, timer start/done, etc.) reload > -- safely so no warning is shown. The active-timer header is separate > -- and shows whenever a timer is running (except on /timers itself and > -- text views). > buildHeaders :: Ctx -> IO [T.Text] > buildHeaders ctx = case ctxKey ctx of > Nothing -> pure [] > Just k -> do > let segs = ctxSegs ctx > rest = drop 2 segs > textView = rest == ["txt"] || rest == ["diary"] > if textView then pure [] else do > let conn = ctxConn ctx > hasQ = not (T.null (ctxQuery ctx)) > dirty = mutationClean segs hasQ > lastHdr <- case dirty of > Just sub -> do > lastRow <- query conn > "SELECT last_kind, last_ref, last_ts FROM journal WHERE key=?" (Only k) > :: IO [(Maybe T.Text, Maybe T.Text, Maybe Integer)] > tz <- getCurrentTimeZone > today <- todayDay > let stamp ts = endLabelTZ tz ts today > label = case lastRow of > [(Just kind, Just ref, Just ts)] -> > "!! don't refresh; tap here . last: " <> actVerb kind <> " " > <> clamp 16 ref <> " . " <> stamp ts > _ -> > "!! don't refresh; tap here for a clean view" > pure [link ctx label ("/k/" <> k <> sub), infoLine ""] > Nothing -> pure [] > actives <- resolveTimers conn k > let timerHdr > | take 1 rest == ["timers"] = [] -- /timers renders its own > | null actives = [] > | otherwise = concatMap oneHdr actives ++ [ infoLine "" ] > oneHdr (nm, elapsed, target, mins, tid) = > let barFill = min elapsed target > check = if elapsed >= target then " " <> checkmark else "" > over = elapsed - target > overTxt = if over > 0 then " +" <> fmtMin (over `div` 60) else "" > in [ link ctx (clamp 14 nm <> " [" <> barW 10 barFill target > <> "]" <> check <> " " <> fmtMin (elapsed `div` 60) > <> " of " <> fmtMin mins <> overTxt) > ("/k/" <> k <> "/timers/stop/" <> tshow tid) ] > pure (lastHdr ++ timerHdr) > > page :: Ctx -> [T.Text] -> IO () > page ctx rows = do > hdrs <- buildHeaders ctx > mapM_ putLine (hdrs ++ rows ++ ["."]) > > -- | >>> infoLine "hello" > -- "ihello\t\t\t0" > infoLine :: T.Text -> T.Text > infoLine msg = "i" <> sanitize msg <> "\t\t\t0" > > -- | >>> menuRow '1' "home" "/" "host" "70" > -- "1home\t/\thost\t70" > menuRow :: Char -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text > menuRow t display selector host port = > T.singleton t <> sanitize display <> "\t" <> selector > <> "\t" <> host <> "\t" <> port > > errorItem :: T.Text -> T.Text > errorItem msg = "3" <> sanitize msg <> "\t\t\t0" > > -- | >>> sanitize "evil\tfake\trow" > -- "evil fake row" > sanitize :: T.Text -> T.Text > sanitize = T.map (\c -> if c == '\r' || c == '\n' || c == '\t' then ' ' else c) Everything the handlers share: where we are mounted, who we tell clients we are, and the open DB handle. `link`/`search` build rows that point back under this script's mount point. > data Ctx = Ctx > { ctxSel :: T.Text > , ctxHost :: T.Text > , ctxPort :: T.Text > , ctxConn :: Connection > , ctxKey :: Maybe T.Text -- present on keyed routes; Nothing on /, /new > , ctxSegs :: [T.Text] -- request path segments (for header logic) > , ctxQuery :: T.Text -- request query string (for has-query) > } > > link :: Ctx -> T.Text -> T.Text -> T.Text > link ctx display sub = > menuRow '1' display (ctxSel ctx <> sub) (ctxHost ctx) (ctxPort ctx) > > search :: Ctx -> T.Text -> T.Text -> T.Text > search ctx display sub = > menuRow '7' display (ctxSel ctx <> sub) (ctxHost ctx) (ctxPort ctx) > > textLink :: Ctx -> T.Text -> T.Text -> T.Text > textLink ctx display sub = > menuRow '0' display (ctxSel ctx <> sub) (ctxHost ctx) (ctxPort ctx) > > -- | Emit a plain-text body (gopher item type 0): dot-stuff any line > -- that would otherwise look like the terminator, then terminate. > textPage :: [T.Text] -> IO () > textPage ls = mapM_ (putLine . stuff) ls >> putLine "." > where stuff l = if not (T.null l) && T.head l == '.' then "." <> l else l The database ------------ Two tables, WAL mode. `openDb` is idempotent: the `CREATE TABLE IF NOT EXISTS` statements make first-run and hundredth-run identical. The `task.day` column (`YYYY-MM-DD`) is the single source of truth for both day-grouping and month arithmetic (`substr(day,1,7)`). > openDb :: FilePath -> IO Connection > openDb path = do > conn <- open path > _ <- query_ conn "PRAGMA journal_mode=WAL" :: IO [Only T.Text] > _ <- query_ conn "PRAGMA busy_timeout=5000" :: IO [Only Int] > -- NORMAL is the SQLite-recommended WAL setting: durable across > -- application crashes; only an OS crash / power loss can lose the > -- last not-yet-checkpointed txn. Each request closes its connection, > -- which checkpoints the WAL, so the exposure is at most one action. > execute_ conn "PRAGMA synchronous=NORMAL" > mapM_ (execute_ conn) schema > mapM_ (migrate conn) migrations > backfillTimerActive conn > pure conn > where > -- SQLite has no ADD COLUMN IF NOT EXISTS; the duplicate-column > -- error on an already-migrated DB is the no-op signal. > migrate c q = do > r <- try (execute_ c q) :: IO (Either SomeException ()) > case r of > Right () -> pure () > Left e > | "duplicate column" `T.isInfixOf` T.pack (show e) -> pure () > | otherwise -> error ("migration crash: " ++ show q ++ " -> " ++ show e) > > -- | One-time, self-disabling migration of running-timer state from the > -- legacy single journal pointer (@journal.active_tid@/@active_started@) > -- onto each timer's own @active_started@ column. After the journal > -- pointer is cleared it can never match again, so this is a harmless > -- no-op on every subsequent connection. A timer running at upgrade time > -- keeps running, re-homed onto its own row. > backfillTimerActive :: Connection -> IO () > backfillTimerActive conn = withTransaction conn $ do > execute_ conn > "UPDATE timer SET active_started =\ > \ (SELECT j.active_started FROM journal j WHERE j.active_tid = timer.id)\ > \ WHERE active_started IS NULL\ > \ AND id IN (SELECT active_tid FROM journal WHERE active_tid IS NOT NULL)" > execute_ conn > "UPDATE journal SET active_tid=NULL, active_started=NULL\ > \ WHERE active_tid IS NOT NULL" > > schema :: [Query] > schema = > [ "CREATE TABLE IF NOT EXISTS journal\ > \ (key TEXT PRIMARY KEY, active_month TEXT NOT NULL,\ > \ created TEXT NOT NULL)" > , "CREATE TABLE IF NOT EXISTS task\ > \ (id INTEGER PRIMARY KEY AUTOINCREMENT, jkey TEXT NOT NULL,\ > \ body TEXT NOT NULL, state TEXT NOT NULL, day TEXT NOT NULL,\ > \ carries INTEGER NOT NULL DEFAULT 0,\ > \ important INTEGER NOT NULL DEFAULT 0,\ > \ created TEXT NOT NULL, updated TEXT NOT NULL)" > , "CREATE INDEX IF NOT EXISTS task_jkey_day ON task (jkey, day)" > , "CREATE TABLE IF NOT EXISTS habit\ > \ (id INTEGER PRIMARY KEY AUTOINCREMENT, jkey TEXT NOT NULL,\ > \ name TEXT NOT NULL, archived INTEGER NOT NULL DEFAULT 0,\ > \ target INTEGER NOT NULL DEFAULT 7, created TEXT NOT NULL)" > , "CREATE TABLE IF NOT EXISTS hcheck\ > \ (jkey TEXT NOT NULL, hid INTEGER NOT NULL, day TEXT NOT NULL,\ > \ PRIMARY KEY (hid, day))" > , "CREATE INDEX IF NOT EXISTS hcheck_jkey_day ON hcheck (jkey, day)" > , "CREATE INDEX IF NOT EXISTS habit_jkey ON habit (jkey)" > , "CREATE TABLE IF NOT EXISTS timer\ > \ (id INTEGER PRIMARY KEY AUTOINCREMENT, jkey TEXT NOT NULL,\ > \ name TEXT NOT NULL, minutes INTEGER NOT NULL, hid INTEGER,\ > \ archived INTEGER NOT NULL DEFAULT 0, created TEXT NOT NULL)" > , "CREATE INDEX IF NOT EXISTS timer_jkey ON timer (jkey, archived)" > , "CREATE TABLE IF NOT EXISTS timer_done\ > \ (jkey TEXT NOT NULL, tid INTEGER NOT NULL, day TEXT NOT NULL,\ > \ started INTEGER NOT NULL, completed INTEGER NOT NULL,\ > \ PRIMARY KEY (tid, day))" > , "CREATE INDEX IF NOT EXISTS timer_done_jkey ON timer_done (jkey, day)" > , "CREATE TABLE IF NOT EXISTS counter\ > \ (id INTEGER PRIMARY KEY AUTOINCREMENT, jkey TEXT NOT NULL,\ > \ name TEXT NOT NULL, period TEXT NOT NULL DEFAULT 'day',\ > \ polarity TEXT NOT NULL DEFAULT 'pos', goal INTEGER,\ > \ archived INTEGER NOT NULL DEFAULT 0, created TEXT NOT NULL)" > , "CREATE INDEX IF NOT EXISTS counter_jkey ON counter (jkey, archived)" > , "CREATE TABLE IF NOT EXISTS counter_tick\ > \ (jkey TEXT NOT NULL, cid INTEGER NOT NULL, day TEXT NOT NULL,\ > \ n INTEGER NOT NULL DEFAULT 0, PRIMARY KEY (cid, day))" > , "CREATE INDEX IF NOT EXISTS counter_tick_jkey ON counter_tick (jkey, day)" > , "CREATE TABLE IF NOT EXISTS saved_search\ > \ (id INTEGER PRIMARY KEY AUTOINCREMENT, jkey TEXT NOT NULL,\ > \ q TEXT NOT NULL, created TEXT NOT NULL,\ > \ UNIQUE (jkey, q))" > , "CREATE INDEX IF NOT EXISTS saved_search_jkey ON saved_search (jkey)" > ] > > -- | Idempotent column additions for journals created before a column > -- existed. Each either succeeds or fails with "duplicate column". > migrations :: [Query] > migrations = > [ "ALTER TABLE task ADD COLUMN important INTEGER NOT NULL DEFAULT 0" > , "ALTER TABLE task ADD COLUMN pmig INTEGER NOT NULL DEFAULT 0" > , "ALTER TABLE task ADD COLUMN pdel INTEGER NOT NULL DEFAULT 0" > , "ALTER TABLE habit ADD COLUMN target INTEGER NOT NULL DEFAULT 7" > , "ALTER TABLE journal ADD COLUMN active_tid INTEGER" > , "ALTER TABLE journal ADD COLUMN active_started INTEGER" > , "ALTER TABLE journal ADD COLUMN hide_done INTEGER NOT NULL DEFAULT 0" > , "ALTER TABLE timer ADD COLUMN paused_elapsed INTEGER NOT NULL DEFAULT 0" > , "ALTER TABLE timer ADD COLUMN paused_day TEXT" > , "ALTER TABLE journal ADD COLUMN last_kind TEXT" > , "ALTER TABLE journal ADD COLUMN last_ref TEXT" > , "ALTER TABLE journal ADD COLUMN last_ts INTEGER" > , "ALTER TABLE task ADD COLUMN prev_state TEXT" > -- per-timer running state (NULL = not running). Replaces the single > -- journal.active_tid/active_started pointer so several timers can run > -- at once; the legacy journal columns are migrated over once (see > -- 'backfillTimerActive') and then left dormant. > , "ALTER TABLE timer ADD COLUMN active_started INTEGER" > -- the "only one timer at a time" toggle (1 = on, the default = the old > -- behaviour where starting a timer pauses any other running one). > , "ALTER TABLE journal ADD COLUMN single_timer INTEGER NOT NULL DEFAULT 1" ] A task as the handlers see it. The full row carries more columns, but rendering only needs these five. > data Task = Task > { tId :: Int > , tBody :: T.Text > , tState :: T.Text > , tDay :: T.Text > , tCarries :: Int > , tImportant :: Int > } deriving (Eq, Show) > > instance FromRow Task where > fromRow = Task <$> field <*> field <*> field <*> field <*> field <*> field > > taskCols :: Query > taskCols = "id, body, state, day, carries, important" > > -- | One task as a plain text line: the uniform bullet prefix, body, > -- the carry nudge, and a parenthetical for settled rows. Shared by > -- the read-only archive and the text export. > -- > -- >>> taskLine (Task 1 "buy milk" "open" "2026-05-22" 0 0) > -- " [ ] buy milk" > -- > -- >>> taskLine (Task 2 "finish taxes" "open" "2026-05-22" 4 1) > -- "*[ ] finish taxes (carried 4x)" > -- > -- >>> taskLine (Task 3 "old plan" "migrated" "2026-04-01" 0 0) > -- " [>] old plan (carried forward)" > -- > -- >>> taskLine (Task 4 "gym" "dropped" "2026-04-01" 0 0) > -- " [~] gym (dropped)" > taskLine :: Task -> T.Text > taskLine t = > mark (tImportant t) (tState t) <> bullet (tState t) > <> tBody t <> carryNote (tCarries t) <> settled (tState t) > where settled "migrated" = " (carried forward)" > settled "dropped" = " (dropped)" > settled _ = "" Time and identity. > -- | Today's date in the server's local zone, as @YYYY-MM-DD@. > todayDay :: IO T.Text > todayDay = do > zt <- getZonedTime > pure (T.pack (formatTime defaultTimeLocale "%Y-%m-%d" zt)) > > -- | Current wall-clock time as whole POSIX seconds. A timer measures > -- elapsed time against this, so it "runs" with no process: nothing > -- ticks, the clock just moves. > nowEpoch :: IO Integer > nowEpoch = floor <$> getPOSIXTime > > -- | The local-zone calendar day (@YYYY-MM-DD@) of a POSIX second in a > -- given zone. Pure so the boundary maths can be doctested. A timer's > -- completion is credited to this date computed from when it ELAPSED > -- (start + minutes), which is what makes overnight credit land on the > -- right day no matter when the page is next loaded. > -- > -- >>> epochDayTZ utc 1700000000 > -- "2023-11-14" > -- > -- A 25-minute block started 11:55pm UTC (epoch 1700006100) elapses after > -- midnight, so the start day and the elapsed (credit) day differ: > -- > -- >>> [epochDayTZ utc 1700006100, epochDayTZ utc (1700006100 + 25*60)] > -- ["2023-11-14","2023-11-15"] > epochDayTZ :: TimeZone -> Integer -> T.Text > epochDayTZ tz e = > T.pack (formatTime defaultTimeLocale "%Y-%m-%d" > (localDay (utcToLocalTime tz (posixSecondsToUTCTime (fromIntegral e))))) > > -- | 'epochDayTZ' in the same zone 'todayDay' uses, so timer credit > -- dates line up with every other date in the journal. > epochDay :: Integer -> IO T.Text > epochDay e = do tz <- getCurrentTimeZone; pure (epochDayTZ tz e) > > -- | An epoch as a local clock time (@3:47am@), with a weekday prefix when > -- it is not @today@ (@tue 11:55pm@). For showing when a timer ends: a > -- stable statement that reads right even on a page-caching client, where > -- a live "X left" countdown looks frozen. > -- > -- >>> endLabelTZ utc 1700006100 (T.pack "2023-11-14") > -- "11:55pm" > -- > -- >>> endLabelTZ utc 1700006100 (T.pack "2026-01-01") > -- "tue 11:55pm" > endLabelTZ :: TimeZone -> Integer -> T.Text -> T.Text > endLabelTZ tz e today = > let lt = utcToLocalTime tz (posixSecondsToUTCTime (fromIntegral e)) > tm = T.strip (T.toLower (T.pack (formatTime defaultTimeLocale "%l:%M%p" lt))) > wd = T.toLower (T.pack (formatTime defaultTimeLocale "%a" lt)) > in if epochDayTZ tz e == today then tm else wd <> " " <> tm > > -- | Seconds left on a block of @mins@ minutes started at @started@ and > -- seen at @now@ (all POSIX seconds); never negative. > -- > -- >>> map (remainingSecs 25 1000) [1000, 1700, 2600] > -- [1500,800,0] > remainingSecs :: Int -> Integer -> Integer -> Int > remainingSecs mins started now = max 0 (mins * 60 - fromIntegral (now - started)) > > -- | Total elapsed seconds for a timer that may pause/resume across a day: > -- the progress banked earlier today (when @pausedDay@ is today) plus the > -- current running segment. A stale paused day counts as 0, so timers reset > -- fresh each day --- and pausing then resuming continues where you left off. > -- > -- >>> totalElapsed 1200 (Just (T.pack "2026-05-27")) (T.pack "2026-05-27") 1000 1300 > -- 1500 > -- > -- >>> totalElapsed 1200 (Just (T.pack "2026-05-26")) (T.pack "2026-05-27") 1000 1300 > -- 300 > totalElapsed :: Int -> Maybe T.Text -> T.Text -> Integer -> Integer -> Int > totalElapsed pausedElapsed pausedDay today started now = > (if pausedDay == Just today then pausedElapsed else 0) + fromIntegral (now - started) > > -- | A countdown as @m:ss@, or @h:mm:ss@ once past an hour. > -- > -- >>> map fmtClock [0, 65, 1500, 5400] > -- ["0:00","1:05","25:00","1:30:00"] > fmtClock :: Int -> T.Text > fmtClock secs = > let (h, r) = secs `divMod` 3600 > (m, s) = r `divMod` 60 > pad2 n = T.justifyRight 2 '0' (tshow n) > in if h > 0 then tshow h <> ":" <> pad2 m <> ":" <> pad2 s > else tshow m <> ":" <> pad2 s > > -- | 16 random bytes from @/dev/urandom@, hex-encoded to a 32-char key. > -- Retries on a short read so the key is always full-width: a truncated > -- key would pass creation but then fail 'validKey' on every later > -- visit, leaving the journal permanently unreachable. > genKey :: IO T.Text > genKey = do > h <- openBinaryFile "/dev/urandom" ReadMode > bs <- BS.hGet h 16 > hClose h > if BS.length bs == 16 then pure (hexEncode bs) else genKey Front door and journal creation ------------------------------- > frontDoor :: Ctx -> IO () > frontDoor ctx = page ctx > [ infoLine "bujo --- a bullet journal over gopher" > , infoLine "" > , infoLine "one running list per month, grouped by the day you file" > , infoLine "each task. add a task in a single line; tap it to check" > , infoLine "it off. at month's end you pick what carries forward; the" > , infoLine "rest settles into the archive (and can be pulled back)." > , infoLine "" > , infoLine "also built in: star what matters, a monthly habit" > , infoLine "tracker, an honest stats page, and a one-page text export." > , infoLine "" > , link ctx "create my journal" "/new" > , infoLine "" > , infoLine "you will get a private link to bookmark." > ] > > createJournal :: Ctx -> IO () > createJournal ctx = do > key <- mintKey -- guaranteed 32-hex before we commit to it > today <- todayDay > execute (ctxConn ctx) > "INSERT INTO journal (key, active_month, created) VALUES (?,?,?)" > (key, monthOf today, today) > page ctx > [ infoLine "your journal is ready." > , infoLine "" > , infoLine "BOOKMARK THIS LINK. it is the only way back in, and" > , infoLine "anyone who has it can read and edit your journal:" > , infoLine "" > , infoLine (" " <> ctxSel ctx <> "/k/" <> key) > , infoLine "" > , link ctx "open my journal" ("/k/" <> key) > ] > where > -- belt-and-suspenders: never persist a key the router would reject. > mintKey = do k <- genKey; if validKey k then pure k else mintKey The journal: normal vs migration -------------------------------- `home` is the one selector a bookmark points at. It decides, on every hit, whether to show the running list or the migration ritual: if the real month is ahead of the journal's active month *and* open tasks remain from earlier months, it migrates; otherwise it quietly advances the active month (nothing to review) and shows the list. > home :: Ctx -> T.Text -> IO () > home ctx key = do > let conn = ctxConn ctx > mj <- listToMaybe <$> > (query conn "SELECT active_month FROM journal WHERE key=?" (Only key) > :: IO [Only T.Text]) > case mj of > Nothing -> notFound ctx > Just (Only active) -> do > today <- todayDay > let real = monthOf today > oldN <- query conn > "SELECT COUNT(*) FROM task WHERE jkey=? AND state='open' AND substr(day,1,7) (key, real) :: IO [Only Int] > if needsMigration active real && maybe 0 fromOnly (listToMaybe oldN) > 0 > then migrationView ctx key real > else do > when (active /= real) $ > execute conn "UPDATE journal SET active_month=? WHERE key=?" > (real, key) > -- carry/delete picks are ephemeral to their ritual screens; landing > -- back on the journal clears them, so a half-finished selection never > -- lingers to confuse a later visit (and the counts can't drift apart). > execute conn "UPDATE task SET pmig=0, pdel=0 WHERE jkey=? AND (pmig=1 OR pdel=1)" > (Only key) > normalView ctx key real > > -- | Persist the show/hide-done preference. Named target (not a blind toggle), > -- so a refresh is safe; persists across visits (it's a preference, untouched by > -- the ephemeral pmig/pdel clear). > setHideDone :: Ctx -> T.Text -> Int -> IO () > setHideDone ctx key v = do > execute (ctxConn ctx) "UPDATE journal SET hide_done=? WHERE key=?" (v, key) > home ctx key > > normalView :: Ctx -> T.Text -> T.Text -> IO () > normalView ctx key real = do > let conn = ctxConn ctx > tasks <- query conn > (Query ("SELECT " <> fromQuery taskCols <> > " FROM task WHERE jkey=? AND substr(day,1,7)=?\ > \ AND state IN ('open','done','note') ORDER BY day DESC, id DESC")) > (key, real) :: IO [Task] > archN <- query conn > "SELECT COUNT(DISTINCT substr(day,1,7)) FROM task\ > \ WHERE jkey=? AND substr(day,1,7)'trashed'" (key, real) :: IO [Only Int] > hd <- query conn "SELECT hide_done FROM journal WHERE key=?" (Only key) :: IO [Only Int] > -- saved finds ride just under the find box, each with a live count of how > -- many of this month's tasks it matches (the same predicate the search > -- page uses, so the number never lies about what's behind the tap). > saved <- query conn > "SELECT id, q FROM saved_search WHERE jkey=? ORDER BY id LIMIT 8" (Only key) > :: IO [(Int, T.Text)] > savedRows <- forM saved $ \(sid, sq) -> do > cnt <- query conn > "SELECT COUNT(*) FROM task WHERE jkey=? AND substr(day,1,7)=?\ > \ AND state IN ('open','done','note') AND body LIKE ? ESCAPE '\\'" > (key, real, "%" <> likeEscape sq <> "%") :: IO [Only Int] > let n = maybe 0 fromOnly (listToMaybe cnt) > pure (link ctx ("\160" <> clamp 40 sq <> " (" <> tshow n <> ")") > ("/k/" <> key <> "/search/run/" <> tshow sid)) > let hideDone = maybe False ((== 1) . fromOnly) (listToMaybe hd) > openN = length (filter ((== "open") . tState) tasks) > doneN = length (filter ((== "done") . tState) tasks) > starN = length (filter (\t -> tImportant t == 1 && tState t == "open") tasks) > visible = if hideDone then filter ((/= "done") . tState) tasks else tasks > groups = groupBy ((==) `on` tDay) visible > dayBlock g = infoLine ("== " <> dayLabel (tDay (head g)) <> " ==") > : map render g > -- a note is an inert logged line; a task is a clickable toggle. > -- live task rows are clickable (type 1); some clients trim a > -- leading ASCII space off those, so non-important rows pad with > -- a non-breaking space (renders as a space, survives the trim) > -- to stay aligned under the "*" of important rows. > menuMark t = if tImportant t == 1 && tState t == "open" then "*" else "\160" > render t > | tState t == "note" = infoLine (" " <> bullet "note" <> clamp 68 (tBody t)) > | otherwise = link ctx > (menuMark t <> bullet (tState t) <> clamp 68 (tBody t) <> carryNote (tCarries t)) > ("/k/" <> key <> "/" <> nextState (tState t) <> "/" <> tshow (tId t)) > body | null tasks = [ infoLine "nothing here yet --- add your first task above." ] > | null visible = [ infoLine "(done tasks hidden --- tap 'show done' to see them.)" ] > | otherwise = concatMap dayBlock groups > -- one door for prioritising: jump to starred when you have some to > -- check off, else into focus to pick what's important. Focus stays > -- reachable from inside the starred view. > whatMattersLink > | starN > 0 = [ link ctx ("what matters --- check off your starred (" <> tshow starN <> ")") > ("/k/" <> key <> "/starred") ] > | openN > 0 = [ link ctx "what matters --- pick what's important" > ("/k/" <> key <> "/focus") ] > | otherwise = [] > archLink = case archN of > (Only n : _) | n > 0 -> > [ link ctx ("view archive (" <> plural n "month" <> ")") > ("/k/" <> key <> "/archive") ] > _ -> [] > trackersLink = [ link ctx "habit tracker" ("/k/" <> key <> "/habits") > , link ctx "timeblocks (timers)" ("/k/" <> key <> "/timers") > , link ctx "counters" ("/k/" <> key <> "/counters") ] > -- review & export live behind one door to keep the front page calm. > metaLink = [ link ctx "meta (read only) --- stats, hiscores, export, diary" > ("/k/" <> key <> "/meta") ] > -- the mutate-your-entries door: carry/trash tasks AND delete notes. > -- Always shown (notes can need managing even with nothing to migrate). > migrateLink = [ link ctx "migrate & manage --- carry tasks, delete notes" > ("/k/" <> key <> "/migrate") ] > -- one line does double duty: the show/hide-done toggle AND the month's > -- tally "(done; open; %done)", so no separate count line is needed. > -- With nothing done there's nothing to hide, so it falls back to a > -- plain open count. > doneToggle > | doneN == 0 = [ infoLine (tshow openN <> " open") ] > | otherwise = > let total = openN + doneN > pct = (doneN * 100 + total `div` 2) `div` total > stats = "(" <> tshow doneN <> " done; " <> tshow openN > <> " open; " <> tshow pct <> "%)" > (verb, sel) = if hideDone then ("show done ", "/showdone") > else ("hide done ", "/hidedone") > in [ link ctx (verb <> stats) ("/k/" <> key <> sel) ] > -- Layout: daily tools (count + trackers) ride above the task list so > -- they're one screen away even with a long list; review/cleanup doors > -- (meta, archive, migrate) settle below it. > page ctx $ > [ infoLine (monthLabel real) > , search ctx "+ add a task (- note, * important)" ("/k/" <> key <> "/add") > , search ctx "find a task (filter this month)" ("/k/" <> key <> "/search") > ] ++ savedRows ++ whatMattersLink ++ doneToggle > ++ trackersLink ++ > [ infoLine "" ] ++ body ++ [ infoLine "" ] > ++ metaLink ++ archLink ++ migrateLink > > -- | The month-rollover review. Each still-open task from before is a > -- checkbox: tap to choose whether it carries into the new month > -- (default off). "finish" carries the checked ones; the rest settle > -- into their old month (you can pull any back from the archive later). > migrationView :: Ctx -> T.Text -> T.Text -> IO () > migrationView ctx key real = do > olds <- query (ctxConn ctx) > "SELECT id, body, carries, pmig FROM task\ > \ WHERE jkey=? AND state='open' AND substr(day,1,7) (key, real) :: IO [(Int, T.Text, Int, Int)] > let picked = length [ () | (_, _, _, p) <- olds, p == 1 ] > row (i, body, carries, p) = > let (box, verb) = if p == 1 then ("[x] ", "unmig") else ("[ ] ", "mig") > in link ctx (box <> clamp 56 body <> carryNote carries) > ("/k/" <> key <> "/" <> verb <> "/" <> tshow i) > page ctx $ > [ infoLine ("==== entering " <> monthLabel real <> " ====") > , infoLine "" > , infoLine (plural (length olds) "task" <> " still open from before.") > , infoLine "tap the ones to carry forward; the rest stay behind" > , infoLine "(you can pull them back from the archive anytime)." > , infoLine "" > ] ++ map row olds ++ > [ infoLine "" > , link ctx ("finish migration --- carry " <> tshow picked <> " into " <> monthLabel real) > ("/k/" <> key <> "/start") > ] Mutations --------- Each mutation does its work, then re-renders `home` so the client lands on a fresh view --- the response to a click is always the updated journal. > addTask :: Ctx -> T.Text -> T.Text -> IO () > addTask ctx key q = do > let (st, imp, raw) = classify q > body = T.take bodyMax raw > when (not (T.null body)) $ do > today <- todayDay > execute (ctxConn ctx) > "INSERT INTO task (jkey, body, state, day, carries, important, created, updated)\ > \ VALUES (?,?,?,?,0,?,?,?)" > (key, body, st, today, imp, today, today) > logEvent (ctxConn ctx) key "task_add" body > home ctx key > > -- | Set a task to an explicit state (@done@ or @open@). Naming the > -- target rather than toggling keeps the selector idempotent: a > -- client refresh or a crawler re-fetch lands on the same result. The > -- @state IN ('open','done')@ guard means a crafted URL can never turn > -- a note, migrated, or dropped row into a live task. The final action > -- re-renders whichever view the click came from, so checking a task > -- off in the starred view leaves you in the starred view. > setTaskState :: Ctx -> T.Text -> T.Text -> Int -> IO () -> IO () > setTaskState ctx key new i rerender = do > today <- todayDay > bodies <- query (ctxConn ctx) "SELECT body FROM task WHERE id=? AND jkey=?" > (i, key) :: IO [Only T.Text] > execute (ctxConn ctx) > "UPDATE task SET state=?, updated=? WHERE id=? AND jkey=? AND state IN ('open','done')" > (new, today, i, key) > case bodies of > (Only b : _) -> logEvent (ctxConn ctx) key > (if new == "done" then "task_done" else "task_open") b > _ -> pure () > rerender > > -- | Carry one open task forward: the old row becomes a @migrated@ > -- breadcrumb, and a fresh @open@ copy is filed under today with its > -- carry count bumped (so a repeatedly-carried task announces itself). > carryTask :: Connection -> T.Text -> T.Text -> Int -> IO () > carryTask conn key today i = do > rows <- query conn > "SELECT body, carries, important FROM task WHERE id=? AND jkey=? AND state='open'" > (i, key) :: IO [(T.Text, Int, Int)] > case rows of > ((b, c, im) : _) -> do > execute conn "UPDATE task SET state='migrated', updated=? WHERE id=?" > (today, i) > execute conn > "INSERT INTO task (jkey, body, state, day, carries, important, created, updated)\ > \ VALUES (?,?,'open',?,?,?,?,?)" > (key, b, today, c + 1, im, today, today) > _ -> pure () > > -- | Toggle a prior-open task's "carry me forward?" flag during the > -- migration review. Naming the target value (1 or 0) keeps it > -- idempotent --- a refresh won't flip the selection. Nothing is > -- carried until 'finishMigration'. > setPmig :: Ctx -> T.Text -> Int -> Int -> IO () -> IO () > setPmig ctx key v i rerender = do > execute (ctxConn ctx) > "UPDATE task SET pmig=? WHERE id=? AND jkey=? AND state='open'" (v, i, key) > rerender > > -- | Finish the month-rollover: carry the checked tasks forward, settle > -- the unchecked ones into their old month as @lapsed@ (still in the > -- archive, restorable, but no longer nagging the active list), clear > -- the flags, and advance the month --- all atomically, so a crash > -- mid-finish rolls back and re-shows the review with nothing stranded. > finishMigration :: Ctx -> T.Text -> IO () > finishMigration ctx key = do > let conn = ctxConn ctx > today <- todayDay > let real = monthOf today > picks <- query conn > "SELECT id FROM task WHERE jkey=? AND state='open' AND substr(day,1,7) (key, real) :: IO [Only Int] > withTransaction conn $ do > forM_ picks $ \(Only i) -> carryTask conn key today i > execute conn > "UPDATE task SET state='lapsed', updated=?\ > \ WHERE jkey=? AND state='open' AND substr(day,1,7) (today, key, real) > execute conn "UPDATE task SET pmig=0 WHERE jkey=? AND pmig=1" (Only key) > execute conn "UPDATE journal SET active_month=? WHERE key=?" (real, key) > home ctx key Early migration (/migrate) -------------------------- The month-rollover ritual, available any day: a select-then-commit screen over *this* month's open tasks. Tap a task to carry it forward (re-dated to today); the ones you leave are archived (lapsed) when you commit. It does NOT advance the month --- you are tidying the live list, not crossing a boundary. Rendered with rapid-logging signifiers: @(>)@ will carry, @(.)@ will stay behind (archive). One tap = one meaning (toggle the carry flag); the commit quantifies the archive sweep so it is never silent. Delete is a deliberate second step, tucked behind a link. Reuses the @pmig@ flag and the @lapsed@ state; no schema change. > earlyMigrateView :: Ctx -> T.Text -> IO () > earlyMigrateView ctx key = do > today <- todayDay > let real = monthOf today > opens <- query (ctxConn ctx) > "SELECT id, body, carries, pmig FROM task\ > \ WHERE jkey=? AND state='open' AND substr(day,1,7)=? ORDER BY day ASC, id ASC" > (key, real) :: IO [(Int, T.Text, Int, Int)] > let sel = length [ () | (_, _, _, p) <- opens, p == 1 ] > rest = length opens - sel > row (i, body, carries, p) = > let (box, verb) = if p == 1 then ("[x] ", "drop") else ("[ ] ", "pick") > in link ctx (box <> clamp 56 body <> carryNote carries) > ("/k/" <> key <> "/migrate/" <> verb <> "/" <> tshow i) > page ctx $ > [ infoLine "migrate & manage", infoLine "" > , infoLine "tap a task to select; then carry the selected (the rest get" > , infoLine "archived), or trash them. notes are managed below." > , infoLine "" ] > ++ (if null opens then [infoLine "nothing open here."] else map row opens) > ++ [ infoLine "" > , link ctx ("carry " <> tshow sel <> " to today (archive the other " <> tshow rest <> ")") > ("/k/" <> key <> "/migrate/go") > , link ctx ("trash " <> tshow sel <> " selected") > ("/k/" <> key <> "/migrate/del") > , infoLine "" > , link ctx "manage notes (delete)" ("/k/" <> key <> "/notes") > , link ctx "recycle bin (restore trashed)" ("/k/" <> key <> "/trash") > , link ctx "back to the journal" ("/k/" <> key) ] > > -- | Commit an early migration: carry the picked tasks (re-date to today, > -- still open), archive the rest (@lapsed@), clear the flags. Atomic, and > -- crucially does NOT advance @active_month@ --- this is a within-month > -- tidy, not a rollover. Carried tasks are re-dated rather than copied (no > -- @migrated@ breadcrumb), because nothing is crossing a month boundary. > earlyMigrate :: Ctx -> T.Text -> IO () > earlyMigrate ctx key = do > let conn = ctxConn ctx > today <- todayDay > let real = monthOf today > picked <- query conn "SELECT COUNT(*) FROM task WHERE jkey=? AND state='open' AND pmig=1" > (Only key) :: IO [Only Int] > withTransaction conn $ do > execute conn > "UPDATE task SET day=?, updated=?\ > \ WHERE jkey=? AND state='open' AND substr(day,1,7)=? AND pmig=1" > (today, today, key, real) > execute conn > "UPDATE task SET state='lapsed', updated=?\ > \ WHERE jkey=? AND state='open' AND substr(day,1,7)=? AND pmig=0" > (today, key, real) > execute conn "UPDATE task SET pmig=0 WHERE jkey=? AND pmig=1" (Only key) > let n = case picked of (Only c : _) -> c; _ -> 0 > logEvent conn key "migrate_carry" (tshow n <> " task" <> (if n == 1 then "" else "s")) > home ctx key The archive ----------- Everything left behind by past migrations lives here, one screen per month, frozen and read-only --- archived rows render as info lines, not links, because the past does not change. > archiveIndex :: Ctx -> T.Text -> IO () > archiveIndex ctx key = do > let conn = ctxConn ctx > today <- todayDay > let real = monthOf today > months <- query conn > "SELECT DISTINCT substr(day,1,7) m FROM task\ > \ WHERE jkey=? AND substr(day,1,7)'trashed' ORDER BY m DESC" > (key, real) :: IO [Only T.Text] > rows <- forM months $ \(Only m) -> do > counts <- query conn > "SELECT state, COUNT(*) FROM task WHERE jkey=? AND substr(day,1,7)=?\ > \ GROUP BY state" (key, m) :: IO [(T.Text, Int)] > let g s = fromMaybe 0 (lookup s counts) > summary = tshow (g "done") <> " done " > <> tshow (g "migrated") <> " carried " > <> tshow (g "lapsed" + g "dropped") <> " left" > pure (link ctx (monthLabel m <> " --- " <> summary) > ("/k/" <> key <> "/archive/" <> m)) > page ctx $ > [ infoLine "the archive", infoLine "" ] ++ > (if null rows then [infoLine "nothing archived yet."] else rows) ++ > [ infoLine "", link ctx "back to the current month" ("/k/" <> key) ] > > archiveMonth :: Ctx -> T.Text -> T.Text -> IO () > archiveMonth ctx key m > | not (validMonth m) = notFound ctx > | otherwise = do > tasks <- query (ctxConn ctx) > (Query ("SELECT " <> fromQuery taskCols <> > " FROM task WHERE jkey=? AND substr(day,1,7)=? AND state<>'trashed'\ > \ ORDER BY day DESC, id ASC")) > (key, m) :: IO [Task] > let groups = groupBy ((==) `on` tDay) tasks > dayBlock g = infoLine ("== " <> dayLabel (tDay (head g)) <> " ==") > : map row g > -- a left-behind (or still-open) task is tappable to pull it > -- back into the current month; settled history is not. > row t > | tState t `elem` ["lapsed", "open"] = > link ctx (taskLine t <> " <- bring back") > ("/k/" <> key <> "/restore/" <> tshow (tId t)) > | otherwise = infoLine (taskLine t) > page ctx $ > [ infoLine (monthLabel m <> " (archived)"), infoLine "" ] ++ > (if null tasks then [infoLine "(empty)"] else concatMap dayBlock groups) ++ > [ infoLine "", link ctx "back to the current month" ("/k/" <> key) ] > > -- | Pull a settled (lapsed) or still-open archived task back into the > -- current month: it becomes open and filed under today. > restore :: Ctx -> T.Text -> Int -> IO () > restore ctx key i = do > today <- todayDay > execute (ctxConn ctx) > "UPDATE task SET state='open', day=?, updated=? WHERE id=? AND jkey=? AND state IN ('lapsed','open')" > (today, today, i, key) > home ctx key The delete view (/delete) ------------------------- Select-then-delete, like migration. A delete is *soft*: the row's state becomes @trashed@ --- hidden from the journal, archive, stats, and export (those queries already filter to other states), but retained and restorable from the "recently deleted" list. That list is a bounded undo buffer of the last 'trashKeep' deletions; once a trashed row falls out of it (and so could never be restored anyway) it is hard-purged, the one place the app truly deletes a row. > -- | Delete the selected (@pmig=1@) tasks from the migrate screen: soft-trash > -- them (retained, hidden, restorable from @/trash@), clear the flags, then > -- hard-purge anything that has fallen out of the bounded undo buffer --- one > -- atomic step. The unselected tasks are left untouched. Re-running is a > -- no-op (the flags are cleared), so a refresh can't double-delete. > migrateDelete :: Ctx -> T.Text -> IO () > migrateDelete ctx key = do > let conn = ctxConn ctx > today <- todayDay > picked <- query conn "SELECT COUNT(*) FROM task WHERE jkey=? AND state='open' AND pmig=1" > (Only key) :: IO [Only Int] > withTransaction conn $ do > execute conn > "UPDATE task SET state='trashed', prev_state='open', updated=?\ > \ WHERE jkey=? AND pmig=1 AND state='open'" (today, key) > execute conn "UPDATE task SET pmig=0 WHERE jkey=? AND pmig=1" (Only key) > execute conn > (Query ("DELETE FROM task WHERE jkey=? AND state='trashed' AND id NOT IN\ > \ (SELECT id FROM task WHERE jkey=? AND state='trashed'\ > \ ORDER BY updated DESC, id DESC LIMIT " <> tshow trashKeep <> ")")) > (key, key) > let n = case picked of (Only c : _) -> c; _ -> 0 > logEvent conn key "migrate_trash" (tshow n <> " task" <> (if n == 1 then "" else "s")) > home ctx key > > -- | The recycle bin: the last 'trashKeep' deletions, each tappable to > -- restore. Older deletions have already been hard-purged and are gone. > trashView :: Ctx -> T.Text -> IO () > trashView ctx key = do > trashed <- query (ctxConn ctx) > (Query ("SELECT id, body, prev_state FROM task WHERE jkey=? AND state='trashed'\ > \ ORDER BY updated DESC, id DESC LIMIT " <> tshow trashKeep)) > (Only key) :: IO [(Int, T.Text, Maybe T.Text)] > -- @[ ]@ marks a trashed task, @ - @ a trashed note (per 'bullet'), so you > -- can tell them apart and know what a restore brings back. > let row (i, body, ps) = > link ctx (bullet (fromMaybe "open" ps) <> clamp 52 body <> " <- restore") > ("/k/" <> key <> "/untrash/" <> tshow i) > cap = tshow (length trashed) <> "/" <> tshow trashKeep > page ctx $ > [ infoLine ("recycle bin --- recently deleted (" <> cap <> ", tap to restore)") > , infoLine "" ] > ++ (if null trashed then [ infoLine "empty --- nothing deleted recently." ] > else map row trashed) > ++ [ infoLine "" > , infoLine ("only the last " <> tshow trashKeep <> " deletions are kept.") > , link ctx "back to the journal" ("/k/" <> key) ] > > -- | Restore one trashed row to whatever it was before it was trashed > -- (recorded in @prev_state@). A note comes back as a note in its original > -- place (diary entries are dated where they happened); anything else comes > -- back as an open task in today (carry-it-forward semantics). Legacy rows > -- with no @prev_state@ default to a task. > restoreTrashed :: Ctx -> T.Text -> Int -> IO () > restoreTrashed ctx key i = do > let conn = ctxConn ctx > today <- todayDay > rows <- query conn "SELECT body, prev_state FROM task WHERE id=? AND jkey=? AND state='trashed'" > (i, key) :: IO [(T.Text, Maybe T.Text)] > case rows of > ((body, Just "note") : _) -> do > execute conn "UPDATE task SET state='note', updated=? WHERE id=? AND jkey=? AND state='trashed'" > (today, i, key) > logEvent conn key "note_restore" body > ((body, _) : _) -> do > execute conn "UPDATE task SET state='open', day=?, updated=? WHERE id=? AND jkey=? AND state='trashed'" > (today, today, i, key) > logEvent conn key "task_restore" body > _ -> pure () > > untrash :: Ctx -> T.Text -> Int -> IO () > untrash ctx key i = restoreTrashed ctx key i >> trashView ctx key > > -- | Notes-only screen: every logged note, newest first, each tappable to > -- delete. Notes render inert on the journal (a tap there means "toggle > -- done", reserved for tasks), so deletion lives on its own view. The full > -- body is wrapped via 'note' --- nothing is clamped, so long notes read in > -- full here even when the journal clips them. > notesView :: Ctx -> T.Text -> IO () > notesView ctx key = do > notes <- query (ctxConn ctx) > "SELECT id, body, day FROM task WHERE jkey=? AND state='note' ORDER BY day DESC, id DESC" > (Only key) :: IO [(Int, T.Text, T.Text)] > let row (i, body, day) = > note body > ++ [ link ctx (" -> delete (" <> day <> ")") > ("/k/" <> key <> "/notes/del/" <> tshow i) > , infoLine "" ] > page ctx $ > [ infoLine "notes --- every logged note (tap to delete)", infoLine "" ] > ++ (if null notes > then [ infoLine "no notes yet. add one with a leading - on the journal." ] > else concatMap row notes) > ++ [ infoLine "deleted notes go to the recycle bin and can be restored." > , link ctx "recycle bin (restore deleted)" ("/k/" <> key <> "/trash") > , link ctx "back to the journal" ("/k/" <> key) ] > > -- | Soft-delete one note: trash it (restorable from @/trash@), then > -- hard-purge anything fallen out of the bounded undo buffer --- the same > -- pattern as 'migrateDelete'. The @state='note'@ guard makes a reload a > -- no-op, so the navigation is refresh-safe without a redirect. > notesDelete :: Ctx -> T.Text -> Int -> IO () > notesDelete ctx key i = do > let conn = ctxConn ctx > today <- todayDay > bodies <- query conn "SELECT body FROM task WHERE id=? AND jkey=? AND state='note'" > (i, key) :: IO [Only T.Text] > withTransaction conn $ do > execute conn > "UPDATE task SET state='trashed', prev_state='note', updated=?\ > \ WHERE id=? AND jkey=? AND state='note'" (today, i, key) > execute conn > (Query ("DELETE FROM task WHERE jkey=? AND state='trashed' AND id NOT IN\ > \ (SELECT id FROM task WHERE jkey=? AND state='trashed'\ > \ ORDER BY updated DESC, id DESC LIMIT " <> tshow trashKeep <> ")")) > (key, key) > case bodies of > (Only b : _) -> logEvent conn key "note_trash" b > _ -> pure () > notesView ctx key The focus view -------------- Importance is orthogonal to done/undone, so it gets its own screen. Here a click toggles the *star* (not done) --- so the meaning of a click stays unambiguous within each view --- and starred tasks rise to the top. You visit it to prioritise, then leave. > focusView :: Ctx -> T.Text -> IO () > focusView ctx key = do > today <- todayDay > let real = monthOf today > tasks <- query (ctxConn ctx) > (Query ("SELECT " <> fromQuery taskCols <> > " FROM task WHERE jkey=? AND substr(day,1,7)=? AND state='open'\ > \ ORDER BY important DESC, day DESC, id DESC")) > (key, real) :: IO [Task] > let row t = link ctx > ((if tImportant t == 1 then "* " else " ") <> clamp 66 (tBody t) <> carryNote (tCarries t)) > ("/k/" <> key <> "/" <> (if tImportant t == 1 then "unstar" else "star") > <> "/" <> tshow (tId t)) > body = if null tasks > then [infoLine "no open tasks to prioritise."] > else map row tasks > page ctx $ > [ infoLine "focus --- what matters this month" > , infoLine "tap a task to star or unstar it; starred rises to the top." > , infoLine "" > ] ++ body ++ > [ infoLine "" > , link ctx "see only starred (check them off)" ("/k/" <> key <> "/starred") > , link ctx "back to the journal" ("/k/" <> key) ] > > -- | Set a task's star to an explicit value (1 or 0). Idempotent for > -- the same reason as 'setTaskState': the selector names the result. > setStar :: Ctx -> T.Text -> Int -> Int -> IO () > setStar ctx key v i = do > today <- todayDay > bodies <- query (ctxConn ctx) "SELECT body FROM task WHERE id=? AND jkey=?" > (i, key) :: IO [Only T.Text] > execute (ctxConn ctx) > "UPDATE task SET important=?, updated=? WHERE id=? AND jkey=? AND state='open'" > (v, today, i, key) > case bodies of > (Only b : _) -> logEvent (ctxConn ctx) key (if v == 1 then "star" else "unstar") b > _ -> pure () > focusView ctx key The starred view ---------------- The do-list twin of the focus view: it shows only this month's starred tasks and a click *checks them off* (open ones first, done ones below so you can un-check). The toggle links carry a trailing @/s@ so 'setTaskState' returns here rather than to the full journal --- you knock down the list without leaving it. > starredView :: Ctx -> T.Text -> IO () > starredView ctx key = do > today <- todayDay > let real = monthOf today > tasks <- query (ctxConn ctx) > (Query ("SELECT " <> fromQuery taskCols <> > " FROM task WHERE jkey=? AND substr(day,1,7)=? AND important=1\ > \ AND state IN ('open','done') ORDER BY (state='done'), day DESC, id DESC")) > (key, real) :: IO [Task] > let row t = link ctx > (bullet (tState t) <> clamp 68 (tBody t) <> carryNote (tCarries t)) > ("/k/" <> key <> "/" <> nextState (tState t) <> "/" <> tshow (tId t) <> "/s") > body > | null tasks = [ infoLine "nothing starred yet." > , link ctx "go pick what's important (focus)" > ("/k/" <> key <> "/focus") ] > | otherwise = map row tasks > page ctx $ > [ infoLine "starred --- what matters", infoLine "tap to check off." > , infoLine "" ] ++ body ++ > [ infoLine "" > , link ctx "pick what's important (focus)" ("/k/" <> key <> "/focus") > , link ctx "back to the journal" ("/k/" <> key) ] The search filter (/search) --------------------------- A type-7 box that filters *this* month's running list by text, keeping every matching row tappable exactly as on the front page (one tap = check it off). It is not a separate read-only results page: it is the normal view, narrowed. Matches in past months surface read-only as archive jump-links below, so nothing is lost without dragging frozen rows into a tappable list. User input is escaped so a literal @%@ or @_@ is not treated as a wildcard. > -- | Escape SQL LIKE wildcards so a query matches literally (paired with > -- @ESCAPE '\\'@): backslash, percent and underscore each get a backslash. > -- > -- >>> likeEscape (T.pack "a_b 50%") > -- "a\\_b 50\\%" > likeEscape :: T.Text -> T.Text > likeEscape = T.concatMap esc > where esc '\\' = "\\\\" > esc '%' = "\\%" > esc '_' = "\\_" > esc c = T.singleton c > > -- | Clean a search before saving it as a "find": trim, collapse internal > -- runs of whitespace to single spaces, drop if it is empty, and clamp the > -- length. Keeps blanks and spacing-only duplicates out of the saved list. > -- > -- >>> normFind (T.pack " drex work ") > -- Just "drex work" > -- >>> normFind (T.pack " ") > -- Nothing > normFind :: T.Text -> Maybe T.Text > normFind raw = > let cleaned = T.unwords (T.words raw) > in if T.null cleaned then Nothing else Just (T.take 60 cleaned) > > -- | Percent-encode text so it rides safely inside one selector path > -- segment (segments split on @/@). Everything outside the unreserved set > -- is encoded as @%xx@ over the UTF-8 bytes, so any query round-trips > -- through 'pctDec'. Lower-case hex; 'pctDec' accepts either case. > -- > -- >>> pctEnc (T.pack "drex/work 50%") > -- "drex%2fwork%2050%25" > pctEnc :: T.Text -> T.Text > pctEnc = T.concat . map encB . BS.unpack . TE.encodeUtf8 > where > encB w > | unreserved w = T.singleton (chr (fromIntegral w)) > | otherwise = T.pack [ '%', intToDigit (fromIntegral (w `div` 16)) > , intToDigit (fromIntegral (w `mod` 16)) ] > unreserved w = > let c = chr (fromIntegral w) > in isDigit c || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') > || c `elem` ("-_.~" :: String) > > -- | Inverse of 'pctEnc'. Bytes that are not a valid @%xx@ pass through as > -- themselves; malformed UTF-8 decodes leniently rather than crashing. > -- > -- >>> pctDec (T.pack "drex%2fwork%2050%25") > -- "drex/work 50%" > -- >>> pctDec (pctEnc (T.pack "caf\233 / x")) > -- "caf\233 / x" > pctDec :: T.Text -> T.Text > pctDec = TE.decodeUtf8With lenientDecode . BS.pack . go . T.unpack > where > go ('%':a:b:rest) > | isHexDigit a, isHexDigit b = > fromIntegral (16 * digitToInt a + digitToInt b) : go rest > go (c:rest) = fromIntegral (ord c) : go rest > go [] = [] > > searchView :: Ctx -> T.Text -> T.Text -> IO () > searchView ctx key q = do > let conn = ctxConn ctx > qn = T.strip q > if T.null qn > then home ctx key > else do > today <- todayDay > let real = monthOf today > pat = "%" <> likeEscape qn <> "%" > tasks <- query conn > (Query ("SELECT " <> fromQuery taskCols <> > " FROM task WHERE jkey=? AND substr(day,1,7)=?\ > \ AND state IN ('open','done','note') AND body LIKE ? ESCAPE '\\'\ > \ ORDER BY day DESC, id DESC")) > (key, real, pat) :: IO [Task] > archMonths <- query conn > "SELECT DISTINCT substr(day,1,7) m FROM task\ > \ WHERE jkey=? AND substr(day,1,7)'trashed'\ > \ AND body LIKE ? ESCAPE '\\' ORDER BY m DESC" > (key, real, pat) :: IO [Only T.Text] > saved <- query conn > "SELECT id FROM saved_search WHERE jkey=? AND q=?" (key, qn) > :: IO [Only Int] > let menuMark t = if tImportant t == 1 && tState t == "open" then "*" else "\160" > render t > | tState t == "note" = infoLine (" " <> bullet "note" <> clamp 68 (tBody t)) > | otherwise = link ctx > (menuMark t <> bullet (tState t) <> clamp 68 (tBody t) <> carryNote (tCarries t)) > ("/k/" <> key <> "/" <> nextState (tState t) <> "/" <> tshow (tId t)) > dayBlock g = infoLine ("== " <> dayLabel (tDay (head g)) <> " ==") : map render g > body = if null tasks then [ infoLine "no matches this month." ] > else concatMap dayBlock (groupBy ((==) `on` tDay) tasks) > archBlock = case archMonths of > [] -> [] > ms -> infoLine "" > : infoLine ("also found in the archive (" <> tshow (length ms) <> "):") > : [ link ctx ("-> " <> monthLabel m) ("/k/" <> key <> "/archive/" <> m) > | Only m <- ms ] > -- when this find is already saved, the top line itself is the > -- delete action ("filtering by x --- tap to delete this filter"); > -- when it is ad-hoc, offer to pin it onto the journal instead. > headRows = case saved of > (Only sid : _) -> > [ link ctx ("filtering by \"" <> clamp 40 qn > <> "\" --- tap to delete this filter") > ("/k/" <> key <> "/search/forget/" <> tshow sid) > , link ctx "show all (clear filter)" ("/k/" <> key) ] > _ -> > [ infoLine ("filtering: " <> clamp 50 qn) > , link ctx "show all (clear filter)" ("/k/" <> key) > , link ctx "pin this as a filter (keep it on the journal)" > ("/k/" <> key <> "/search/pin/" <> pctEnc qn) ] > page ctx $ > headRows ++ [ infoLine "" ] > ++ body ++ archBlock > ++ [ infoLine "", link ctx "back to the journal" ("/k/" <> key) ] > > -- | Pin the current search as a saved find. The query rides in the > -- selector percent-encoded ('pctDec' reverses it); @INSERT OR IGNORE@ on > -- the @UNIQUE (jkey, q)@ key makes a re-tap (or a refresh) a no-op rather > -- than a duplicate, so no "don't refresh" warning is needed. > pinFind :: Ctx -> T.Text -> T.Text -> IO () > pinFind ctx key enc = > case normFind (pctDec enc) of > Nothing -> home ctx key > Just q -> do > today <- todayDay > execute (ctxConn ctx) > "INSERT OR IGNORE INTO saved_search (jkey, q, created) VALUES (?,?,?)" > (key, q, today) > searchView ctx key q > > -- | Drop a saved find. Scoped by jkey, idempotent (a missing id is a > -- no-op), so a refresh is harmless. A saved find is a preference, not a > -- journal entry, so this is a real delete --- nothing of record is lost. > forgetFind :: Ctx -> T.Text -> Int -> IO () > forgetFind ctx key sid = do > execute (ctxConn ctx) > "DELETE FROM saved_search WHERE id=? AND jkey=?" (sid, key) > home ctx key > > -- | Run a saved find by id: look up its text and hand off to 'searchView', > -- so a saved find behaves exactly like typing it into the find box. > runFind :: Ctx -> T.Text -> Int -> IO () > runFind ctx key sid = do > r <- query (ctxConn ctx) > "SELECT q FROM saved_search WHERE id=? AND jkey=?" (sid, key) > :: IO [Only T.Text] > case r of > (Only q : _) -> searchView ctx key q > _ -> home ctx key The text export --------------- The whole journal as one plain-text page, oldest first --- a diary to read straight through, and a backup you can save anywhere. Emitted as gopher item type 0, so it is linked with a @0@ prefix from the menu. > exportTxt :: Ctx -> T.Text -> IO () > exportTxt ctx key = do > let conn = ctxConn ctx > exists <- query conn "SELECT 1 FROM journal WHERE key=?" (Only key) > :: IO [Only Int] > case exists of > [] -> textPage ["no journal here."] > _ -> do > today <- todayDay > tasks <- query conn > (Query ("SELECT " <> fromQuery taskCols <> > " FROM task WHERE jkey=? AND state<>'trashed' ORDER BY day ASC, id ASC")) > (Only key) :: IO [Task] > habits <- query conn "SELECT id, name, target FROM habit WHERE jkey=? ORDER BY id" > (Only key) :: IO [(Int, T.Text, Int)] > allChecks <- query conn "SELECT hid, day FROM hcheck WHERE jkey=?" > (Only key) :: IO [(Int, T.Text)] > counters <- query conn "SELECT id, name, polarity FROM counter WHERE jkey=? ORDER BY id" > (Only key) :: IO [(Int, T.Text, T.Text)] > cticks <- query conn "SELECT cid, day, n FROM counter_tick WHERE jkey=? AND n>0" > (Only key) :: IO [(Int, T.Text, Int)] > timers <- query conn "SELECT id, name FROM timer WHERE jkey=?" > (Only key) :: IO [(Int, T.Text)] > tdone <- query conn "SELECT tid, day, started, completed FROM timer_done WHERE jkey=?" > (Only key) :: IO [(Int, T.Text, Integer, Integer)] > -- done tasks indexed by the day they were MARKED done (the > -- @updated@ column), not the day they were filed (@day@). For > -- "busiest day" --- which day did you actually close the most. > doneByUpdated <- query conn > "SELECT updated, COUNT(*) FROM task\ > \ WHERE jkey=? AND state='done' GROUP BY updated" > (Only key) :: IO [(T.Text, Int)] > let gut = T.replicate 11 " " > timerName tid = fromMaybe "(unknown)" (lookup tid timers) > nfield s = T.justifyLeft 16 ' ' s > -- the habit grid for one month: only habits with a check > -- that month, cells filled from history (no "today" glyph). > habitGrid m = > let n = daysInMonth m > fdow = firstDow m > (tens, units) = gridHead fdow n > doms hid = [ domOf d | (h, d) <- allChecks, h == hid, monthOf d == m ] > here = [ (hid, name, target) | (hid, name, target) <- habits, not (null (doms hid)) ] > in if null here then [] > else "habits:" : (gut <> tens) : (gut <> units) > : [ T.justifyLeft 11 ' ' (clamp 10 name) <> cells fdow n target 0 (doms hid) > | (hid, name, target) <- here ] ++ [""] > -- per-timer focus breakdown for the month: each timer that > -- had any session, sorted by total time desc. Lets you see > -- where the month's hours actually went, not one rolled-up > -- sum. Renders nothing for months with no timer activity. > focusLines m = > let inM = [ (tid, c - s) | (tid, d, s, c) <- tdone, monthOf d == m ] > blocks = length inM > tids = map head . group . sort $ map fst inM > perTid = [ (timerName tid', sum [ sec | (tid, sec) <- inM, tid == tid' ]) > | tid' <- tids ] > sorted = sortOn (negate . snd) perTid > pieces = [ nm <> " " <> fmtMin (fromInteger sec `div` 60) > | (nm, sec) <- sorted ] > in if null pieces then [] > else [ " focus " <> T.intercalate " . " pieces > <> " (" <> plural blocks "block" <> ")" ] > -- the arc of the month in one task line: what came in, what > -- settled how, what's going out. Zero fragments hide. > totalsBlock m mtasks = > let doneN = length (filter ((== "done") . tState) mtasks) > lapsedN = length (filter ((== "lapsed") . tState) mtasks) > carriedN = length (filter ((== "migrated") . tState) mtasks) > inheritedN = length [ () | t <- mtasks, tCarries t > 0 ] > parts = [ tshow n <> " " <> lbl > | (n, lbl) <- [ (inheritedN, "inherited") > , (doneN, "done") > , (lapsedN, "lapsed") > , (carriedN, "carried forward") ] > , n > 0 ] > taskLine = if null parts then [] > else [ " tasks " <> T.intercalate " . " parts ] > fLines = focusLines m > body = taskLine ++ fLines > in if null body then [] else "totals:" : body ++ [""] > -- the delight layer: specific dates and named winners for > -- the month. Each line elides if it has no data, the whole > -- block elides if all three do. > notableBlock m = > let -- best focus day: argmax of total session seconds per day in m > sessionsM = [ (d, c - s) | (_, d, s, c) <- tdone, monthOf d == m ] > perDay = [ (d, sum [ sec | (d', sec) <- sessionsM, d' == d ]) > | d <- map head . group . sort $ map fst sessionsM ] > bestFocus = case sortOn (negate . snd) perDay of > ((d, sec) : _) | sec > 0 -> > [ " " <> nfield "best focus day" <> dayLabel d > <> " . " <> fmtMin (fromInteger sec `div` 60) ] > _ -> [] > -- longest single session: max (completed - started) with timer name > sessions = [ (d, tid, c - s) | (tid, d, s, c) <- tdone, monthOf d == m ] > longest = case sortOn (\(_, _, sec) -> negate sec) sessions of > ((d, tid, sec) : _) | sec > 0 -> > [ " " <> nfield "longest stretch" <> dayLabel d > <> " . " <> timerName tid > <> " . " <> fmtMin (fromInteger sec `div` 60) ] > _ -> [] > -- busiest day: which day in m closed the most tasks (by > -- updated, not filed). Comes from the dedicated query so > -- we don't conflate "day filed" with "day done." > doneInM = [ (d, n) | (d, n) <- doneByUpdated, monthOf d == m ] > busiest = case sortOn (negate . snd) doneInM of > ((d, n) : _) | n > 0 -> > [ " " <> nfield "busiest day" <> dayLabel d > <> " . " <> tshow n <> " tasks closed" ] > _ -> [] > lines_ = bestFocus ++ longest ++ busiest > in if null lines_ then [] else "of note:" : lines_ ++ [""] > -- each counter's total for the month (only those used that month). > counterBlock m = > let here = [ (name, pol, t) > | (cid, name, pol) <- counters > , let t = sum [ n | (c, d, n) <- cticks, c == cid, monthOf d == m ] > , t > 0 ] > in if null here then [] > else "counters:" > : [ T.justifyLeft 11 ' ' (clamp 10 name) <> counterShow pol t > | (name, pol, t) <- here ] ++ [""] > monthBlock m = > let mtasks = filter ((== m) . monthOf . tDay) tasks > days = groupBy ((==) `on` tDay) mtasks > dayBlock dg = ("== " <> dayLabel (tDay (head dg)) <> " ==") > : map ((" " <>) . taskLine) dg ++ [""] > in ("======== " <> monthLabel m <> " ========") : "" > : (concatMap dayBlock days ++ habitGrid m > ++ totalsBlock m mtasks > ++ notableBlock m > ++ counterBlock m) > -- every month with a task, habit check, counter tick OR timeblock, > -- oldest first --- so a month with only tracker data still exports. > months = map head . group . sort $ > map (monthOf . tDay) tasks ++ map (monthOf . snd) allChecks > ++ map (\(_, d, _) -> monthOf d) cticks > ++ map (\(_, d, _, _) -> monthOf d) tdone > textPage $ > [ " my bujo --- exported " <> today, "" ] > ++ (if null months then ["(empty)"] else concatMap monthBlock months) > > -- | The diary's fixed artifact width. A touch under the classic ~64 so > -- the framed masthead never overflows a narrow client. > diaryW :: Int > diaryW = 60 > > -- | Centre a line within the diary width using leading padding only, so > -- no trailing whitespace ever creeps into the artifact. > diaryCenter :: T.Text -> T.Text > diaryCenter t = T.replicate (max 0 ((diaryW - T.length t) `div` 2)) " " <> t > > -- | A short, centred dashed rule that sets off each month. > diaryRule :: T.Text > diaryRule = diaryCenter (T.unwords (replicate 24 "-")) > > -- | The framed title block --- the one piece of ornament, page-scale, > -- pure ASCII so it reads on any client and never competes with a memory. > diaryMasthead :: [T.Text] > diaryMasthead = [ top, side, bar "M Y D I A R Y", side, top ] > where > inner = diaryW - 2 > top = "+" <> T.replicate inner "=" <> "+" > side = "|" <> T.replicate inner " " <> "|" > bar t = let pad = max 0 (inner - T.length t); l = pad `div` 2 > in "|" <> T.replicate l " " <> t <> T.replicate (pad - l) " " <> "|" > > -- | Notes only, oldest first --- the journal read as a diary worth > -- keeping: a framed masthead, a "kept since / N memories" frontispiece, > -- months set off by a centred rule, every memory wrapped with room to > -- breathe, and a quiet colophon. Pure prose (no tasks, no habits), > -- gopher item type 0. The full backup lives at /txt; this is the keepsake. > exportNotes :: Ctx -> T.Text -> IO () > exportNotes ctx key = do > let conn = ctxConn ctx > exists <- query conn "SELECT 1 FROM journal WHERE key=?" (Only key) :: IO [Only Int] > case exists of > [] -> textPage ["no journal here."] > _ -> do > today <- todayDay > created <- maybe today fromOnly . listToMaybe <$> > (query conn "SELECT created FROM journal WHERE key=?" (Only key) :: IO [Only T.Text]) > notes <- query conn > "SELECT body, day FROM task WHERE jkey=? AND state='note' ORDER BY day ASC, id ASC" > (Only key) :: IO [(T.Text, T.Text)] > let n = length notes > memoryWord = if n == 1 then "memory" else "memories" > frontispiece = > [ "", diaryCenter ("kept since " <> monthLabel (monthOf created) > <> " " <> tshow n <> " " <> memoryWord), "", "" ] > memoryLines (body, _) = map (" " <>) (wrapTo (diaryW - 4) body) ++ [""] > dayBlock dg = (" " <> dayLabel (snd (head dg))) : concatMap memoryLines dg > monthBlock mg = > "" : diaryRule : diaryCenter (monthLabel (monthOf (snd (head mg)))) : "" > : concatMap dayBlock (groupBy ((==) `on` snd) mg) > months = groupBy ((==) `on` (monthOf . snd)) notes > textPage $ > diaryMasthead > ++ (if null notes > then [ "", diaryCenter "(no memories yet)", "" > , diaryCenter "jot one in your journal with a '-' prefix." ] > else frontispiece ++ concatMap monthBlock months > ++ [ "", diaryRule, "", diaryCenter ("exported " <> today) ]) Your stats (/stats) ------------------- An honest, scannable dashboard --- real numbers to check in on and keep yourself accountable, each with a one-line plain-English explanation. It is read-only (counts rows, never writes), so it adds no daily friction and can never lose data. Two design choices for an ADHD brain: engagement (showing up) is the headline, not completion; and every fragile number (the streak) is paired with a resilient one (consistency ratios) so a single missed day never zeroes you out. > data Stats = Stats > { stStreak :: Int -- forgiving current streak (days) > , stGrace :: Int -- grace days the streak has leaned on > , stLongest :: Int -- best-ever consecutive run (never drops) > , stActive7 :: Int -- active days in the last 7 > , stActive14 :: Int -- active days in the last 14 (grade window) > , stActivePrev7 :: Int -- active days in the 7 before the last 7 > , stActive30 :: Int -- active days in the last 30 > , stCreated :: T.Text -- journal birth date > , stDaysKept :: Int -- calendar days since creation > , stActiveDays :: Int -- distinct days you did anything > , stWeeksKept :: Int -- calendar weeks since creation (>=1) > , stDoneToday :: Int > , stDoneWeek :: Int -- completed in the last 7 days > , stDoneRecent :: Int -- completed in the last 30 days (grade) > , stAddWeek :: Int -- added in the last 7 days > , stFiledDone :: Int -- of tasks filed this month, how many done > , stMonthTot :: Int -- taken on this month (done+open+dropped) > , stLingering :: Int -- open tasks carried >=1 (outlived a month) > , stBestDay :: Int -- most ever completed in one day > , stBestDate :: T.Text > , stDoneAll :: Int -- lifetime completed > , stAddAll :: Int -- lifetime added (first appearances, no carries) > , stImpDone :: Int -- important done this month > , stImpDoneToday :: Int -- important done today > , stImpTot :: Int -- important open+done this month > , stStale :: Int -- important + open + carried 2+ times > , stStaleBody :: T.Text -- the worst offender > , stStaleCarr :: Int > , stOpenNow :: Int > , stOldestAge :: Int -- age in days of the oldest open task > , stOldestBody :: T.Text > , stHabits :: Int -- active (non-archived) habit count > , stHabitScore :: Int -- 0--100 recent habit completion > } > > statsView :: Ctx -> T.Text -> IO () > statsView ctx key = do > let conn = ctxConn ctx > ex <- query conn "SELECT 1 FROM journal WHERE key=?" (Only key) :: IO [Only Int] > case ex of > [] -> notFound ctx > _ -> do > today <- todayDay > s <- gatherStats conn key (monthOf today) today > hs <- gatherHabitStats conn key today > f <- gatherFocus conn key today > tas <- gatherTimerAverages conn key > crs <- gatherCounterRecs conn key today > h <- localHour > let garden = gardenLines (gatherGarden s hs f crs h) > page ctx (garden ++ [infoLine ""] ++ > renderStats s ++ > renderHabitStats hs ++ > renderFocusStats f tas ++ > [ infoLine "" > , link ctx "your hiscores (personal bests)" ("/k/" <> key <> "/hiscores") > , link ctx "back to the journal" ("/k/" <> key) ]) > > -- | All the read-only counts and dates the dashboard needs, in one > -- place. Activity dates (filing or acting on a task) drive streaks; > -- everything else is a scoped COUNT. > gatherStats :: Connection -> T.Text -> T.Text -> T.Text -> IO Stats > gatherStats conn key real today = do > let n q p = do rs <- query conn q p :: IO [Only Int] > pure (maybe 0 fromOnly (listToMaybe rs)) > c7 = shiftDay (-6) today > c14 = shiftDay (-13) today > c30 = shiftDay (-29) today > created <- maybe today fromOnly . listToMaybe <$> > (query conn "SELECT created FROM journal WHERE key=?" (Only key) :: IO [Only T.Text]) > adays <- query conn > "SELECT day FROM task WHERE jkey=?\ > \ UNION SELECT updated FROM task WHERE jkey=? AND state IN ('done','dropped','migrated')" > (key, key) :: IO [Only T.Text] > doneToday <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='done' AND updated=?" (key, today) > doneWeek <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='done' AND updated>=?" (key, c7) > doneRec <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='done' AND updated>=?" (key, c30) > addWeek <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND carries=0\ > \ AND state NOT IN ('note','trashed') AND day>=?" (key, c7) > -- cohort-consistent monthly rate: numerator and denominator both > -- key off the filing month, so the rate can never exceed 100%. > filedDone <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND substr(day,1,7)=? AND state='done'" (key, real) > monthTot <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND substr(day,1,7)=? AND state IN ('open','done','dropped')" (key, real) > linger <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='open' AND carries>=1" (Only key) > doneAll <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='done'" (Only key) > addAll <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND carries=0 AND state<>'note'" (Only key) > impDone <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND substr(day,1,7)=? AND state='done' AND important=1" (key, real) > impDoneT <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='done' AND important=1 AND updated=?" (key, today) > impTot <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND substr(day,1,7)=? AND important=1 AND state IN ('open','done')" (key, real) > openNow <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='open'" (Only key) > stale <- n "SELECT COUNT(*) FROM task WHERE jkey=? AND state='open' AND important=1 AND carries>=2" (Only key) > best <- query conn > "SELECT updated, COUNT(*) FROM task WHERE jkey=? AND state='done'\ > \ GROUP BY updated ORDER BY 2 DESC, updated DESC LIMIT 1" (Only key) :: IO [(T.Text, Int)] > oldest <- query conn > "SELECT day, body FROM task WHERE jkey=? AND state='open' ORDER BY day ASC, id ASC LIMIT 1" > (Only key) :: IO [(T.Text, T.Text)] > staleW <- query conn > "SELECT body, carries FROM task WHERE jkey=? AND state='open' AND important=1 AND carries>=2\ > \ ORDER BY carries DESC, id ASC LIMIT 1" (Only key) :: IO [(T.Text, Int)] > habits <- query conn "SELECT id, created, target FROM habit WHERE jkey=? AND archived=0" > (Only key) :: IO [(Int, T.Text, Int)] > hchecks <- query conn > "SELECT hid, COUNT(*) FROM hcheck WHERE jkey=? AND day>=? GROUP BY hid" > (key, c14) :: IO [(Int, Int)] > let dates = map fromOnly adays > ords = mapMaybe dayNum dates > (streak, grace) = maybe (0, 0) (`currentStreak` ords) (dayNum today) > daysKept = daysBetween created today + 1 > (bestDate, bestN) = case best of ((d, c) : _) -> (d, c); _ -> ("", 0) > (oldBody, oldDay) = case oldest of ((d, b) : _) -> (b, d); _ -> ("", "") > (stBody, stCarr) = case staleW of ((b, c) : _) -> (b, c); _ -> ("", 0) > -- average per-habit completion over the last 14 days, measured > -- against each habit's own weekly target (so a 4x/week habit done > -- 4x scores 100%, not 4/7) and normalised to its own age > hRate (hid, hcreated, htarget) = > let age = max 1 (min 14 (daysBetween hcreated today + 1)) > expected = max 1 (htarget * age `div` 7) > in min 100 (fromMaybe 0 (lookup hid hchecks) * 100 `div` expected) > habitScore | null habits = 0 > | otherwise = sum (map hRate habits) `div` length habits > pure Stats > { stStreak = streak, stGrace = grace, stLongest = longestStreak ords > , stActive7 = length (filter (>= c7) dates) > , stActive14 = length (filter (>= c14) dates) > , stActivePrev7 = length (filter (\d -> d >= c14 && d < c7) dates) > , stActive30 = length (filter (>= c30) dates) > , stCreated = created, stDaysKept = daysKept > , stActiveDays = length dates, stWeeksKept = max 1 (daysKept `div` 7) > , stDoneToday = doneToday, stDoneWeek = doneWeek, stDoneRecent = doneRec > , stAddWeek = addWeek, stFiledDone = filedDone, stMonthTot = monthTot > , stLingering = linger > , stBestDay = bestN, stBestDate = bestDate > , stDoneAll = doneAll, stAddAll = addAll > , stImpDone = impDone, stImpDoneToday = impDoneT, stImpTot = impTot > , stStale = stale, stStaleBody = stBody, stStaleCarr = stCarr > , stOpenNow = openNow > , stOldestAge = if T.null oldDay then 0 else daysBetween oldDay today > , stOldestBody = oldBody > , stHabits = length habits, stHabitScore = habitScore > } > > -- | The stats screen's fixed content width (classic gopher ~70 cols). > statsW :: Int > statsW = 64 > > -- | Pure TOC-style row content: label on the left, value on the > -- right, leader dots between, padded to exactly @statsW@ characters. > -- Drops the dots if the line would overflow (caller's job to keep > -- values short enough). @ind@ is the left indent for the label. > -- > -- >>> T.length (tocRowAt 2 (T.pack "streak") (T.pack "0 days")) > -- 64 > -- > -- >>> T.length (tocRowAt 4 (T.pack "best week") (T.pack "5 . wk of may 18")) > -- 64 > tocRowAt :: Int -> T.Text -> T.Text -> T.Text > tocRowAt ind label value = > let prefix = T.replicate ind " " <> label <> " " > suffix = " " <> value > gap = statsW - T.length prefix - T.length suffix > in if gap < 1 then prefix <> suffix > else prefix <> T.replicate gap "." <> suffix > > tocRow :: T.Text -> T.Text -> T.Text > tocRow = tocRowAt 2 > > -- | A TOC-style metric line ready to ship: leader dots between label > -- and value, wrapped in 'infoLine'. One fact per line; numbers stack > -- vertically because every value lands at the same column. > metricTOC :: T.Text -> T.Text -> [T.Text] > metricTOC l v = [infoLine (tocRow l v)] > > -- | A TOC-style sub-metric: extra indent for nesting under a group > -- header (e.g. one counter's records nested under its name). > subMetricTOC :: T.Text -> T.Text -> [T.Text] > subMetricTOC l v = [infoLine (tocRowAt 4 l v)] > > -- | The key holding the smallest value, or a default if empty. > -- Mirror of 'argmaxBy' for "quietest" records. > -- > -- >>> argminBy (T.pack "?") [(T.pack "a",2),(T.pack "c",5),(T.pack "b",3)] > -- "a" > argminBy :: T.Text -> [(T.Text, Int)] -> T.Text > argminBy def [] = def > argminBy _ xs = fst (foldl1 (\a@(_,ma) b@(_,mb) -> if mb < ma then b else a) xs) > > -- | A short anchor label for a period record: @"wk of mon, may 18"@, > -- @"may 2026"@, or @"fri, may 22"@ depending on the counter's window. > periodAnchor :: T.Text -> T.Text -> T.Text > periodAnchor period d = case period of > "week" -> "wk of " <> dayLabel d > "month" -> monthLabel d > _ -> dayLabel d > > -- | A spartan framed block: @statsW@ equals signs above and below, > -- the given lines centered between them. Sets visual hierarchy on the > -- review pages without webby chrome. Widths are computed by > -- 'T.center'/'T.replicate', never eyeballed. Each output line is > -- already wrapped in 'infoLine' so the block speaks gopher protocol. > framedTitle :: [T.Text] -> [T.Text] > framedTitle xs = > infoLine (T.replicate statsW "=") > : map (infoLine . T.center statsW ' ') xs > ++ [infoLine (T.replicate statsW "=")] > > -- | Like 'framedTitle' but drops the top rule, used when the line > -- above is already a divider (e.g. the garden's ground line under > -- the @/stats@ grade block --- one rule, not two). > framedFloor :: [T.Text] -> [T.Text] > framedFloor xs = > map (infoLine . T.center statsW ' ') xs > ++ [infoLine (T.replicate statsW "=")] > > -- | A flower kind. Each is a hand-tuned multi-row tile shown at full > -- bloom; earlier growth phases truncate the tile from the top. > data FlowerKind = Oak | Pine | Cairn | Cattail deriving (Eq, Show) > > -- | Inputs to the garden above the grade frame. Five flower slots, each > -- a (kind, phase 0-5); a clock for sun position; a flag for the cloud > -- when stale stars are weighing on you; a flag for a duck visiting the > -- pond at high grades. No new schema --- every value derives from data > -- already gathered elsewhere on the page. > data GardenInputs = GardenInputs > { giHour :: Int -- 0-23 local > , giStaleStars :: Int -- >0 -> cloud overhead > , giFlowers :: [(FlowerKind, Int)] -- one per slot, phase 0-5 > , giCattailPhase :: Int -- focus-today, 0-5 > , giHasDuck :: Bool -- True -> duck visits the pond > } deriving (Show, Eq) > > -- | The duck tile as @(rowOffset, colOffset, char)@ triples anchored > -- at the duck's chest. Feet are intentionally omitted so the pond > -- water shows underneath (duck floats, not stands). When awake the > -- head faces right with bill sticking out (@(')<@). When asleep the > -- head is turned 180 degrees so the bill rests on its back (@>(-)@), > -- which is how ducks actually sleep --- head tucked backwards over > -- the wing. The body stays facing right both ways; only the head > -- swivels. > duckTile :: Bool -> [(Int, Int, Char)] > duckTile True = -- asleep > [ (0, 0, '_') -- crown above closed eye > , (1, -1, '('), (1, 0, '-'), (1, 1, ')'), (1, 2, '=') -- head curled in, aligned with body > , (2, -1, '('), (2, 0, '@'), (2, 2, ')') -- body --- ( and ) stack directly under head's ( and = > ] > duckTile False = -- awake > [ (0, 1, '_') -- crown above eye > , (1, 0, '('), (1, 1, '\''), (1, 2, ')'), (1, 3, '<') -- head looking right, bill out > , (2, -1, '('), (2, 0, '@'), (2, 2, ')') -- body > ] > > -- | Write a single character at @(row, col)@ in the grid. > writeCell :: Int -> Int -> Char -> [T.Text] -> [T.Text] > writeCell r c ch grid = > [ if i == r > then T.take c row <> T.singleton ch <> T.drop (c + 1) row > else row > | (i, row) <- zip [0 ..] grid > ] > > -- | Place an offset-tile at @(topRow, anchorCol)@ into the grid. > placeOffsetTile :: Int -> Int -> [(Int, Int, Char)] > -> [T.Text] -> [T.Text] > placeOffsetTile topRow anchorCol tile grid = > foldl (\g (dr, dc, ch) -> > let r = topRow + dr > c = anchorCol + dc > in if r >= 0 && r < length g && c >= 0 && c < statsW > then writeCell r c ch g else g) > grid tile > > -- | Full-bloom tile for each garden kind. Plants are taken from the > -- @flowers.txt@ motifs; the cairn is a stack of stones with a wide > -- @( )@ foundation. Bottom row anchors at the slot column. Earlier > -- phases drop top rows (5 = full, 1 = just the base, 0 = nothing). > flowerTile :: FlowerKind -> [T.Text] > flowerTile Oak = [" @@@@ ", "@@@@@@", " @@@@ ", " \\|/ ", " | "] > flowerTile Pine = [" ^ ", " ^^^ ", "^^^^^", " | ", " | "] > flowerTile Cairn = [" . ", " , ", " * ", " O ", "( )"] > flowerTile Cattail = [" . ", " 0 ", " | ", " | "] > > -- | Truncate a tile to the given phase. Phase 0 = empty (no flower), > -- phase 1 = bare stem only, phase 5 = full tile. > atPhase :: Int -> [T.Text] -> [T.Text] > atPhase phase tile > | phase <= 0 = [] > | phase >= length tile = tile > | otherwise = drop (length tile - phase) tile > > -- | Force a row to exactly statsW characters (truncate then pad). > fitRow :: T.Text -> T.Text > fitRow = T.justifyLeft statsW ' ' . T.take statsW > > -- | Overlay glyphs at @col@ onto a row, skipping spaces in the glyph > -- string (so multi-glyph tiles don't erase what's already there). > overlayAt :: Int -> T.Text -> T.Text -> T.Text > overlayAt col glyphs row = > T.pack [ let here = col <= i && i < col + T.length glyphs > gch = if here then T.index glyphs (i - col) else ' ' > in if here && gch /= ' ' then gch else T.index row i > | i <- [0 .. statsW - 1] ] > > -- | Place a tile (multi-row, centered on @anchorCol@, bottom row at > -- @anchorRow@) into the rolling grid. > placeTile :: Int -> Int -> [T.Text] -> [T.Text] -> [T.Text] > placeTile anchorRow anchorCol tile grid = > let n = length tile > startRow = anchorRow - (n - 1) > indexed = zip [startRow .. anchorRow] tile > in [ case lookup r indexed of > Just line -> > let w = T.length line > start = anchorCol - (w `div` 2) > in overlayAt start line g > Nothing -> g > | (r, g) <- zip [0..] grid ] > > -- | Compose the sky row: sun by hour during daylight (moves left to > -- right across 6am-6pm), scattered stars at night, or a cloud if > -- stale stars are weighing on you (cloud wins). > skyRow :: GardenInputs -> T.Text > skyRow gi > | giStaleStars gi > 0 = overlayAt 6 "_~~_" empty > | h >= 6 && h < 18 = > let frac = fromIntegral (h - 6) / 12.0 :: Double > col = max 1 (min (statsW - 3) (round (frac * fromIntegral (statsW - 4)))) > in overlayAt (col - 1) "(O)" empty > | otherwise = foldl (\r (c, g) -> overlayAt c g r) empty > [(4,"."),(17,"*"),(28,"."),(39,","),(51,"*"),(60,".")] > where > h = giHour gi > empty = T.replicate statsW " " > > -- | The flower slot anchor columns across the @statsW@ canvas. Slot 3 > -- (col 30) was dropped after the lily was removed; the duck still > -- floats at col 31 when it visits. > slotCols :: [Int] > slotCols = [6, 18, 42, 54] > > -- | The ground row: carrots `^^^^` with a 20-char pond `~~~~` (cols > -- 22-41). The pond starts left-of-center under the cattail cluster > -- (so the reeds stand IN the shallows like real cattails) and stops > -- short of the right-side cairn at col 42 (so the cairn stands on > -- dry ground, not over water). > groundWithPond :: T.Text > groundWithPond = T.pack > [ if i >= 22 && i < 42 then '~' else '^' | i <- [0 .. statsW - 1] ] > > -- | The whole garden: always 7 rows of exactly statsW characters. > -- Row 0 is sky, rows 1-5 hold the plant bodies (bottom stem on row 5), > -- row 6 is the ground line with the pond. When a duck visits (high > -- grade), the middle slot is hidden and the duck floats on the pond > -- there instead --- asleep when it's dark out. > -- > -- >>> map T.length (gardenOf (GardenInputs 12 0 [(Pine,5),(Oak,5),(Cairn,5),(Oak,5)] 5 False)) > -- [64,64,64,64,64,64,64] > -- > -- >>> last (gardenOf (GardenInputs 12 0 [(Pine,0),(Oak,0),(Cairn,0),(Oak,0)] 0 False)) > -- "^^^^^^^^^^^^^^^^^^^^^^~~~~~~~~~~~~~~~~~~~~^^^^^^^^^^^^^^^^^^^^^^" > gardenOf :: GardenInputs -> [T.Text] > gardenOf gi = > let empty = T.replicate statsW " " > blank = [skyRow gi, empty, empty, empty, empty, empty, groundWithPond] > placeOne grid ((kind, phase), col) = > placeTile 5 col (atPhase phase (flowerTile kind)) grid > withFlowers = foldl placeOne blank (zip (giFlowers gi) slotCols) > -- cattail CLUSTER at the pond's shallow left edge (cols 22, 24, > -- 26 --- all in water now that the pond is bigger). All three > -- reeds grow with the same focus-today phase: more focus, taller > -- patch; no focus, no cattails. > cattailPhase = giCattailPhase gi > cattailTile = atPhase cattailPhase (flowerTile Cattail) > withCattails = placeTile 5 22 cattailTile > $ placeTile 5 24 cattailTile > $ placeTile 5 26 cattailTile > $ withFlowers > -- duck sleeps at night, head curled in with bill on its back; > -- it also drifts toward the cattail cluster at night, nestled > -- against the reeds for shelter. By day it floats centered. > asleep = giHour gi < 6 || giHour gi >= 18 > duckCol = if asleep then 28 else 32 > in if giHasDuck gi > then placeOffsetTile 3 duckCol (duckTile asleep) withCattails > else withCattails > > -- | The garden ready to ship: each row wrapped in 'infoLine'. > gardenLines :: GardenInputs -> [T.Text] > gardenLines = map infoLine . gardenOf > > -- | Current local hour (0-23). Uses the server's local zone, the same > -- zone 'todayDay' uses, so the sun's position matches the calendar day. > localHour :: IO Int > localHour = do > now <- nowEpoch > tz <- getCurrentTimeZone > let utcHour = fromIntegral ((now `mod` 86400) `div` 3600) :: Int > offsetH = timeZoneMinutes tz `div` 60 > pure ((utcHour + offsetH + 24) `mod` 24) > > -- | Translate stats into the five flower phases. Each slot maps to a > -- domain of your life; the phase scales with how that domain is doing > -- this week / today. Phase 5 is celebratory (full bloom); phase 0 is > -- nothing yet (bare ground). > gardenFlowers :: Stats -> HabitStats -> Focus -> [CounterRec] > -> [(FlowerKind, Int)] > gardenFlowers s hs f crs = > let phaseClamp = max 0 . min 5 > habitPhase = phaseClamp (hsWeekDone hs `div` 3) -- 3 checks/wk = +1 > taskPhase = phaseClamp (stDoneWeek s `div` 3) -- 3 done/wk = +1 > budsCount = length [ () | cr <- crs, crPol cr == "neg", crZeroRun cr > 0 ] > counterPh = phaseClamp budsCount -- 1 clean streak = +1 > streakPh = phaseClamp (stStreak s) -- 1 day streak = +1 > in [ (Pine, habitPhase) > , (Oak, taskPhase) > , (Cairn, counterPh) > , (Oak, streakPh) > ] > > -- | Gather garden inputs from already-computed stats. No schema change. > -- The duck flag fires when overall grade is A- or higher (letter starts > -- with 'A'); warming counts as no duck. > gatherGarden :: Stats -> HabitStats -> Focus -> [CounterRec] > -> Int -> GardenInputs > gatherGarden s hs f crs h = > let gi = GradeIn (stDaysKept s) (stActiveDays s) (stActive14 s) > (stActive7 s) (stActivePrev7 s) (stDoneRecent s) > (stLingering s) (stStale s) (stHabits s) (stHabitScore s) > hasDuck = case overallGrade gi of > Graded l _ _ _ _ _ _ -> case T.uncons l of > Just ('A', _) -> True > _ -> False > _ -> False > focusPhase = max 0 (min 5 (fcToday f `div` 30)) -- 30 min today = +1 > in GardenInputs > { giHour = h > , giStaleStars = stStale s > , giFlowers = gardenFlowers s hs f crs > , giCattailPhase = focusPhase > , giHasDuck = hasDuck > } > > -- | A labelled metric line, value word-wrapped to width with a hanging > -- indent under the value column. > metric :: T.Text -> T.Text -> [T.Text] > metric label value = case wrapTo (statsW - 14) value of > [] -> [ infoLine (" " <> T.justifyLeft 12 ' ' label) ] > (x : xs) -> infoLine (" " <> T.justifyLeft 12 ' ' label <> x) > : map (infoLine . (T.replicate 14 " " <>)) xs > > -- | An indented explanation line, word-wrapped to width. > note :: T.Text -> [T.Text] > note t = map (infoLine . (T.replicate 5 " " <>)) (wrapTo (statsW - 5) t) > > -- | A full-width section divider: "== showing up ===========...". > divider :: T.Text -> T.Text > divider s = infoLine (T.justifyLeft statsW '=' ("== " <> s <> " ")) > > -- | Render the dashboard (pure): a grade headline with a full-width > -- standing bar, then labelled metrics + plain-English notes, all kept > -- within 'statsW' columns. > renderStats :: Stats -> [T.Text] > renderStats s > | stActiveDays s == 0 = > gradeBlock ++ [ infoLine "", infoLine " nothing logged yet --- add a task to begin." ] > | otherwise = gradeBlock ++ [ infoLine "" ] ++ dashboard > where > gi = GradeIn (stDaysKept s) (stActiveDays s) (stActive14 s) (stActive7 s) > (stActivePrev7 s) (stDoneRecent s) (stLingering s) (stStale s) > (stHabits s) (stHabitScore s) > gradeBlock = case overallGrade gi of > Warming d -> > framedFloor > [ "warming up" > , "[" <> barW 30 (min 7 (stDaysKept s)) 7 <> "]" > , plural d "more day" > ] > ++ note "the grade unlocks after about a week of use." > Graded l sc tr str act gap nx -> > framedFloor > [ l <> " . " <> stateWord sc > , "[" <> barW 30 sc 100 <> "] " <> tshow sc <> "%" > , tr <> gapTxt gap nx > ] > ++ note ("strongest: " <> str) > ++ note ("biggest win: " <> act) > gapTxt gap nx > | T.null nx = " top grade" > | otherwise = " " <> tshow gap <> "% to " <> nx > -- denominators cap at days available, so a young journal reads > -- "4 of 5", not an unfair "4 of 30 (13%)". > wk = min 7 (stDaysKept s) > mo = min 30 (stDaysKept s) > a7 = min wk (stActive7 s) -- can't be active more days than elapsed > a30 = min mo (stActive30 s) > showLast30 = stDaysKept s >= 14 > showMonth = stDaysKept s >= 14 > showPaceWk = stWeeksKept s > 1 > dashboard = concat > [ [ divider "showing up" ] > , metricTOC "streak" (plural (stStreak s) "day") > , metricTOC "this week" (tshow a7 <> " of " <> tshow wk <> " days") > , if showLast30 > then metricTOC "last 30" (tshow a30 <> " of " <> tshow mo <> " days") > else [] > , metricTOC "kept since" (dayLabel (stCreated s)) > , note "one skip a week is forgiven; a slip never zeroes you out." > , [ infoLine "" ] > , [ divider "getting done" ] > , metricTOC "today done" (tshow (stDoneToday s)) > , metricTOC "this week done" (tshow (stDoneWeek s)) > , metricTOC "this week added" (tshow (stAddWeek s)) > , metricTOC "this week flow" flow > , if showMonth > then metricTOC "this month" > (tshow (stFiledDone s) <> " of " <> tshow (stMonthTot s)) > else [] > , metricTOC "pace per day" (avg1 (stDoneAll s) (stActiveDays s) <> " done") > , if showPaceWk > then metricTOC "pace per week" (avg1 (stDoneAll s) (stWeeksKept s) <> " done") > else [] > , metricTOC "best day" bestDayValue > , [ infoLine "" ] > , [ divider "what matters" ] > , metricTOC "today important done" (tshow (stImpDoneToday s)) > , metricTOC "important done this month" > (tshow (stImpDone s) <> " of " <> tshow (stImpTot s)) > , if stStale s > 0 > then metricTOC "stale stars" (tshow (stStale s)) > else [] > , metricTOC "open now" openNowValue > , oldestLine > , note "the things you said matter; oldest = longest-untouched." > ] > -- the open count looks scary until you see how little is actually > -- carried over (the rest is this month's fresh capture, which the > -- monthly migrate lapses cleanly) --- so show the split, no nagging. > openNowValue > | stLingering s > 0 = tshow (stOpenNow s) <> " . " > <> tshow (stLingering s) <> " carried over" > | otherwise = tshow (stOpenNow s) > flow = let done = stDoneWeek s > added = stAddWeek s > in if added <= 0 > then if done > 0 then "100%" else "---" > else tshow (pct done added) <> "% done of added" > bestDayValue > | stBestDay s == 0 = "---" > | otherwise = plural (stBestDay s) "task" <> " . " <> dayLabel (stBestDate s) > oldestLine > | stOldestAge s <= 0 = [] > | otherwise = metricTOC "oldest open" > (plural (stOldestAge s) "day" <> " . " <> clamp 24 (stOldestBody s)) The habit stats (the @== habits ==@ section of /stats) ------------------------------------------------------ Encouraging, never-shaming habit numbers: aggregates and ever-growing records up top, then a leaderboard of last-30-day completion (each vs its own goal). The bottom group is "show love", not "worst"; an "on the rise" line rewards the most-improved habit regardless of its level. > data HabitStats = HabitStats > { hsCount :: Int > , hsWeekDone :: Int -- checks this week (active habits) > , hsWeekGoal :: Int -- sum of weekly targets > , hsOnPace :: Int -- habits on pace this week > , hsLifetime :: Int -- checks all-time (incl archived) > , hsBestDay :: Int -- most habits ticked in one day > , hsBestWeek :: Int -- most checks in one week > , hsRanked :: [(T.Text, Int)] -- active habits, name + 30d rate, best first > , hsRising :: T.Text -- most-improved active habit ("" = none) > } > > gatherHabitStats :: Connection -> T.Text -> T.Text -> IO HabitStats > gatherHabitStats conn key today = do > let n q p = do rs <- query conn q p :: IO [Only Int] > pure (maybe 0 fromOnly (listToMaybe rs)) > c30 = shiftDay (-29) today > c60 = shiftDay (-59) today > tdow = weekdayOf today > weekStart = shiftDay (negate (tdow - 1)) today > habits <- query conn > "SELECT id, name, target, created FROM habit WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, Int, T.Text)] > chk30 <- query conn "SELECT hid, COUNT(*) FROM hcheck WHERE jkey=? AND day>=? GROUP BY hid" > (key, c30) :: IO [(Int, Int)] > chkPrev <- query conn "SELECT hid, COUNT(*) FROM hcheck WHERE jkey=? AND day>=? AND day (key, c60, c30) :: IO [(Int, Int)] > chkWk <- query conn "SELECT hid, COUNT(*) FROM hcheck WHERE jkey=? AND day>=? GROUP BY hid" > (key, weekStart) :: IO [(Int, Int)] > lifetime <- n "SELECT COUNT(*) FROM hcheck WHERE jkey=?" (Only key) > bestDay <- n "SELECT COUNT(*) c FROM hcheck WHERE jkey=? GROUP BY day ORDER BY c DESC LIMIT 1" (Only key) > bestWeek <- n "SELECT COUNT(*) c FROM hcheck WHERE jkey=? GROUP BY strftime('%Y-%W',day) ORDER BY c DESC LIMIT 1" (Only key) > let look m hid = fromMaybe 0 (lookup hid m) > age created = daysBetween created today + 1 > rate30 (hid,_,t,cr) = rateOf (look chk30 hid) t (min 30 (age cr)) > ratePrev (hid,_,t,_) = rateOf (look chkPrev hid) t 30 > hid4 (h,_,_,_) = h; nm (_,nme,_,_) = nme; tgt (_,_,t,_) = t; cr (_,_,_,c) = c > ranked = sortOn (negate . snd) [ (nm h, rate30 h) | h <- habits ] > onPace = length [ () | h <- habits, look chkWk (hid4 h) * 7 >= tgt h * tdow ] > weekDone = sum [ look chkWk (hid4 h) | h <- habits ] > weekGoal = sum (map tgt habits) > -- most-improved among habits old enough to have prior data > rises = [ (nm h, rate30 h - ratePrev h) | h <- habits, cr h <= c30, rate30 h > ratePrev h ] > rising = case sortOn (negate . snd) rises of ((nme,_):_) -> nme; _ -> "" > pure HabitStats > { hsCount = length habits, hsWeekDone = weekDone, hsWeekGoal = weekGoal > , hsOnPace = onPace, hsLifetime = lifetime, hsBestDay = bestDay > , hsBestWeek = bestWeek, hsRanked = ranked, hsRising = rising } > > renderHabitStats :: HabitStats -> [T.Text] > renderHabitStats hs > | hsCount hs == 0 = [] > | otherwise = concat > [ [ infoLine "", divider "habits" ] > , metricTOC "this week toward goals" > (tshow (pct (hsWeekDone hs) (hsWeekGoal hs)) <> "%" > <> " (" <> tshow (hsWeekDone hs) <> " of " <> tshow (hsWeekGoal hs) <> ")") > , metricTOC "this week on pace" > (tshow (pct (hsOnPace hs) (hsCount hs)) <> "%" > <> " (" <> tshow (hsOnPace hs) <> " of " <> tshow (hsCount hs) <> ")") > , board > , rise > ] > where > rankLine xs = T.intercalate " . " [ nme <> " " <> tshow r <> "%" | (nme, r) <- xs ] > bottom3 = drop (max 0 (length (hsRanked hs) - 3)) (hsRanked hs) > board > | hsCount hs < 6 = [ infoLine "" ] ++ note ("your habits: " <> rankLine (hsRanked hs)) > | otherwise = [ infoLine "" ] > ++ note ("strongest: " <> rankLine (take 3 (hsRanked hs))) > ++ note ("show love: " <> rankLine bottom3) > rise = if T.null (hsRising hs) then [] > else note ("on the rise: " <> hsRising hs <> " (up from last month)") Your hiscores (/hiscores) ------------------------- A trophy room, kept apart from the accountability numbers in @/stats@: only the bests, framed as achievements you have already banked. Records only ever go up --- the kindest metric there is --- so there is never a "days since" or "below your best" deficit here, and an empty journal sees warm placeholders, not a wall of zeros. Every figure is read-only, derived from existing @task@/@hcheck@ rows; the week/month maths are pure and doctested (Monday-started weeks via 'weekKey', not SQLite's @%W@). > -- | The Monday-started week key (that week's Monday, @YYYY-MM-DD@) for > -- a day, so checks and completions bucket into ISO weeks purely. > -- > -- >>> map weekKey ["2021-01-04","2021-01-07","2021-01-10","2021-01-11"] > -- ["2021-01-04","2021-01-04","2021-01-04","2021-01-11"] > weekKey :: T.Text -> T.Text > weekKey d = shiftDay (negate (weekdayOf d - 1)) d > > -- | How many of @days@ fall in each bucket under key @f@, sorted by > -- key. Repeats count, so a day on which three tasks were finished adds > -- three to its day/week/month bucket. > -- > -- >>> bucketCounts weekKey ["2021-01-04","2021-01-05","2021-01-11"] > -- [("2021-01-04",2),("2021-01-11",1)] > bucketCounts :: Ord k => (T.Text -> k) -> [T.Text] -> [(k, Int)] > bucketCounts f days = > map (\g -> (fst (head g), length g)) > (groupBy ((==) `on` fst) (sortOn fst [ (f d, d) | d <- days ])) > > -- | The largest value in a list, or 0 when empty --- a missing record > -- reads as a calm 0, never a crash. > -- > -- >>> map maxOr0 [[3,7,2],[]] > -- [7,0] > maxOr0 :: [Int] -> Int > maxOr0 [] = 0 > maxOr0 xs = maximum xs > > -- | Most entries in any one ISO week. > -- > -- >>> bestWeek ["2021-01-04","2021-01-05","2021-01-11"] > -- 2 > bestWeek :: [T.Text] -> Int > bestWeek = maxOr0 . map snd . bucketCounts weekKey > > -- | Most entries in any one calendar month. > -- > -- >>> bestMonth ["2021-01-31","2021-01-04","2021-02-02"] > -- 2 > bestMonth :: [T.Text] -> Int > bestMonth = maxOr0 . map snd . bucketCounts monthOf > > -- | How many ISO weeks met (or beat) a weekly target. Wins only: a > -- week that fell short is simply not counted, never deducted. > -- > -- >>> perfectWeeks 2 ["2021-01-04","2021-01-05","2021-01-06","2021-01-11"] > -- 1 > perfectWeeks :: Int -> [T.Text] -> Int > perfectWeeks target = length . filter ((>= target) . snd) . bucketCounts weekKey > > -- | Everything the trophy room shows: journal-wide bests plus a record > -- line per active habit. All read-only. > data Records = Records > { rcKept :: T.Text -- when the journal was created > , rcDaysKept :: Int > , rcBestDay :: Int -- most tasks finished in one day > , rcBestDayOn :: T.Text > , rcBestWeek :: Int -- most tasks finished in one week > , rcBestMonth :: Int -- most tasks finished in one month > , rcLifetime :: Int -- tasks completed, all time > , rcStreak :: Int -- longest activity streak ever > , rcHabitLifetime :: Int -- aggregate: total habit checks all-time > , rcHabitBestDay :: Int -- aggregate: most habits ticked in one day > , rcHabitBestWeek :: Int -- aggregate: most checks in any week > , rcHabits :: [HabitRecord] > } > > data HabitRecord = HabitRecord > { hrName :: T.Text > , hrStreak :: Int -- longest check streak ever > , hrBestWeek :: Int -- most checks in one week > , hrPerfect :: Int -- weeks the target was met > , hrLifetime :: Int -- checks, all time > } > > -- | Gather the records (read-only). Best day/week/month come from the > -- completion dates of done tasks; the longest streak from activity days > -- (the same definition the dashboard uses); each habit's bests from its > -- own check days. > gatherRecords :: Connection -> T.Text -> T.Text -> IO Records > gatherRecords conn key today = do > created <- maybe today fromOnly . listToMaybe <$> > (query conn "SELECT created FROM journal WHERE key=?" (Only key) :: IO [Only T.Text]) > doneDates <- map fromOnly <$> (query conn > "SELECT updated FROM task WHERE jkey=? AND state='done'" (Only key) :: IO [Only T.Text]) > adays <- query conn > "SELECT day FROM task WHERE jkey=?\ > \ UNION SELECT updated FROM task WHERE jkey=? AND state IN ('done','dropped','migrated')" > (key, key) :: IO [Only T.Text] > bestRow <- query conn > "SELECT updated, COUNT(*) FROM task WHERE jkey=? AND state='done'\ > \ GROUP BY updated ORDER BY 2 DESC, updated DESC LIMIT 1" (Only key) :: IO [(T.Text, Int)] > habits <- query conn > "SELECT id, name, target FROM habit WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, Int)] > checks <- query conn > "SELECT hid, day FROM hcheck WHERE jkey=? ORDER BY hid, day" (Only key) :: IO [(Int, T.Text)] > let ords = mapMaybe dayNum (map fromOnly adays) > (bDayOn, bDay) = case bestRow of ((d, c) : _) -> (d, c); _ -> ("", 0) > daysFor hid = [ d | (h, d) <- checks, h == hid ] > hrec (hid, nm, tgt) = > let ds = daysFor hid > in HabitRecord nm (longestStreak (mapMaybe dayNum ds)) > (bestWeek ds) (perfectWeeks tgt ds) (length ds) > -- aggregate habit records across ALL hcheck rows (including any > -- archived habits' history --- a record is a record) > checkDays = map snd checks > bestDayAgg = maxOr0 (map snd (sumByKey id (map (\d -> (d, 1)) checkDays))) > bestWeekAgg = maxOr0 (map snd (sumByKey weekKey (map (\d -> (d, 1)) checkDays))) > pure Records > { rcKept = created, rcDaysKept = daysBetween created today + 1 > , rcBestDay = bDay, rcBestDayOn = bDayOn > , rcBestWeek = bestWeek doneDates, rcBestMonth = bestMonth doneDates > , rcLifetime = length doneDates, rcStreak = longestStreak ords > , rcHabitLifetime = length checks > , rcHabitBestDay = bestDayAgg > , rcHabitBestWeek = bestWeekAgg > , rcHabits = map hrec habits > } > > -- | Render the trophy room (pure). Bests are framed as kept > -- achievements; an unearned record shows a warm placeholder, never a > -- bare zero or a deficit. > renderRecords :: Records -> [T.Text] > renderRecords r = > [ infoLine "", divider "journal" ] > ++ journalBlock ++ habitBlock > where > kept = metricTOC "kept since" (dayLabel (rcKept r)) > journalBlock > | rcLifetime r == 0 = > kept ++ note "finish your first task and your hiscores start here." > | otherwise = kept > ++ metricTOC "best day" (plural (rcBestDay r) "task" > <> " . " <> dayLabel (rcBestDayOn r)) > ++ metricTOC "best week" (plural (rcBestWeek r) "task") > ++ metricTOC "best month" (plural (rcBestMonth r) "task") > ++ metricTOC "lifetime" (plural (rcLifetime r) "task") > ++ metricTOC "best run" (plural (rcStreak r) "day" <> " in a row") > habitBlock > | null (rcHabits r) = [] > | otherwise = [ infoLine "", divider "habit bests" ] > ++ aggregateBlock > ++ concat (intersperse [infoLine ""] (map habitLines (rcHabits r))) > aggregateBlock = metricTOC "all-time done" (tshow (rcHabitLifetime r)) > ++ metricTOC "best day across" (tshow (rcHabitBestDay r)) > ++ metricTOC "best week across" (tshow (rcHabitBestWeek r)) > ++ [ infoLine "" ] > habitLines h = > infoLine (" " <> hrName h) > : if hrLifetime h == 0 > then note "no checks yet --- tap it on the grid and the streak begins." > else subMetricTOC "best run" (plural (hrStreak h) "day" <> " in a row") > ++ subMetricTOC "best week" (plural (hrBestWeek h) "check") > ++ (if hrPerfect h > 0 > then subMetricTOC "perfect weeks" (tshow (hrPerfect h)) > else []) > ++ subMetricTOC "lifetime" (plural (hrLifetime h) "check") > > recordsView :: Ctx -> T.Text -> IO () > recordsView ctx key = do > let conn = ctxConn ctx > ex <- query conn "SELECT 1 FROM journal WHERE key=?" (Only key) :: IO [Only Int] > case ex of > [] -> notFound ctx > _ -> do > today <- todayDay > r <- gatherRecords conn key today > f <- gatherFocus conn key today > crs <- gatherCounterRecs conn key today > let frame = framedTitle ["your records", "they only go up"] > body = renderRecords r ++ renderFocusRecords f ++ renderCounterRecs crs > page ctx (frame ++ body > ++ [ infoLine "", link ctx "back to the journal" ("/k/" <> key) ]) Focus stats (timeblocks on /stats and /hiscores) ------------------------------------------------ Completed timeblocks are tallied from @timer_done@. Each row carries the start and finish epochs, so a block's minutes are @(completed - started) \/ 60@ --- robust even if the timer's length is later changed. The same pure bucket helpers behind the journal records group these into days, ISO weeks and months. > -- | Sum a per-day value into buckets under key @f@ (e.g. focus minutes > -- per ISO week). Like 'bucketCounts', but summing rather than counting. > -- > -- >>> sumByKey weekKey [("2021-01-04",25),("2021-01-05",50),("2021-01-11",10)] > -- [("2021-01-04",75),("2021-01-11",10)] > sumByKey :: Ord k => (T.Text -> k) -> [(T.Text, Int)] -> [(k, Int)] > sumByKey f = > map (\g -> (fst (head g), sum (map snd g))) > . groupBy ((==) `on` fst) . sortOn fst . map (\(d, n) -> (f d, n)) > > -- | Minutes as @45m@, @1h 30m@, or @6h@ (whole hours drop the @0m@). > -- > -- >>> map fmtMin [0, 45, 90, 125, 360] > -- ["0m","45m","1h 30m","2h 5m","6h"] > fmtMin :: Int -> T.Text > fmtMin m = let (h, r) = m `divMod` 60 > in if h > 0 > then if r == 0 then tshow h <> "h" else tshow h <> "h " <> tshow r <> "m" > else tshow r <> "m" > > -- | The key holding the largest value, or a default if the list is > -- empty. Used to anchor a record to the day/week it was set on. > -- > -- >>> argmaxBy (T.pack "?") [(T.pack "a",2),(T.pack "c",5),(T.pack "b",3)] > -- "c" > -- > -- >>> argmaxBy (T.pack "?") [] > -- "?" > argmaxBy :: T.Text -> [(T.Text, Int)] -> T.Text > argmaxBy def [] = def > argmaxBy _ xs = fst (foldl1 (\a@(_,ma) b@(_,mb) -> if mb > ma then b else a) xs) > > -- | Focus figures from completed timeblocks: the current-window numbers > -- for /stats and the all-time bests for /hiscores. Bests carry the > -- day/week they were set on so the trophy room can anchor each record > -- in memory ("oh, that was the day I..."). > data Focus = Focus > { fcToday :: Int > , fcWeek :: Int > , fcWeekBlocks :: Int > , fcBestDay :: Int > , fcBestDayOn :: T.Text > , fcBestWeek :: Int > , fcBestWeekOn :: T.Text > , fcLongest :: Int > , fcLongestOn :: T.Text > , fcTotalMin :: Int > , fcBlocks :: Int > , fcStreak :: Int > } > > gatherFocus :: Connection -> T.Text -> T.Text -> IO Focus > gatherFocus conn key today = do > rows <- query conn "SELECT day, started, completed FROM timer_done WHERE jkey=?" > (Only key) :: IO [(T.Text, Integer, Integer)] > -- in-progress today: today's paused work + any currently-active session, > -- summed across all of the journal's timers. Not yet in timer_done > -- (harvestStale moves it there at midnight) but absolutely is today's > -- focus, so include it for fcToday/fcWeek truthfulness. > pausedRow <- query conn > "SELECT COALESCE(SUM(paused_elapsed),0) FROM timer\ > \ WHERE jkey=? AND paused_day=? AND archived=0" (key, today) :: IO [Only Int] > actRows <- query conn > "SELECT active_started FROM timer\ > \ WHERE jkey=? AND active_started IS NOT NULL AND archived=0" (Only key) > :: IO [Only Integer] > now <- nowEpoch > let pausedSec = case pausedRow of (Only s : _) -> s; _ -> 0 > activeSec = sum [ fromIntegral (now - st) | Only st <- actRows ] > liveTodayMin = (pausedSec + activeSec) `div` 60 > histDayMins = [ (d, fromIntegral ((c - s) `div` 60)) | (d, s, c) <- rows ] > -- synthesise a today-row so all the aggregates see live work. > dayMins = if liveTodayMin > 0 > then (today, liveTodayMin) : histDayMins > else histDayMins > weekStart = shiftDay (negate (weekdayOf today - 1)) today > daySums = sumByKey id dayMins > weekSums = sumByKey weekKey dayMins > pure Focus > { fcToday = sum [ m | (d, m) <- dayMins, d == today ] > , fcWeek = sum [ m | (d, m) <- dayMins, d >= weekStart ] > , fcWeekBlocks = length [ () | (d, _) <- dayMins, d >= weekStart ] > , fcBestDay = maxOr0 (map snd daySums) > , fcBestDayOn = argmaxBy "" daySums > , fcBestWeek = maxOr0 (map snd weekSums) > , fcBestWeekOn = argmaxBy "" weekSums > , fcLongest = maxOr0 (map snd dayMins) > , fcLongestOn = argmaxBy "" dayMins > , fcTotalMin = sum (map snd dayMins) > , fcBlocks = length dayMins > , fcStreak = longestStreak (mapMaybe dayNum (map fst dayMins)) > } > > -- | One timer's timeblocks figures. The lifetime average is taken over > -- the days the timer actually ran (a day with no @timer_done@ row is not > -- part of it), so days off never drag it down --- the whole point. The > -- this-week pair (run count + this-week average) gives the missing > -- cadence: a long average earned on two days reads @ran 2@, not as a win. > -- @taTarget@ is the bound habit's days/week goal, shown as the @/N@ > -- denominator when the timer is tied to one. > data TimerAvg = TimerAvg > { taName :: T.Text -- timer name > , taAvgMin :: Int -- lifetime avg minutes per day it ran > , taDays :: Int -- lifetime days the timer ran > , taWkRuns :: Int -- days run this week (Monday-start) > , taWkAvgMin :: Int -- this week's avg minutes per day run (0 if none) > , taTarget :: Maybe Int -- bound habit's days/week target, if bound > } > > -- | Per-timer averages, lifetime and this-week. Off-days are excluded > -- automatically (a day with no @timer_done@ row is not counted), which is > -- the whole point: you see what a typical working day looks like, not how > -- often you forgot. The this-week figures are bucketed against the > -- Monday-start 'weekKey'; the bound habit's target rides along for the > -- @ran N\/T@ denominator. Archived timers are dropped. > gatherTimerAverages :: Connection -> T.Text -> IO [TimerAvg] > gatherTimerAverages conn key = do > today <- todayDay > let wk = weekKey today > rows <- query conn > "SELECT t.name, count(*), avg(td.completed - td.started), \ > \ sum(CASE WHEN td.day >= ? THEN 1 ELSE 0 END), \ > \ sum(CASE WHEN td.day >= ? THEN td.completed - td.started ELSE 0 END), \ > \ h.target \ > \ FROM timer_done td JOIN timer t ON t.id = td.tid \ > \ LEFT JOIN habit h ON h.id = t.hid AND h.jkey = ? \ > \ WHERE td.jkey = ? AND t.archived = 0 \ > \ GROUP BY t.id ORDER BY t.id" > (wk, wk, key, key) :: IO [(T.Text, Int, Double, Int, Int, Maybe Int)] > pure [ TimerAvg > { taName = n > , taAvgMin = (round avgS :: Int) `div` 60 > , taDays = d > , taWkRuns = wkRuns > , taWkAvgMin = if wkRuns > 0 then (wkSecs `div` wkRuns) `div` 60 else 0 > , taTarget = mtgt > } > | (n, d, avgS, wkRuns, wkSecs, mtgt) <- rows ] > > -- | Per-timer averages, each timer grouped under its own name header > -- (the @subMetricTOC@ nesting the counters already use) with two nested > -- rows: a this-week cadence line above the lifetime average. The cadence > -- line is the honest guard --- @ran 6\/6 . avg 10h18m@ shows what the > -- average is measured against, so a fat number earned on a couple of days > -- can't pose as a strong week. Sits under the aggregate @timeblocks@ totals. > renderTimerAverages :: [TimerAvg] -> [T.Text] > renderTimerAverages = concatMap one > where > one ta = > [ infoLine (" " <> taName ta) ] > ++ subMetricTOC "this wk" (thisWk ta) > ++ subMetricTOC "avg" > (fmtMin (taAvgMin ta) <> " . " <> plural (taDays ta) "day") > thisWk ta > | taWkRuns ta == 0 = "ran 0" <> tgt ta <> " . --" > | otherwise = "ran " <> tshow (taWkRuns ta) <> tgt ta > <> " . avg " <> fmtMin (taWkAvgMin ta) > tgt ta = case taTarget ta of Just t -> "/" <> tshow t; Nothing -> "" > > -- | The /stats timeblocks section (hidden until a block is completed). > renderFocusStats :: Focus -> [TimerAvg] -> [T.Text] > renderFocusStats f tas > | fcBlocks f == 0 = [] > | otherwise = concat > [ [ infoLine "", divider "timeblocks" ] > , metricTOC "today focused" (fmtMin (fcToday f)) > , metricTOC "this week focused" (fmtMin (fcWeek f)) > , metricTOC "this week blocks" (tshow (fcWeekBlocks f)) > , renderTimerAverages tas > ] > > -- | The /hiscores focus records (hidden until a block is completed). > renderFocusRecords :: Focus -> [T.Text] > renderFocusRecords f > | fcBlocks f == 0 = [] > | otherwise = > [ infoLine "", divider "focus" ] > ++ metricTOC "best day" (fmtMin (fcBestDay f) <> " . " <> dayLabel (fcBestDayOn f)) > ++ metricTOC "best week" (fmtMin (fcBestWeek f) <> " . wk of " <> dayLabel (fcBestWeekOn f)) > ++ metricTOC "longest" (fmtMin (fcLongest f) <> " . " <> dayLabel (fcLongestOn f)) > ++ metricTOC "lifetime" (fmtMin (fcTotalMin f) <> " . " <> plural (fcBlocks f) "block") > ++ metricTOC "best run" (plural (fcStreak f) "day" <> " in a row") The habit tracker (/habits) --------------------------- A month grid: one tappable row per habit, columns for each day, and a tap toggles *today's* cell (the only column you can change). Two stacked header rows number the days; today's cell shows as @_@/@*@ so the tappable column stands out. Each row also carries its current streak and month count. Checks live in @hcheck@ (presence = done) and toggle idempotently via named verbs. > habitsView :: Ctx -> T.Text -> IO () > habitsView ctx key = do > let conn = ctxConn ctx > today <- todayDay > let real = monthOf today > n = daysInMonth real > dom = domOf today > fdow = firstDow real > todayDw = dowOf fdow dom -- today's weekday (1=Mon) > weekStart = dom - (todayDw - 1) -- this week's Monday (day-of-month) > (tens, units) = gridHead fdow n > gut = T.replicate 11 " " > hs <- query conn "SELECT id, name, target FROM habit WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, Int)] > checks <- query conn > "SELECT hid, day FROM hcheck WHERE jkey=? AND substr(day,1,7)=?" > (key, real) :: IO [(Int, T.Text)] > let row (hid, name, target) = > let doms = [ domOf d | (h, d) <- checks, h == hid ] > verb = if dom `elem` doms then "huncheck" else "hcheck" > -- frequency habit: this week's progress; daily: streak > stat | target < 7 = tshow (length (filter (>= weekStart) doms)) <> "/" <> tshow target <> "wk" > | otherwise = tshow (fst (currentStreak (maybe 0 id (dayNum today)) (mapMaybe dayNum [ d | (h, d) <- checks, h == hid ]))) <> "d" > in link ctx > (T.justifyLeft 11 ' ' (clamp 10 name) <> cells fdow n target dom doms > <> " " <> stat) > ("/k/" <> key <> "/" <> verb <> "/" <> tshow hid) > body | null hs = [ infoLine "no habits yet --- add one below." ] > | otherwise = infoLine (gut <> tens) : infoLine (gut <> units) : map row hs > page ctx $ > [ infoLine ("habits . " <> monthLabel real <> " (today: the " <> tshow dom <> ")") > , infoLine "X done . O earned rest . . missed . _ today (tap a row)" > , infoLine "" > ] ++ body ++ > [ infoLine "" > , search ctx "+ add a habit (e.g. 4|exercise = 4x a week)" ("/k/" <> key <> "/habits/add") > , link ctx "manage habits" ("/k/" <> key <> "/habits/manage") > , link ctx "timeblocks (timers) --- finishing one ticks its habit" ("/k/" <> key <> "/timers") > , link ctx "back to the journal" ("/k/" <> key) ] > > addHabit :: Ctx -> T.Text -> T.Text -> IO () > addHabit ctx key q = do > let (target, nm) = parseHabit q > name = T.take 40 nm > when (not (T.null name)) $ do > today <- todayDay > execute (ctxConn ctx) > "INSERT INTO habit (jkey, name, archived, target, created) VALUES (?,?,0,?,?)" > (key, name, target, today) > logEvent (ctxConn ctx) key "habit_add" name > habitsView ctx key > > -- | Set today's check for a habit on/off (idempotent; named target). > -- Guarded by ownership so a check can only attach to your own habit. > setCheck :: Ctx -> T.Text -> Bool -> Int -> IO () > setCheck ctx key on hid = do > let conn = ctxConn ctx > today <- todayDay > owned <- query conn "SELECT name FROM habit WHERE id=? AND jkey=?" (hid, key) > :: IO [Only T.Text] > when (not (null owned)) $ do > if on > then execute conn "INSERT OR IGNORE INTO hcheck (jkey, hid, day) VALUES (?,?,?)" (key, hid, today) > else execute conn "DELETE FROM hcheck WHERE hid=? AND day=? AND jkey=?" (hid, today, key) > case owned of > (Only n : _) -> logEvent conn key > (if on then "habit_check" else "habit_uncheck") n > _ -> pure () > habitsView ctx key > > manageHabits :: Ctx -> T.Text -> IO () > manageHabits ctx key = do > hs <- query (ctxConn ctx) > "SELECT id, name, archived FROM habit WHERE jkey=? ORDER BY archived, id" > (Only key) :: IO [(Int, T.Text, Int)] > let row (hid, name, arch) = > let (lbl, verb) = if arch == 1 then ("[restore] ", "hunarch") > else ("[archive] ", "harch") > in link ctx (lbl <> clamp 40 name) ("/k/" <> key <> "/" <> verb <> "/" <> tshow hid) > page ctx $ > [ infoLine "manage habits", infoLine "tap to archive or restore.", infoLine "" ] > ++ (if null hs then [infoLine "no habits yet."] else map row hs) > ++ [ infoLine "", link ctx "back to the grid" ("/k/" <> key <> "/habits") ] > > setArch :: Ctx -> T.Text -> Int -> Int -> IO () > setArch ctx key v hid = do > execute (ctxConn ctx) "UPDATE habit SET archived=? WHERE id=? AND jkey=?" (v, hid, key) > manageHabits ctx key The timeblocks (/timers) ------------------------ Daily countdown timers, one running at a time. Gopher cannot tick, so a timer never does: it stores when it started and how long it runs, and the time left is arithmetic against the clock on each page load. Completion is resolved lazily ('resolveTimers', run on every keyed request from 'mainBody'): if the running block has elapsed, it is recorded and, if bound to a habit, that habit is checked for the day it ELAPSED (start + minutes) --- so a block that runs out overnight credits the right day whenever you next load a page. The running block shows at the top of every menu; tapping that line stops it (resolve runs first, so a finished block is completed, not discarded). Daily reset is implicit: a @timer_done@ row keyed by @(tid, day)@ means "done that day", and a new day simply has none yet. Schema is additive; habit credit reuses @hcheck@. > -- | Parse a duration into minutes: a bare number is minutes (@25@), or > -- use @h@\/@m@ units (@6h@, @90m@, @1h30m@). Case-insensitive. > -- > -- >>> map parseDur (map T.pack ["25","6h","1h30m","90m","2h5m"]) > -- [Just 25,Just 360,Just 90,Just 90,Just 125] > parseDur :: T.Text -> Maybe Int > parseDur t0 > | T.null t = Nothing > | T.all isDigit t = readMaybe (T.unpack t) > | otherwise = > let (hp, r) = T.breakOn "h" t > in if not (T.null r) > then (\h m -> h * 60 + m) <$> readMaybe (T.unpack hp) <*> mins (T.drop 1 r) > else mins t > where t = T.toLower (T.strip t0) > mins s | T.null s' = Just 0 > | otherwise = readMaybe (T.unpack s') > where s' = if "m" `T.isSuffixOf` s then T.dropEnd 1 s else s > > -- | Parse a @duration|name@ timer spec (1..720 min, non-empty name). > -- > -- >>> parseTimer (T.pack "25|deep work") > -- Just (25,"deep work") > -- > -- >>> parseTimer (T.pack "6h|timed thing") > -- Just (360,"timed thing") > -- > -- >>> parseTimer (T.pack "nope") > -- Nothing > parseTimer :: T.Text -> Maybe (Int, T.Text) > parseTimer raw = case T.breakOn "|" raw of > (d, rest) | not (T.null rest) -> > case parseDur d of > Just m | m >= 1, m <= 720 -> > let nm = T.strip (T.drop 1 rest) > in if T.null nm then Nothing else Just (m, T.take 30 nm) > _ -> Nothing > _ -> Nothing > > -- | Lazy timer resolution, run on every keyed page load. If a block is > -- running and has elapsed, record it in @timer_done@, credit a bound > -- habit on the day it elapsed, and clear the running pointer. Returns the > -- still-running block as @(name, seconds-left)@ for the header, else > -- Nothing. A pointer to a vanished (archived/deleted) timer is cleared. > -- | Epoch of midnight starting the given YYYY-MM-DD in local time. > -- Grounds a "paused on day X with N seconds" entry into a concrete > -- timestamp for timer_done. The day boundary follows the server's > -- local zone so the credit lines up with @todayDay@. > dayStartEpoch :: T.Text -> IO Integer > dayStartEpoch day = do > tz <- getCurrentTimeZone > case parseTimeM True defaultTimeLocale "%Y-%m-%d" (T.unpack day) :: Maybe Day of > Just d -> pure $ floor $ utcTimeToPOSIXSeconds $ > localTimeToUTC tz (LocalTime d midnight) > Nothing -> nowEpoch > > -- | Preserve abandoned-but-launched work. Any timer with a paused > -- session from before today gets that elapsed written as a > -- @timer_done@ partial for the day it actually happened, then cleared. > -- An active timer whose @started@-day is before today gets the same > -- treatment (credited up to midnight of that day, capped at the > -- target). Idempotent via @INSERT OR IGNORE@ on the @(tid, day)@ > -- primary key, so a reload won't duplicate. Runs at the start of > -- 'resolveTimers' on every keyed page load, so any stale work surfaces > -- the first time you visit the next day instead of vanishing. > -- | Every timer currently running for this journal, as @(tid, started)@. > -- The active SET (size 0..N): one entry in single-timer mode, possibly > -- several when the "one at a time" toggle is off. Archived timers are > -- excluded defensively (they should never be running). > activeTimers :: Connection -> T.Text -> IO [(Int, Integer)] > activeTimers conn key = query conn > "SELECT id, active_started FROM timer\ > \ WHERE jkey=? AND active_started IS NOT NULL AND archived=0 ORDER BY id" > (Only key) > > -- | The "only one timer at a time" preference (default on). On = starting > -- a timer pauses any other running one; off = they run concurrently. > getSingleTimer :: Connection -> T.Text -> IO Bool > getSingleTimer conn key = do > r <- query conn "SELECT single_timer FROM journal WHERE key=?" (Only key) > :: IO [Only Int] > pure (maybe True ((/= 0) . fromOnly) (listToMaybe r)) > > setSingleTimer :: Ctx -> T.Text -> Int -> IO () > setSingleTimer ctx key v = do > execute (ctxConn ctx) "UPDATE journal SET single_timer=? WHERE key=?" (v, key) > timersView ctx key > > harvestStale :: Connection -> T.Text -> T.Text -> IO () > harvestStale conn key today = do > -- Branch A: paused-stale (banked seconds from a day before today). > -- Additive: if a row already exists for that day (rare, e.g. from > -- a same-day credit), bump completed by pe; else insert fresh. > pausedStale <- query conn > "SELECT id, paused_elapsed, paused_day FROM timer\ > \ WHERE jkey = ? AND paused_elapsed > 0 AND paused_day IS NOT NULL AND paused_day < ?" > (key, today) :: IO [(Int, Int, T.Text)] > forM_ pausedStale $ \(tid, pe, pd) -> do > startE <- dayStartEpoch pd > withTransaction conn $ do > execute conn "INSERT INTO timer_done\ > \ (jkey, tid, day, started, completed) VALUES (?,?,?,?,?)\ > \ ON CONFLICT(tid, day) DO UPDATE SET completed = completed + ?" > (key, tid, pd, startE, startE + fromIntegral pe, pe) > totRow <- query conn "SELECT completed - started FROM timer_done\ > \ WHERE jkey=? AND tid=? AND day=?" (key, tid, pd) > :: IO [Only Int] > let total = case totRow of (Only n : _) -> n; _ -> fromIntegral pe > maybeTickHabit conn key tid pd total > execute conn "UPDATE timer SET paused_elapsed=0, paused_day=NULL WHERE id=? AND jkey=?" > (tid, key) > -- Branch B: active-stale (active timer still running from before today). > -- A running timer AUTO-STOPS at midnight: bank the pre-midnight portion > -- (@started@ -> midnight of the start day) to that day --- additive and > -- uncapped, worked time is worked time --- then clear the running pointer > -- so the block is stopped, not rolled into the new day. Post-midnight is > -- not tracked; 'timersView' warns you to restart if you work past 12am. > -- Idempotent via the (tid, day) primary key, so a reload won't duplicate. > actStale <- query conn > "SELECT id, active_started FROM timer\ > \ WHERE jkey=? AND active_started IS NOT NULL AND archived=0" > (Only key) :: IO [(Int, Integer)] > forM_ actStale $ \(tid, started) -> do > sDay <- epochDay started > when (sDay /= today) $ do > midnightAfter <- dayStartEpoch (shiftDay 1 sDay) > let dur = fromIntegral (midnightAfter - started) :: Int > when (dur > 0) $ withTransaction conn $ do > execute conn "INSERT INTO timer_done\ > \ (jkey, tid, day, started, completed) VALUES (?,?,?,?,?)\ > \ ON CONFLICT(tid, day) DO UPDATE SET completed = completed + ?" > (key, tid, sDay, started, midnightAfter, dur) > totRow <- query conn "SELECT completed - started FROM timer_done\ > \ WHERE jkey=? AND tid=? AND day=?" (key, tid, sDay) > :: IO [Only Int] > let total = case totRow of (Only n : _) -> n; _ -> dur > maybeTickHabit conn key tid sDay total > -- auto-stop this timer (clear its own running pointer + any banked) > execute conn "UPDATE timer SET active_started=NULL, paused_elapsed=0, paused_day=NULL\ > \ WHERE id=? AND jkey=?" (tid, key) > > -- | Every running timer as @(name, elapsed_sec, target_sec, mins, tid)@ > -- (empty when none run). With the "one at a time" toggle on there is at > -- most one; with it off there may be several. No auto-complete --- a timer > -- keeps accumulating past its goal, with the render's @✓@ marking when the > -- goal has been reached. Ticks each bound habit (idempotently) if today's > -- elapsed has crossed the goal threshold. > resolveTimers :: Connection -> T.Text -> IO [(T.Text, Int, Int, Int, Int)] > resolveTimers conn key = do > today <- todayDay > harvestStale conn key today > acts <- activeTimers conn key > now <- nowEpoch > fmap catMaybes $ forM acts $ \(tid, started) -> do > trow <- query conn > "SELECT name, minutes, paused_elapsed, paused_day FROM timer WHERE id=? AND jkey=?" > (tid, key) :: IO [(T.Text, Int, Int, Maybe T.Text)] > case trow of > [(nm, mins, pe, pd)] -> do > let target = mins * 60 > elapsed = totalElapsed pe pd today started now > maybeTickHabit conn key tid today elapsed > pure (Just (nm, elapsed, target, mins, tid)) > _ -> do > execute conn "UPDATE timer SET active_started=NULL WHERE id=? AND jkey=?" (tid, key) > pure Nothing > > -- | The timers page: one row per timer. There's no "done" state --- > -- worked seconds just accumulate vs the goal, with a @(done)@ marker > -- when the goal is reached and a @+Nm@ tail when you've gone past it. > -- Active timer gets a stop link; stopped timers get start (or resume, > -- if they have today's banked time) plus an edit-time sub-link for > -- after-the-fact correction. > timersView :: Ctx -> T.Text -> IO () > timersView ctx key = do > let conn = ctxConn ctx > today <- todayDay > now <- nowEpoch > tz <- getCurrentTimeZone > single <- getSingleTimer conn key > timers <- query conn > "SELECT id, name, minutes, hid, paused_elapsed, paused_day, active_started\ > \ FROM timer WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, Int, Maybe Int, Int, Maybe T.Text, Maybe Integer)] > habits <- query conn "SELECT id, name FROM habit WHERE jkey=? AND archived=0" > (Only key) :: IO [(Int, T.Text)] > let hn hid = fromMaybe "" (lookup hid habits) > tag mhid = case mhid of Just h -> " -> " <> hn h; Nothing -> "" > -- active timer is wrapped in @===@ rules above AND below the whole > -- block (label + ends-line + stop link), so it reads as a banner > -- you can spot from across the room. Inactive rows have no rule > -- and a name flush at column 0. > activeRule = infoLine (T.replicate 60 "=") > row (tid, nm, mins, mhid, pe, pd, mstarted) = > let target = mins * 60 > isActive = mstarted /= Nothing > elapsed = case mstarted of > Just st -> totalElapsed pe pd today st now > Nothing -> if pd == Just today then pe else 0 > check = if elapsed >= target then " " <> checkmark else "" > over = elapsed - target > overTxt = if over > 0 then " +" <> fmtClock over else "" > worked = fmtClock elapsed <> " of " <> fmtMin mins > label = clamp 24 nm <> " " <> bar (min elapsed target) target > <> check <> " " <> worked <> overTxt <> tag mhid > -- pre-goal active row gets an "ends HH:MM" line: when the > -- timer would hit its goal if you keep working continuously. > -- Post-goal active rows drop it (already-met goals don't > -- have an "ends" to look forward to). > endsLine > | isActive, elapsed < target = > [ infoLine (" ends " > <> endLabelTZ tz (now + fromIntegral (target - elapsed)) today) ] > | otherwise = [] > in if isActive > then [ activeRule, infoLine label ] ++ endsLine ++ > [ link ctx (" >> stop " <> clamp 22 nm) > ("/k/" <> key <> "/timers/stop/" <> tshow tid) > , activeRule ] > else > let verb = if pe > 0 && pd == Just today then "resume" else "start" > in [ infoLine label > , link ctx (" >> " <> verb <> " " <> clamp 22 nm) > ("/k/" <> key <> "/timers/start/" <> tshow tid) > , search ctx (" >> edit time (e.g. 1h30m)") > ("/k/" <> key <> "/timers/setworked/" <> tshow tid) ] > page ctx $ > [ infoLine ("timeblocks --- " <> if single then "starting one pauses the rest" > else "several can run at once") > , link ctx (if single then "only one timer at a time: on (tap to allow several)" > else "only one timer at a time: off (tap to limit to one)") > ("/k/" <> key <> "/timers/single/" <> if single then "0" else "1") > , infoLine "a running timer auto-stops at midnight; restart it to keep" > , infoLine "logging past 12am (after-midnight time is not tracked)." > , infoLine "" ] > ++ (if null timers then [ infoLine "no timers yet. add one below." ] > else concat (intersperse [infoLine ""] (map row timers))) > ++ [ infoLine "" > , search ctx "+ add a timer (e.g. 25, 90m, 1h30m | name)" ("/k/" <> key <> "/timers/add") > , link ctx "manage timers (archive / link a habit)" ("/k/" <> key <> "/timers/manage") > , link ctx "habit tracker (timers tick habits)" ("/k/" <> key <> "/habits") > , link ctx "back to the journal" ("/k/" <> key) ] > > addTimer :: Ctx -> T.Text -> T.Text -> IO () > addTimer ctx key q = do > case parseTimer q of > Just (m, nm) -> do > today <- todayDay > execute (ctxConn ctx) > "INSERT INTO timer (jkey, name, minutes, hid, archived, created)\ > \ VALUES (?,?,?,NULL,0,?)" (key, nm, m, today) > logEvent (ctxConn ctx) key "timer_add" nm > Nothing -> pure () > timersView ctx key > > -- | Start a timer: stop whatever was running (resolve already credited it > -- if it had elapsed), then point the journal at this one as of now. > startTimer :: Ctx -> T.Text -> Int -> IO () > startTimer ctx key tid = do > let conn = ctxConn ctx > now <- nowEpoch > today <- todayDay > owned <- query conn "SELECT name, active_started FROM timer WHERE id=? AND jkey=? AND archived=0" > (tid, key) :: IO [(T.Text, Maybe Integer)] > -- idempotent on reload: if this timer is already running, leave it alone. > -- Resuming keeps the timer's banked paused_elapsed as its base (today). > case owned of > [(nm, Nothing)] -> do > single <- getSingleTimer conn key > withTransaction conn $ do > -- one-at-a-time (default): pause every OTHER running timer first, > -- banking its segment. With the toggle off, leave them running. > when single $ do > others <- query conn > "SELECT id, paused_elapsed, paused_day, active_started FROM timer\ > \ WHERE jkey=? AND active_started IS NOT NULL AND id<>?" > (key, tid) :: IO [(Int, Int, Maybe T.Text, Maybe Integer)] > forM_ others $ \(oid, ope, opd, ostarted) -> case ostarted of > Just os -> do > let banked = totalElapsed ope opd today os now > execute conn "UPDATE timer SET paused_elapsed=?, paused_day=?, active_started=NULL\ > \ WHERE id=? AND jkey=?" (banked, today, oid, key) > maybeTickHabit conn key oid today banked > Nothing -> pure () > execute conn "UPDATE timer SET active_started=? WHERE id=? AND jkey=?" (now, tid, key) > logEvent conn key "timer_start" nm > _ -> pure () -- not owned, or already running (safe reload) > timersView ctx key > > -- | Stop the running block. Elapsed blocks were already completed by > -- 'resolveTimers' (run in 'mainBody'); this just clears a still-running > -- pointer, so an unfinished block stops with no credit. > -- | Pause the running timer: bank the elapsed so far (this segment plus any > -- earlier today) onto the timer, then clear the running pointer. Resuming > -- continues from there; it resets fresh next day. NOT a discard --- that's > -- what the daily reset / not-resuming does. > stopTimer :: Ctx -> T.Text -> Int -> IO () > stopTimer ctx key tid = do > let conn = ctxConn ctx > today <- todayDay > now <- nowEpoch > trow <- query conn > "SELECT paused_elapsed, paused_day, name, active_started FROM timer WHERE id=? AND jkey=?" > (tid, key) :: IO [(Int, Maybe T.Text, T.Text, Maybe Integer)] > case trow of > [(pe, pd, nm, Just started)] -> do > let elapsed = totalElapsed pe pd today started now > withTransaction conn $ do > execute conn "UPDATE timer SET paused_elapsed=?, paused_day=?, active_started=NULL\ > \ WHERE id=? AND jkey=?" (elapsed, today, tid, key) > maybeTickHabit conn key tid today elapsed > logEvent conn key "timer_pause" nm > _ -> pure () -- not running (or not found): nothing to bank > timersView ctx key > > -- | Manually set the worked-today seconds for a timer (must be stopped). > -- The new model has no "complete" event --- worked time just accumulates > -- vs the goal. This verb is for after-the-fact correction: you forgot to > -- clock part of the session, or want to claim time you worked without > -- running the timer in-app. Ticks the bound habit if the new value reaches > -- the goal. Refused while the timer is the active one (stop first). > setTimerWorked :: Ctx -> T.Text -> Int -> T.Text -> IO () > setTimerWorked ctx key tid q = do > let conn = ctxConn ctx > today <- todayDay > case parseDur q of > Just m | m >= 0, m <= 24 * 60 -> do > act <- query conn > "SELECT 1 FROM timer WHERE id=? AND jkey=? AND active_started IS NOT NULL" > (tid, key) :: IO [Only Int] > when (null act) $ do > let secs = m * 60 > withTransaction conn $ do > execute conn "UPDATE timer SET paused_elapsed=?, paused_day=? WHERE id=? AND jkey=?" > (secs, today, tid, key) > maybeTickHabit conn key tid today secs > nmRow <- query conn "SELECT name FROM timer WHERE id=? AND jkey=?" (tid, key) > :: IO [Only T.Text] > case nmRow of > (Only n : _) -> logEvent conn key "timer_setworked" n > _ -> pure () > _ -> pure () > timersView ctx key > > -- | Tick the habit bound to this timer if today's worked seconds have > -- reached the goal. Idempotent via @INSERT OR IGNORE@ on @(jkey, hid, day)@, > -- so callers can invoke after every bank without dedup logic. > maybeTickHabit :: Connection -> T.Text -> Int -> T.Text -> Int -> IO () > maybeTickHabit conn key tid day workedSec = do > trow <- query conn "SELECT hid, minutes FROM timer WHERE id=? AND jkey=?" > (tid, key) :: IO [(Maybe Int, Int)] > case trow of > [(Just hid, mins)] | workedSec >= mins * 60 -> > execute conn "INSERT OR IGNORE INTO hcheck (jkey, hid, day) VALUES (?,?,?)" > (key, hid, day) > _ -> pure () > > timerManageView :: Ctx -> T.Text -> IO () > timerManageView ctx key = do > timers <- query (ctxConn ctx) > "SELECT id, name, minutes, hid, archived FROM timer WHERE jkey=? ORDER BY archived, id" > (Only key) :: IO [(Int, T.Text, Int, Maybe Int, Int)] > habits <- query (ctxConn ctx) "SELECT id, name FROM habit WHERE jkey=?" > (Only key) :: IO [(Int, T.Text)] > let hn hid = fromMaybe "(unknown)" (lookup hid habits) > rows (tid, nm, mins, mhid, arch) = > let (lbl, verb) = if arch == 1 then ("[restore] ", "tunarch") else ("[archive] ", "tarch") > t = case mhid of Just h -> " -> " <> hn h; Nothing -> " (no habit)" > in [ link ctx (lbl <> clamp 26 nm <> " (" <> fmtMin mins <> ")" <> t) > ("/k/" <> key <> "/timers/" <> verb <> "/" <> tshow tid) > , link ctx (" link a habit") ("/k/" <> key <> "/timers/link/" <> tshow tid) > , search ctx (" change time (now " <> fmtMin mins <> ")") > ("/k/" <> key <> "/timers/settime/" <> tshow tid) > , link ctx " reset (wipe today's record and any banked / active time)" > ("/k/" <> key <> "/timers/reset/" <> tshow tid) > , link ctx (" credit a full session today (log " <> fmtMin mins <> " regardless of elapsed)") > ("/k/" <> key <> "/timers/credit/" <> tshow tid) > , infoLine "" ] > page ctx $ > [ infoLine "manage timeblocks", infoLine "tap to archive, link a habit, change time, or reset.", infoLine "" ] > ++ (if null timers then [ infoLine "no timers yet." ] else concatMap rows timers) > ++ [ infoLine "", link ctx "back to timers" ("/k/" <> key <> "/timers") ] > > -- | Credit a full-goal session for today. One-click shortcut for "I did > -- the work but didn't literally run the timer in-app." Sets > -- @paused_elapsed@ to the goal (preserving any greater existing total), > -- ticks the linked habit, and stops the timer if it's the active one. > -- Idempotent: repeat taps just re-set the same value. > creditTimer :: Ctx -> T.Text -> Int -> IO () > creditTimer ctx key tid = do > today <- todayDay > let conn = ctxConn ctx > trow <- query conn "SELECT minutes, name, paused_elapsed, paused_day\ > \ FROM timer WHERE id=? AND jkey=?" > (tid, key) :: IO [(Int, T.Text, Int, Maybe T.Text)] > case trow of > [(mins, nm, pe, pd)] -> do > let target = mins * 60 > current = if pd == Just today then pe else 0 > newPe = max target current > withTransaction conn $ do > execute conn "UPDATE timer SET paused_elapsed=?, paused_day=?, active_started=NULL\ > \ WHERE id=? AND jkey=?" (newPe, today, tid, key) > maybeTickHabit conn key tid today newPe > logEvent conn key "timer_credit" nm > _ -> pure () > timerManageView ctx key > > -- | Wipe today's session entirely for a timer: drop any banked or > -- active state, AND delete the day's @timer_done@ row if one exists. > -- For when a session was a mistap, a misrecorded duration, or you just > -- want to start fresh. The linked habit's @hcheck@ is intentionally > -- NOT removed (the user might have checked it elsewhere; safer to > -- leave it). > resetTimer :: Ctx -> T.Text -> Int -> IO () > resetTimer ctx key tid = do > today <- todayDay > let conn = ctxConn ctx > nmRow <- query conn "SELECT name FROM timer WHERE id=? AND jkey=?" (tid, key) > :: IO [Only T.Text] > withTransaction conn $ do > execute conn "UPDATE timer SET paused_elapsed=0, paused_day=NULL, active_started=NULL\ > \ WHERE id=? AND jkey=?" (tid, key) > execute conn "DELETE FROM timer_done WHERE tid=? AND day=? AND jkey=?" > (tid, today, key) > case nmRow of > (Only n : _) -> logEvent conn key "timer_reset" n > _ -> pure () > timerManageView ctx key > > setTimerArch :: Ctx -> T.Text -> Int -> Int -> IO () > setTimerArch ctx key v tid = do > let conn = ctxConn ctx > execute conn "UPDATE timer SET archived=? WHERE id=? AND jkey=?" (v, tid, key) > when (v == 1) $ execute conn > "UPDATE timer SET active_started=NULL WHERE id=? AND jkey=?" (tid, key) > timerManageView ctx key > > -- | Change a timer's length, reusing the duration parser (1..720 min). > setTimerMins :: Ctx -> T.Text -> Int -> T.Text -> IO () > setTimerMins ctx key tid q = do > case parseDur q of > Just m | m >= 1, m <= 720 -> > execute (ctxConn ctx) "UPDATE timer SET minutes=? WHERE id=? AND jkey=?" (m, tid, key) > _ -> pure () > timerManageView ctx key > > -- | Pick a habit to bind a timer to (or unlink). Completing the block > -- then checks that habit for the day. > timerLinkView :: Ctx -> T.Text -> Int -> IO () > timerLinkView ctx key tid = do > habits <- query (ctxConn ctx) > "SELECT id, name FROM habit WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text)] > let row (hid, nm) = link ctx ("link to: " <> clamp 30 nm) > ("/k/" <> key <> "/timers/sethabit/" <> tshow tid <> "/" <> tshow hid) > page ctx $ > [ infoLine "link this timer to a habit" > , infoLine "completing the block checks that habit for the day." > , infoLine "" ] > ++ (if null habits then [ infoLine "no habits yet --- add one in the habit tracker." ] > else map row habits) > ++ [ infoLine "" > , link ctx "unlink (no habit)" ("/k/" <> key <> "/timers/unlink/" <> tshow tid) > , link ctx "back to manage" ("/k/" <> key <> "/timers/manage") ] > > setTimerHabit :: Ctx -> T.Text -> Int -> Int -> IO () > setTimerHabit ctx key tid hid = do > let conn = ctxConn ctx > mh = if hid == 0 then Nothing else Just hid > ok <- if hid == 0 then pure True > else (not . null) <$> (query conn "SELECT 1 FROM habit WHERE id=? AND jkey=?" > (hid, key) :: IO [Only Int]) > when ok $ execute conn "UPDATE timer SET hid=? WHERE id=? AND jkey=?" (mh, tid, key) > timerManageView ctx key Counters (/counters) -------------------- A counter is a per-day integer tally: a habit's shape, but counting how many instead of whether. Tap @+1@ and the number grows; there is no goal or ceiling. A period (day/week/month) sets the window the current value covers and resets within; polarity is just a flavour --- positive (a good thing, celebrate highs and runs) or negative (something you are cutting down, celebrate the lows and the longest run of zero days). Ticks live per day in @counter_tick@; reset is implicit, since a new window simply has no rows yet. The @goal@ column is retained but unused (kept to avoid a destructive migration). > -- | Parse a counter spec: just a name, optionally prefixed with @-@ to > -- mark a negative ("less is better") counter. No goal --- a counter is a > -- free-running tally. Returns @(polarity, name)@. > -- > -- >>> parseCounter (T.pack "water") > -- Just ("pos","water") > -- > -- >>> parseCounter (T.pack "-coffee") > -- Just ("neg","coffee") > parseCounter :: T.Text -> Maybe (T.Text, T.Text) > parseCounter raw0 = case T.uncons (T.strip raw0) of > Just ('-', r) | not (T.null (T.strip r)) -> Just ("neg", T.take 30 (T.strip r)) > _ | T.null (T.strip raw0) -> Nothing > | otherwise -> Just ("pos", T.take 30 (T.strip raw0)) > > -- | The first day of a counter's current window, by period. > -- > -- >>> [periodStart "day" "2026-05-26", periodStart "month" "2026-05-26"] > -- ["2026-05-26","2026-05-01"] > periodStart :: T.Text -> T.Text -> T.Text > periodStart "week" today = shiftDay (negate (weekdayOf today - 1)) today > periodStart "month" today = monthOf today <> "-01" > periodStart _ today = today > > -- | Longest run of consecutive days with NO tick within @[start..end]@ > -- ordinals --- a negative counter's "best" (the longest stretch you stayed > -- at zero). > -- > -- >>> longestZeroRun [2,5] 1 7 > -- 2 > longestZeroRun :: [Integer] -> Integer -> Integer -> Int > longestZeroRun ticks start end = snd (foldl step (0, 0) [start .. end]) > where step (cur, best) d > | d `elem` ticks = (0, best) > | otherwise = let c = cur + 1 in (c, max best c) > > -- | Render a counter's window value with its polarity. A positive > -- counter reads as-is; a negative ("less is better") counter shows the > -- count as a deficit, with a leading minus, so the sign carries the > -- meaning and no "(less)" tag is needed. Zero shows plain (no "-0"). > -- Every surface renders counter values through this one chokepoint, so > -- the sign can never be honoured on one page and forgotten on another. > -- > -- >>> map (counterShow (T.pack "neg")) [0, 2] > -- ["0","-2"] > -- > -- >>> map (counterShow (T.pack "pos")) [0, 3] > -- ["0","3"] > counterShow :: T.Text -> Int -> T.Text > counterShow pol n > | pol == "neg" && n > 0 = "-" <> tshow n > | otherwise = tshow n > > -- | The window phrase for a counter's current value, by period. > -- > -- >>> map periodWindow ["day","week","month"] > -- ["today","this week","this month"] > periodWindow :: T.Text -> T.Text > periodWindow "week" = "this week" > periodWindow "month" = "this month" > periodWindow _ = "today" > > -- | The single-period noun, for record labels ("best week", "quietest > -- month"), so a hiscore always says which window its number covers. > -- > -- >>> map periodUnit ["day","week","month"] > -- ["day","week","month"] > periodUnit :: T.Text -> T.Text > periodUnit "week" = "week" > periodUnit "month" = "month" > periodUnit _ = "day" > > -- | Sum per-day tallies into one total per period bucket (day/week/ > -- month), so records read in the counter's own window. A period with no > -- ticks has no bucket (it surfaces in the clean-streak, not as a zero > -- here). Pure. > -- > -- >>> sort (periodTotals "month" [("2026-05-03",2),("2026-05-20",1),("2026-04-09",4)]) > -- [3,4] > -- > -- >>> sort (periodTotals "day" [("2026-05-03",2),("2026-05-03",1),("2026-05-04",5)]) > -- [3,5] > periodTotals :: T.Text -> [(T.Text, Int)] -> [Int] > periodTotals p dayN = map snd (periodTotalsKeyed p dayN) > > -- | Like 'periodTotals' but keeps the period key alongside each sum, > -- so a record can be anchored to the period it was set in (best week > -- of, quietest month of). Pure. > periodTotalsKeyed :: T.Text -> [(T.Text, Int)] -> [(T.Text, Int)] > periodTotalsKeyed period dayN = > [ (fst (head g), sum (map snd g)) > | g <- groupBy ((==) `on` fst) (sortOn fst keyed) ] > where keyed = [ (periodKey d, n) | (d, n) <- dayN ] > periodKey d = case period of > "week" -> periodStart "week" d > "month" -> monthOf d > _ -> d > > -- | The counters page: each counter shows its current-window value (and > -- goal), a @+1@ tap, and an undo. One tap = one tally. > countersView :: Ctx -> T.Text -> IO () > countersView ctx key = do > let conn = ctxConn ctx > today <- todayDay > cs <- query conn > "SELECT id, name, period, polarity FROM counter WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, T.Text, T.Text)] > rows <- forM cs $ \(cid, name, period, pol) -> do > let ws = periodStart period today > vs <- query conn "SELECT COALESCE(SUM(n),0) FROM counter_tick WHERE jkey=? AND cid=? AND day>=?" > (key, cid, ws) :: IO [Only Int] > tvs <- query conn "SELECT COALESCE(SUM(n),0) FROM counter_tick WHERE jkey=? AND cid=? AND day=?" > (key, cid, today) :: IO [Only Int] > let val = case vs of (Only x : _) -> x; _ -> 0 > todayVal = case tvs of (Only x : _) -> x; _ -> 0 > todayTag = if period == "day" then "" > else " (" <> counterShow pol todayVal <> " today)" > pure [ infoLine (clamp 24 name <> " " <> counterShow pol val <> " " > <> periodWindow period <> todayTag) > , link ctx " log one" ("/k/" <> key <> "/counters/tick/" <> tshow cid) > , link ctx " undo" ("/k/" <> key <> "/counters/undo/" <> tshow cid) > , infoLine "" ] > page ctx $ > [ infoLine "counters --- tap 'log one' each time it happens", infoLine "" ] > ++ (if null cs then [ infoLine "no counters yet. add one below." ] else concat rows) > ++ [ infoLine "" > , search ctx "+ add a counter (a name; prefix - for 'less is better')" > ("/k/" <> key <> "/counters/add") > , link ctx "manage counters (period / type / archive)" ("/k/" <> key <> "/counters/manage") > , link ctx "back to the journal" ("/k/" <> key) ] > > addCounter :: Ctx -> T.Text -> T.Text -> IO () > addCounter ctx key q = do > case parseCounter q of > Just (pol, nm) -> do > today <- todayDay > execute (ctxConn ctx) > "INSERT INTO counter (jkey, name, period, polarity, goal, archived, created)\ > \ VALUES (?,?,'day',?,NULL,0,?)" (key, nm, pol, today) > logEvent (ctxConn ctx) key "counter_add" nm > Nothing -> pure () > countersView ctx key > > -- | @+1@ for today (idempotent only in the sense of being a named bump: > -- each tap genuinely adds one --- a count is a create, not a toggle). > tickCounter :: Ctx -> T.Text -> Int -> IO () > tickCounter ctx key cid = do > let conn = ctxConn ctx > today <- todayDay > owned <- query conn "SELECT name FROM counter WHERE id=? AND jkey=? AND archived=0" > (cid, key) :: IO [Only T.Text] > when (not (null owned)) $ do > execute conn > "INSERT INTO counter_tick (jkey, cid, day, n) VALUES (?,?,?,1)\ > \ ON CONFLICT(cid, day) DO UPDATE SET n = n + 1" (key, cid, today) > case owned of > (Only n : _) -> logEvent conn key "counter_tick" n > _ -> pure () > countersView ctx key > > undoCounter :: Ctx -> T.Text -> Int -> IO () > undoCounter ctx key cid = do > today <- todayDay > let conn = ctxConn ctx > nmRow <- query conn "SELECT name FROM counter WHERE id=? AND jkey=?" (cid, key) > :: IO [Only T.Text] > execute conn > "UPDATE counter_tick SET n = CASE WHEN n > 0 THEN n - 1 ELSE 0 END\ > \ WHERE cid=? AND day=? AND jkey=?" (cid, today, key) > case nmRow of > (Only n : _) -> logEvent conn key "counter_undo" n > _ -> pure () > countersView ctx key > > counterManageView :: Ctx -> T.Text -> IO () > counterManageView ctx key = do > cs <- query (ctxConn ctx) > "SELECT id, name, period, polarity, archived FROM counter WHERE jkey=? ORDER BY archived, id" > (Only key) :: IO [(Int, T.Text, T.Text, T.Text, Int)] > let row (cid, name, period, pol, arch) = > let (lbl, verb) = if arch == 1 then ("[restore] ", "cunarch") else ("[archive] ", "carch") > polTxt = if pol == "neg" then "stay-under" else "count-up" > in [ link ctx (lbl <> clamp 24 name) > ("/k/" <> key <> "/counters/" <> verb <> "/" <> tshow cid) > , link ctx (" period: " <> period <> " (change)") > ("/k/" <> key <> "/counters/period/" <> tshow cid) > , link ctx (" type: " <> polTxt <> " (flip)") > ("/k/" <> key <> "/counters/polarity/" <> tshow cid) > , infoLine "" ] > page ctx $ > [ infoLine "manage counters" > , infoLine "tap to archive, change the window, or flip count-up/stay-under.", infoLine "" ] > ++ (if null cs then [ infoLine "no counters yet." ] else concatMap row cs) > ++ [ infoLine "", link ctx "back to counters" ("/k/" <> key <> "/counters") ] > > setCounterArch :: Ctx -> T.Text -> Int -> Int -> IO () > setCounterArch ctx key v cid = do > execute (ctxConn ctx) "UPDATE counter SET archived=? WHERE id=? AND jkey=?" (v, cid, key) > counterManageView ctx key > > -- | Cycle a counter's window: day -> week -> month -> day. > cycleCounterPeriod :: Ctx -> T.Text -> Int -> IO () > cycleCounterPeriod ctx key cid = do > let conn = ctxConn ctx > ps <- query conn "SELECT period FROM counter WHERE id=? AND jkey=?" (cid, key) :: IO [Only T.Text] > let next = (case ps of (Only "day" : _) -> "week"; (Only "week" : _) -> "month"; _ -> "day") :: T.Text > execute conn "UPDATE counter SET period=? WHERE id=? AND jkey=?" (next, cid, key) > counterManageView ctx key > > -- | Flip a counter's polarity: count-up <-> stay-under. > flipCounterPolarity :: Ctx -> T.Text -> Int -> IO () > flipCounterPolarity ctx key cid = do > let conn = ctxConn ctx > ps <- query conn "SELECT polarity FROM counter WHERE id=? AND jkey=?" (cid, key) :: IO [Only T.Text] > let next = (case ps of (Only "pos" : _) -> "neg"; _ -> "pos") :: T.Text > execute conn "UPDATE counter SET polarity=? WHERE id=? AND jkey=?" (next, cid, key) > counterManageView ctx key > > -- | Current-window value per active counter, for the /stats section. > gatherCounterStats :: Connection -> T.Text -> T.Text -> IO [(T.Text, T.Text, T.Text, Int, Int)] > gatherCounterStats conn key today = do > cs <- query conn > "SELECT id, name, period, polarity FROM counter WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, T.Text, T.Text)] > forM cs $ \(cid, name, period, pol) -> do > let ws = periodStart period today > vsP <- query conn "SELECT COALESCE(SUM(n),0) FROM counter_tick WHERE jkey=? AND cid=? AND day>=?" > (key, cid, ws) :: IO [Only Int] > vsT <- query conn "SELECT COALESCE(SUM(n),0) FROM counter_tick WHERE jkey=? AND cid=? AND day=?" > (key, cid, today) :: IO [Only Int] > let getV vs = case vs of (Only x : _) -> x; _ -> 0 > pure (name, period, pol, getV vsP, getV vsT) > > -- | Render the counters section. Daily counters get one line (today > -- is already the whole window); weekly and monthly counters get the > -- window value AND a "today" line beneath, so you can see where in > -- the window you are without doing the subtraction in your head. > renderCounterStats :: [(T.Text, T.Text, T.Text, Int, Int)] -> [T.Text] > renderCounterStats [] = [] > renderCounterStats rs = [ infoLine "", divider "counters" ] ++ concatMap one rs > where one (name, period, pol, periodVal, todayVal) = > metricTOC (name <> " " <> periodWindow period) (counterShow pol periodVal) > ++ (if period == "day" then [] > else metricTOC (name <> " today") (counterShow pol todayVal)) > > -- | Per-counter all-time records for /hiscores. Positive counters > -- celebrate highs and runs; negative ones celebrate the longest stretch > -- held at zero. All from existing ticks, via the pure bucket maths. > data CounterRec = CounterRec > { crName :: T.Text, crPol :: T.Text, crPeriod :: T.Text > , crBest :: Int, crBestOn :: T.Text -- best period total + which period > , crQuiet :: Int, crQuietOn :: T.Text -- quietest active period + which one > , crLifetime :: Int, crStreak :: Int, crZeroRun :: Int } > > gatherCounterRecs :: Connection -> T.Text -> T.Text -> IO [CounterRec] > gatherCounterRecs conn key today = do > cs <- query conn > "SELECT id, name, polarity, period, created FROM counter WHERE jkey=? AND archived=0 ORDER BY id" > (Only key) :: IO [(Int, T.Text, T.Text, T.Text, T.Text)] > forM cs $ \(cid, name, pol, period, created) -> do > dayN <- query conn "SELECT day, n FROM counter_tick WHERE jkey=? AND cid=? AND n>0" > (key, cid) :: IO [(T.Text, Int)] > let ords = mapMaybe dayNum (map fst dayN) > pts = periodTotalsKeyed period dayN > pure CounterRec > { crName = name, crPol = pol, crPeriod = period > , crBest = maxOr0 (map snd pts) > , crBestOn = argmaxBy "" pts > , crQuiet = if null pts then 0 else minimum (map snd pts) > , crQuietOn = argminBy "" pts > , crLifetime = sum (map snd dayN) > , crStreak = longestStreak ords > , crZeroRun = case (dayNum created, dayNum today) of > (Just s, Just e) -> longestZeroRun ords s e > _ -> 0 } > > renderCounterRecs :: [CounterRec] -> [T.Text] > renderCounterRecs [] = [] > renderCounterRecs crs = > let blocks = filter (not . null) (map block crs) > in if null blocks then [] > else [ infoLine "", divider "counters" ] > ++ concat (intersperse [infoLine ""] blocks) > where > block cr = let sl = sublines cr > in if null sl then [] else infoLine (" " <> crName cr) : sl > sublines cr > | crPol cr == "neg" = > (if crZeroRun cr > 0 > then subMetricTOC "clean streak" (plural (crZeroRun cr) "day") > else []) > ++ (if crPeriod cr /= "day" && crQuiet cr > 0 && not (T.null (crQuietOn cr)) > then subMetricTOC ("quietest " <> periodUnit (crPeriod cr)) > (tshow (crQuiet cr) <> " . " <> periodAnchor (crPeriod cr) (crQuietOn cr)) > else []) > | otherwise = > (if crBest cr > 0 && not (T.null (crBestOn cr)) > then subMetricTOC ("best " <> periodUnit (crPeriod cr)) > (tshow (crBest cr) <> " . " <> periodAnchor (crPeriod cr) (crBestOn cr)) > else []) > ++ (if crStreak cr > 0 > then subMetricTOC "run" (plural (crStreak cr) "day") > else []) > ++ (if crLifetime cr > 0 > then subMetricTOC "lifetime" (tshow (crLifetime cr) <> " total") > else []) > -- | The "meta" hub: the review-and-export doors, gathered off the busy > -- front page so the journal itself stays about doing. > metaView :: Ctx -> T.Text -> IO () > metaView ctx key = page ctx > [ infoLine "meta (read only) --- review & export", infoLine "" > , link ctx "your stats" ("/k/" <> key <> "/stats") > , link ctx "your hiscores (personal bests)" ("/k/" <> key <> "/hiscores") > , textLink ctx "read / export the whole journal (text)" ("/k/" <> key <> "/txt") > , textLink ctx "open your diary" ("/k/" <> key <> "/diary") > , infoLine "" > , link ctx "back to the journal" ("/k/" <> key) ] > > notFound :: Ctx -> IO () > notFound ctx = page ctx > [ errorItem "no journal here." > , infoLine "the link may be mistyped, or this journal never existed." > , infoLine "" > , link ctx "start a new journal" "/new" > ] Request parsing and dispatch ---------------------------- Venusia passes positional argv: `$selector`, `$search`, `$pathinfo`, and (if forwarded) `$remote_ip`. The cons pattern degrades gracefully for manual testing and aborts loudly on empty argv. `mainBody` derives the mount point by subtracting path-info off the selector, splits path-info into segments, and routes on `(segments, hasQuery)`; key/id/month validators live in the guards, so anything malformed falls straight through to the not-found page. > data Req = Req > { reqSel :: T.Text > , reqQ :: T.Text > , reqP :: T.Text > } > > parseArgs :: [String] -> Req > parseArgs (s:q:p:_) = Req (T.pack s) (T.pack q) (T.pack p) > parseArgs (s:q:_) = Req (T.pack s) (T.pack q) T.empty > parseArgs [s] = Req (T.pack s) T.empty T.empty > parseArgs [] = error > "bujo.lhs: missing argv[0] (gopher selector). Run by Venusia this is\ > \ automatic; for manual testing pass selector + search + path-info,\ > \ e.g. `./bujo.lhs /applets/bujo.lhs '' ''`." > > main :: IO () > main = do > hSetBuffering stdout NoBuffering > hSetEncoding stdout utf8 > result <- try mainBody :: IO (Either SomeException ()) > case result of > Right () -> pure () > Left e -> mapM_ putLine [ errorItem ("bujo.lhs crashed: " <> tshow e), "." ] > > -- | For a non-idempotent route (a create, or the migrate commit), the > -- clean sub-path to offer as "refresh safely here" --- because re-fetching > -- the action URL would repeat it (a duplicate task, a re-archive). Returns > -- Nothing for idempotent routes (done/star/etc.), which are refresh-safe. > -- > -- >>> [mutationClean ["k","x","add"] True, mutationClean ["k","x","add"] False, mutationClean ["k","x","counters","add"] True] > -- [Just "",Nothing,Just "/counters"] > mutationClean :: [T.Text] -> Bool -> Maybe T.Text > mutationClean segs hasQ = case segs of > ["k", _, "add"] | hasQ -> Just "" > ["k", _, "habits", "add"] | hasQ -> Just "/habits" > ["k", _, "timers", "add"] | hasQ -> Just "/timers" > ["k", _, "timers", "setworked", _] | hasQ -> Just "/timers" > ["k", _, "counters", "add"] | hasQ -> Just "/counters" > ["k", _, "counters", "tick", _] -> Just "/counters" > ["k", _, "counters", "undo", _] -> Just "/counters" > ["k", _, "migrate", "go"] -> Just "" > ["k", _, "migrate", "del"] -> Just "" > _ -> Nothing > > -- | Stamp the journal with the most recent user action so the top-of- > -- page header can show "last: ticked lyft . 2:14pm" no matter which > -- page the user lands on next. One UPDATE per mutation, bounded (one > -- row per journal). Counter ticks/undos are included on purpose --- > -- honest continuity over curated quiet. > logEvent :: Connection -> T.Text -> T.Text -> T.Text -> IO () > logEvent conn key kind ref = do > now <- nowEpoch > execute conn "UPDATE journal SET last_kind=?, last_ref=?, last_ts=? WHERE key=?" > (kind, ref, now, key) > > -- | The user-facing verb for an action kind. Drives the "last: > -- " header so each kind reads naturally. > -- > -- >>> map actVerb [T.pack "task_done", T.pack "counter_tick", T.pack "timer_credit", T.pack "unknown"] > -- ["done","logged","credited","did"] > actVerb :: T.Text -> T.Text > actVerb "task_done" = "done" > actVerb "task_open" = "reopened" > actVerb "task_add" = "added" > actVerb "task_trash" = "trashed" > actVerb "task_restore" = "restored" > actVerb "note_trash" = "deleted note" > actVerb "note_restore" = "restored note" > actVerb "star" = "starred" > actVerb "unstar" = "unstarred" > actVerb "migrate_carry" = "carried" > actVerb "migrate_trash" = "trashed via migrate" > actVerb "habit_check" = "checked" > actVerb "habit_uncheck" = "unchecked" > actVerb "habit_add" = "added habit" > actVerb "counter_tick" = "logged" > actVerb "counter_undo" = "undid" > actVerb "counter_add" = "added counter" > actVerb "timer_start" = "started" > actVerb "timer_pause" = "paused" > actVerb "timer_done" = "completed" > actVerb "timer_reset" = "reset" > actVerb "timer_credit" = "credited" > actVerb "timer_setworked" = "set worked time on" > actVerb "timer_add" = "added timer" > actVerb _ = "did" > > mainBody :: IO () > mainBody = do > req <- parseArgs <$> getArgs > host <- maybe defaultHost T.pack <$> lookupEnv "GOPHER_HOST" > port <- maybe defaultPort T.pack <$> lookupEnv "GOPHER_PORT" > dbp <- fromMaybe defaultDb <$> lookupEnv "BUJO_DB" > conn <- openDb dbp > let pinfo = reqP req > scriptSel = T.dropEnd (T.length pinfo) (reqSel req) > segs = filter (not . T.null) (T.splitOn "/" pinfo) > query' = T.strip (reqQ req) > hasQuery = not (T.null query') > -- The current journal key, if the route is keyed. `page` reads > -- this to drive the last-action / active-timer headers AFTER > -- dispatch has committed any mutation --- so the header reflects > -- the action that was just performed, not the previous one. > cKey = case segs of > ("k" : k : _) | validKey k -> Just k > _ -> Nothing > ctx = Ctx scriptSel host port conn cKey segs query' > dispatch ctx segs query' hasQuery > close conn > > dispatch :: Ctx -> [T.Text] -> T.Text -> Bool -> IO () > dispatch ctx segs q hasQuery = case (segs, hasQuery) of > ([], _ ) -> frontDoor ctx > (["new"], _ ) -> createJournal ctx > (["k", k], False) | validKey k -> home ctx k > (["k", k, "add"], True ) | validKey k -> addTask ctx k q > (["k", k, "add"], False) | validKey k -> home ctx k > (["k", k, "done", i], _ ) | validKey k, Just n <- readId i -> setTaskState ctx k "done" n (home ctx k) > (["k", k, "open", i], _ ) | validKey k, Just n <- readId i -> setTaskState ctx k "open" n (home ctx k) > (["k", k, "done", i, "s"],_ ) | validKey k, Just n <- readId i -> setTaskState ctx k "done" n (starredView ctx k) > (["k", k, "open", i, "s"],_ ) | validKey k, Just n <- readId i -> setTaskState ctx k "open" n (starredView ctx k) > (["k", k, "mig", i], _ ) | validKey k, Just n <- readId i -> setPmig ctx k 1 n (home ctx k) > (["k", k, "unmig", i], _ ) | validKey k, Just n <- readId i -> setPmig ctx k 0 n (home ctx k) > (["k", k, "migrate"], _) | validKey k -> earlyMigrateView ctx k > (["k", k, "migrate", "go"], _) | validKey k -> earlyMigrate ctx k > (["k", k, "migrate", "del"], _) | validKey k -> migrateDelete ctx k > (["k", k, "migrate","pick",i],_) | validKey k, Just n <- readId i -> setPmig ctx k 1 n (earlyMigrateView ctx k) > (["k", k, "migrate","drop",i],_) | validKey k, Just n <- readId i -> setPmig ctx k 0 n (earlyMigrateView ctx k) > (["k", k, "restore", i],_ ) | validKey k, Just n <- readId i -> restore ctx k n > (["k", k, "trash"], _ ) | validKey k -> trashView ctx k > (["k", k, "untrash", i],_ ) | validKey k, Just n <- readId i -> untrash ctx k n > (["k", k, "notes"], _ ) | validKey k -> notesView ctx k > (["k", k, "notes","del",i], _) | validKey k, Just n <- readId i -> notesDelete ctx k n > (["k", k, "start"], _ ) | validKey k -> finishMigration ctx k > (["k", k, "focus"], _ ) | validKey k -> focusView ctx k > (["k", k, "starred"], _ ) | validKey k -> starredView ctx k > (["k", k, "star", i], _ ) | validKey k, Just n <- readId i -> setStar ctx k 1 n > (["k", k, "unstar", i], _ ) | validKey k, Just n <- readId i -> setStar ctx k 0 n > (["k", k, "txt"], _ ) | validKey k -> exportTxt ctx k > (["k", k, "diary"], _ ) | validKey k -> exportNotes ctx k > (["k", k, "stats"], _ ) | validKey k -> statsView ctx k > (["k", k, "meta"], _ ) | validKey k -> metaView ctx k > (["k", k, "hidedone"], _ ) | validKey k -> setHideDone ctx k 1 > (["k", k, "showdone"], _ ) | validKey k -> setHideDone ctx k 0 > (["k", k, "hiscores"], _ ) | validKey k -> recordsView ctx k > (["k", k, "search", "run", i], _) | validKey k, Just n <- readId i -> runFind ctx k n > (["k", k, "search", "forget", i], _) | validKey k, Just n <- readId i -> forgetFind ctx k n > (["k", k, "search", "pin", e], _) | validKey k -> pinFind ctx k e > (["k", k, "search"], True ) | validKey k -> searchView ctx k q > (["k", k, "search"], False) | validKey k -> home ctx k > (["k", k, "habits"], _ ) | validKey k -> habitsView ctx k > (["k", k, "habits", "add"], True) | validKey k -> addHabit ctx k q > (["k", k, "habits", "add"], False)| validKey k -> habitsView ctx k > (["k", k, "habits", "manage"],_ ) | validKey k -> manageHabits ctx k > (["k", k, "hcheck", i], _ ) | validKey k, Just n <- readId i -> setCheck ctx k True n > (["k", k, "huncheck", i], _ ) | validKey k, Just n <- readId i -> setCheck ctx k False n > (["k", k, "harch", i], _ ) | validKey k, Just n <- readId i -> setArch ctx k 1 n > (["k", k, "hunarch", i], _ ) | validKey k, Just n <- readId i -> setArch ctx k 0 n > (["k", k, "timers"], _) | validKey k -> timersView ctx k > (["k", k, "timers", "add"], True) | validKey k -> addTimer ctx k q > (["k", k, "timers", "add"], False) | validKey k -> timersView ctx k > (["k", k, "timers", "start", i], _) | validKey k, Just n <- readId i -> startTimer ctx k n > (["k", k, "timers", "stop", i], _) | validKey k, Just n <- readId i -> stopTimer ctx k n > (["k", k, "timers", "single", v],_) | validKey k -> setSingleTimer ctx k (if v == "1" then 1 else 0) > (["k", k, "timers", "manage"], _) | validKey k -> timerManageView ctx k > (["k", k, "timers","settime",i], True) | validKey k, Just n <- readId i -> setTimerMins ctx k n q > (["k", k, "timers","settime",i], False)| validKey k, Just n <- readId i -> timerManageView ctx k > (["k", k, "timers","setworked",i], True) | validKey k, Just n <- readId i -> setTimerWorked ctx k n q > (["k", k, "timers","setworked",i], False)| validKey k, Just n <- readId i -> timersView ctx k > (["k", k, "timers", "reset", i], _) | validKey k, Just n <- readId i -> resetTimer ctx k n > (["k", k, "timers", "credit", i], _) | validKey k, Just n <- readId i -> creditTimer ctx k n > (["k", k, "timers", "tarch", i], _) | validKey k, Just n <- readId i -> setTimerArch ctx k 1 n > (["k", k, "timers", "tunarch", i],_) | validKey k, Just n <- readId i -> setTimerArch ctx k 0 n > (["k", k, "timers", "link", i], _) | validKey k, Just n <- readId i -> timerLinkView ctx k n > (["k", k, "timers","sethabit",i,h],_) | validKey k, Just n <- readId i, Just hh <- readId h -> setTimerHabit ctx k n hh > (["k", k, "timers", "unlink", i],_) | validKey k, Just n <- readId i -> setTimerHabit ctx k n 0 > (["k", k, "counters"], _) | validKey k -> countersView ctx k > (["k", k, "counters", "add"], True) | validKey k -> addCounter ctx k q > (["k", k, "counters", "add"], False) | validKey k -> countersView ctx k > (["k", k, "counters", "tick", i], _) | validKey k, Just n <- readId i -> tickCounter ctx k n > (["k", k, "counters", "undo", i], _) | validKey k, Just n <- readId i -> undoCounter ctx k n > (["k", k, "counters", "manage"], _) | validKey k -> counterManageView ctx k > (["k", k, "counters", "carch", i],_) | validKey k, Just n <- readId i -> setCounterArch ctx k 1 n > (["k", k, "counters", "cunarch", i],_) | validKey k, Just n <- readId i -> setCounterArch ctx k 0 n > (["k", k, "counters", "period", i],_) | validKey k, Just n <- readId i -> cycleCounterPeriod ctx k n > (["k", k, "counters", "polarity", i],_) | validKey k, Just n <- readId i -> flipCounterPolarity ctx k n > (["k", k, "archive"], _ ) | validKey k -> archiveIndex ctx k > (["k", k, "archive", m],_ ) | validKey k -> archiveMonth ctx k m > _ -> notFound ctx