amadan
carlos / todomvc-bakeoff Public
feat(haskell): TodoMVC on warp, lucid2 and sqlite-simple
Server-rendered pages and plain form posts, with app.js swapping in fragments when JavaScript is on. Builds on x86 with ghcup's GHC and for linux-arm64 inside the arm64 root.
Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
18 files changed,
+1296
−0
apps/haskell/.gitignore+6 −0apps/haskell/AGENTS.md+31 −0apps/haskell/DEPS+10 −0apps/haskell/Makefile+68 −0apps/haskell/app/Main.hs+125 −0apps/haskell/cabal.project+12 −0apps/haskell/cabal.project.arm64+5 −0apps/haskell/src/Todo/App.hs+199 −0apps/haskell/src/Todo/Assets.hs+20 −0apps/haskell/src/Todo/Cookie.hs+73 −0apps/haskell/src/Todo/Db.hs+135 −0apps/haskell/src/Todo/Form.hs+32 −0apps/haskell/src/Todo/Html.hs+123 −0apps/haskell/src/Todo/Model.hs+72 −0apps/haskell/static/app.css+45 −0apps/haskell/static/app.js+88 −0apps/haskell/test/Spec.hs+178 −0apps/haskell/todo-haskell.cabal+74 −0
diff --git a/apps/haskell/.gitignore b/apps/haskell/.gitignore| new file mode 100644 |
| index 0000000..9ba9ea5 |
| --- /dev/null |
| +++ b/apps/haskell/.gitignore |
| @@ -0,0 +1,6 @@ |
| +.cache/ |
| +dist/ |
| +dist-newstyle/ |
| +gen/ |
| +*.db |
| +*.db-* |
diff --git a/apps/haskell/AGENTS.md b/apps/haskell/AGENTS.md| new file mode 100644 |
| index 0000000..1591269 |
| --- /dev/null |
| +++ b/apps/haskell/AGENTS.md |
| @@ -0,0 +1,31 @@ |
| +# 🤖 AGENTS.md: todo-haskell |
| + |
| +The one rule: **every visitor's list is theirs alone.** Every query that |
| +reads or changes a todo is scoped to the list named by the caller's own |
| +cookie, and a request naming anything outside that list changes nothing |
| +and answers 404. |
| + |
| +## Tenancy |
| + |
| +- **One instance for the whole app.** `todo-haskell` runs as a single |
| + Carloku instance on `todo-haskell.bfj.oncarlos.com`, with one SQLite |
| + file. |
| +- **Each visitor's list is kept separately by an anonymous cookie.** The |
| + first visit mints a random 256-bit value, stores it as a row in |
| + `lists`, and sets it as the `todo_list` cookie (`HttpOnly; |
| + SameSite=Lax; Path=/`, plus `Secure` over https). A value the app |
| + doesn't hold gets a fresh empty list, never an error. |
| +- **No sign-in.** Losing the cookie loses the list; that's accepted. |
| +- **Trust class C.** The todo text is stored in SQLite as plain text. The |
| + operator can read it. That's a deliberate choice for a demo app, not an |
| + oversight, and nobody should store anything secret in it. |
| + |
| +## Rules for changing this app |
| + |
| +- Work only in `apps/haskell/`. The bakeoff's `BRIEF.md` and |
| + `CONTRACT.md` are binding. |
| +- Migrations only ever add. Never drop or rewrite a table or a column. |
| +- Servers bind `127.0.0.1` or a unix socket, nothing else. |
| +- Cabal's store lives under `.cache/`, set by the `Makefile`. Don't |
| + point it anywhere shared. |
| +- Commits end with a `Co-Authored-By:` trailer naming the model. |
diff --git a/apps/haskell/DEPS b/apps/haskell/DEPS| new file mode 100644 |
| index 0000000..722e083 |
| --- /dev/null |
| +++ b/apps/haskell/DEPS |
| @@ -0,0 +1,10 @@ |
| +cookie |
| +file-embed |
| +hspec |
| +http-types |
| +lucid2 |
| +network |
| +sqlite-simple |
| +wai |
| +wai-extra |
| +warp |
diff --git a/apps/haskell/Makefile b/apps/haskell/Makefile| new file mode 100644 |
| index 0000000..32fb769 |
| --- /dev/null |
| +++ b/apps/haskell/Makefile |
| @@ -0,0 +1,68 @@ |
| +# todo-haskell. Every cabal store and build directory lives under .cache/, |
| +# so nothing here touches ~/.cabal or the arm64 root's /root. |
| +# |
| +# The x86 build uses ghcup's GHC 9.10.3. The shipped linux-arm64 binary is |
| +# built inside the emulated arm64 root (scripts/arm64.sh) with Debian's |
| +# GHC 9.6.6, linked fully static. |
| + |
| +ROOT := $(abspath ../..) |
| +CACHE := $(abspath .cache) |
| +ARM64 := $(ROOT)/scripts/arm64.sh |
| +VERSION := $(shell git rev-parse --short HEAD) |
| +MESSAGE ?= Deploy $(VERSION) |
| + |
| +export PATH := $(HOME)/.ghcup/bin:$(PATH) |
| + |
| +# ghcup's GHC links -lgmp, and this machine has only libgmp.so.10, so |
| +# .cache/x86-lib holds the libgmp.so link the linker looks for. |
| +X86_CABAL := CABAL_DIR=$(CACHE)/cabal-x86 LIBRARY_PATH=$(CACHE)/x86-lib cabal |
| +ARM64_CABAL := $(ARM64) env CABAL_DIR=$(CACHE)/cabal-arm64 cabal |
| + |
| +X86_BIN := $(CACHE)/dist-x86/build/x86_64-linux/ghc-9.10.3/todo-haskell-0.1.0.0/x/todo-haskell/build/todo-haskell/todo-haskell |
| +ARM64_BIN := $(CACHE)/dist-arm64/build/aarch64-linux/ghc-9.6.6/todo-haskell-0.1.0.0/x/todo-haskell/build/todo-haskell/todo-haskell |
| + |
| +.PHONY: build build-arm64 test clean clean-deps bump unbump deploy FORCE |
| + |
| +build: gen/BuildVersion.hs $(CACHE)/x86-lib/libgmp.so |
| + $(X86_CABAL) build -j --builddir=$(CACHE)/dist-x86 exe:todo-haskell |
| + @mkdir -p dist |
| + cp $(X86_BIN) dist/app.new && mv dist/app.new dist/app |
| + |
| +build-arm64: gen/BuildVersion.hs |
| + @[ -d $(CACHE)/cabal-arm64/packages ] || $(ARM64_CABAL) update |
| + $(ARM64_CABAL) build -j --project-file=cabal.project.arm64 --builddir=$(CACHE)/dist-arm64 exe:todo-haskell |
| + @mkdir -p dist |
| + cp $(ARM64_BIN) dist/app-linux-arm64.new && mv dist/app-linux-arm64.new dist/app-linux-arm64 |
| + |
| +test: gen/BuildVersion.hs $(CACHE)/x86-lib/libgmp.so |
| + $(X86_CABAL) test -j --enable-tests --builddir=$(CACHE)/dist-x86-test --test-show-details=direct |
| + |
| +clean: |
| + rm -rf dist $(CACHE)/dist-x86 $(CACHE)/dist-x86-test $(CACHE)/dist-arm64 gen |
| + |
| +# Compiled libraries go; downloaded sources (.cache/cabal-*/packages) stay. |
| +clean-deps: clean |
| + rm -rf $(CACHE)/cabal-x86/store $(CACHE)/cabal-arm64/store |
| + |
| +# The string is Todo.App's serverName, sent as the Server header. |
| +bump: |
| + sed -i 's/^serverName = "todo-haskell"$$/serverName = "todo-haskell (bumped)"/' src/Todo/App.hs |
| + |
| +unbump: |
| + sed -i 's/^serverName = "todo-haskell (bumped)"$$/serverName = "todo-haskell"/' src/Todo/App.hs |
| + |
| +deploy: |
| + carlos deploy --account bfj --app todo-haskell --target linux-arm64 \ |
| + --version $(VERSION) --no-prompt --message "$(MESSAGE)" dist/app-linux-arm64 |
| + |
| +# The build version is the git short SHA, compiled in from a generated |
| +# module. It's rewritten only when the SHA changes, so an unchanged tree |
| +# doesn't recompile. |
| +gen/BuildVersion.hs: FORCE |
| + @mkdir -p gen |
| + @printf 'module BuildVersion (buildVersion) where\n\nbuildVersion :: String\nbuildVersion = "%s"\n' '$(VERSION)' > gen/BuildVersion.hs.new |
| + @if cmp -s gen/BuildVersion.hs.new $@; then rm gen/BuildVersion.hs.new; else mv gen/BuildVersion.hs.new $@; fi |
| + |
| +$(CACHE)/x86-lib/libgmp.so: |
| + @mkdir -p $(dir $@) |
| + ln -sf /usr/lib/x86_64-linux-gnu/libgmp.so.10 $@ |
diff --git a/apps/haskell/app/Main.hs b/apps/haskell/app/Main.hs| new file mode 100644 |
| index 0000000..44fedc2 |
| --- /dev/null |
| +++ b/apps/haskell/app/Main.hs |
| @@ -0,0 +1,125 @@ |
| +-- | @todo-haskell --socket <path> --db <path>@ on Carloku, or |
| +-- @todo-haskell --listen 127.0.0.1:<port> --db <path>@ locally. |
| +module Main (main) where |
| + |
| +import Control.Exception (bracket, catch, throwIO) |
| +import Control.Monad (forM_, unless) |
| +import Data.ByteString.Char8 qualified as B8 |
| +import Data.Text qualified as T |
| +import Data.Word (Word8) |
| +import Network.Socket |
| +import Network.Wai.Handler.Warp |
| +import System.Environment (getArgs, lookupEnv) |
| +import System.Exit (exitWith, ExitCode (..)) |
| +import System.IO (hPutStrLn, stderr) |
| +import System.IO.Error (isDoesNotExistError) |
| +import System.Posix.Files (removeLink) |
| +import System.Posix.Signals (Handler (CatchOnce), installHandler, sigINT, sigTERM) |
| +import Text.Read (readMaybe) |
| + |
| +import Todo.App |
| +import Todo.Db qualified as Db |
| + |
| +data Bind |
| + = UnixSocket FilePath |
| + | Loopback (Word8, Word8, Word8, Word8) PortNumber |
| + |
| +data Options = Options |
| + { optBind :: Maybe Bind |
| + , optDb :: Maybe FilePath |
| + } |
| + |
| +main :: IO () |
| +main = do |
| + args <- getArgs |
| + (target, dbPath) <- case parseArgs args (Options Nothing Nothing) of |
| + Right (Options (Just b) (Just d)) -> pure (b, d) |
| + Right _ -> usage "both --db and one of --socket or --listen are required" |
| + Left err -> usage err |
| + host <- lookupEnv "CARLOS_HOST" |
| + let config = case target of |
| + -- On Carloku the edge serves https://$CARLOS_HOST. |
| + UnixSocket _ -> Config (B8.pack . ("https://" <>) <$> host) True |
| + Loopback addr port -> Config (Just (B8.pack ("http://" <> showAddr addr port))) False |
| + bracket (Db.open dbPath) Db.close $ \db -> |
| + bracket (listenOn target) (cleanUp target) $ \sock -> do |
| + hPutStrLn stderr ("todo-haskell " <> T.unpack version <> " listening on " <> describe target) |
| + runSettingsSocket settings sock (app config db) |
| + hPutStrLn stderr "todo-haskell stopped" |
| + |
| +-- | Warp closes the listening socket on SIGTERM or SIGINT, lets requests |
| +-- in flight finish (for up to five seconds), and then 'runSettingsSocket' |
| +-- returns, so 'main' closes the database and exits 0. |
| +settings :: Settings |
| +settings = |
| + setInstallShutdownHandler onSignal |
| + . setGracefulShutdownTimeout (Just 5) |
| + $ defaultSettings |
| + where |
| + onSignal closeSocket = |
| + forM_ [sigTERM, sigINT] $ \sig -> installHandler sig (CatchOnce closeSocket) Nothing |
| + |
| +listenOn :: Bind -> IO Socket |
| +listenOn = \case |
| + UnixSocket path -> do |
| + removeIfExists path |
| + sock <- socket AF_UNIX Stream defaultProtocol |
| + bind sock (SockAddrUnix path) |
| + listen sock 1024 |
| + pure sock |
| + Loopback addr port -> do |
| + sock <- socket AF_INET Stream defaultProtocol |
| + setSocketOption sock ReuseAddr 1 |
| + bind sock (SockAddrInet port (tupleToHostAddress addr)) |
| + listen sock 1024 |
| + pure sock |
| + |
| +cleanUp :: Bind -> Socket -> IO () |
| +cleanUp target sock = do |
| + close sock |
| + case target of |
| + UnixSocket path -> removeIfExists path |
| + Loopback _ _ -> pure () |
| + |
| +removeIfExists :: FilePath -> IO () |
| +removeIfExists path = removeLink path `catch` \e -> unless (isDoesNotExistError e) (throwIO e) |
| + |
| +parseArgs :: [String] -> Options -> Either String Options |
| +parseArgs args o = case args of |
| + [] -> Right o |
| + "--socket" : path : rest -> parseArgs rest o {optBind = Just (UnixSocket path)} |
| + "--listen" : addr : rest -> do |
| + b <- parseListen addr |
| + parseArgs rest o {optBind = Just b} |
| + "--db" : path : rest -> parseArgs rest o {optDb = Just path} |
| + flag : _ -> Left ("unexpected argument " <> show flag) |
| + |
| +-- | Only an IPv4 loopback address: this app never listens anywhere else. |
| +parseListen :: String -> Either String Bind |
| +parseListen s = case break (== ':') s of |
| + (host, ':' : portText) |
| + | Just [a, b, c, d] <- traverse readMaybe (splitOn '.' host) |
| + , Just port <- readMaybe portText |
| + , a == 127 |
| + , all (<= 255) [b, c, d] |
| + , port > 0 && port < (65536 :: Int) -> |
| + Right (Loopback (fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral (d :: Int)) (fromIntegral port)) |
| + _ -> Left ("--listen wants 127.0.0.1:<port>, not " <> show s) |
| + where |
| + splitOn sep str = case break (== sep) str of |
| + (part, []) -> [part] |
| + (part, _ : rest) -> part : splitOn sep rest |
| + |
| +showAddr :: (Word8, Word8, Word8, Word8) -> PortNumber -> String |
| +showAddr (a, b, c, d) port = concat [show a, ".", show b, ".", show c, ".", show d, ":", show port] |
| + |
| +describe :: Bind -> String |
| +describe = \case |
| + UnixSocket path -> path |
| + Loopback addr port -> showAddr addr port |
| + |
| +usage :: String -> IO a |
| +usage err = do |
| + hPutStrLn stderr ("todo-haskell: " <> err) |
| + hPutStrLn stderr "usage: todo-haskell (--socket <path> | --listen 127.0.0.1:<port>) --db <path>" |
| + exitWith (ExitFailure 2) |
diff --git a/apps/haskell/cabal.project b/apps/haskell/cabal.project| new file mode 100644 |
| index 0000000..7ff92d1 |
| --- /dev/null |
| +++ b/apps/haskell/cabal.project |
| @@ -0,0 +1,12 @@ |
| +packages: . |
| +-- Pinned so the x86 build and the arm64 build resolve the same versions. |
| +index-state: hackage.haskell.org 2026-10-01T00:00:00Z |
| +constraints: |
| + -- Build network from source like every other library, rather than |
| + -- picking up a copy someone installed into the arm64 root's GHC. |
| + network source, |
| + -- Warp's x509 flag only exposes TLS client certificates, and costs a |
| + -- whole crypto library. The edge terminates TLS, so leave it out. |
| + warp -x509, |
| + -- Compile zlib's C into the binary instead of looking for a system one. |
| + zlib +bundled-c-zlib |
diff --git a/apps/haskell/cabal.project.arm64 b/apps/haskell/cabal.project.arm64| new file mode 100644 |
| index 0000000..c859efa |
| --- /dev/null |
| +++ b/apps/haskell/cabal.project.arm64 |
| @@ -0,0 +1,5 @@ |
| +-- The shipped linux-arm64 build, run inside the arm64 root. One static |
| +-- binary: glibc and everything else linked in. |
| +import: cabal.project |
| +package todo-haskell |
| + ghc-options: -static -optl-static -optl-pthread -optl-s |
diff --git a/apps/haskell/src/Todo/App.hs b/apps/haskell/src/Todo/App.hs| new file mode 100644 |
| index 0000000..fc74990 |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/App.hs |
| @@ -0,0 +1,199 @@ |
| +-- | The WAI application: routing, the visitor's cookie, the origin |
| +-- check, and what each route answers. |
| +module Todo.App |
| + ( Config (..) |
| + , app |
| + , version |
| + , fragmentHeader |
| + ) where |
| + |
| +import Control.Monad (join) |
| +import Data.ByteString (ByteString) |
| +import Data.ByteString.Lazy qualified as BL |
| +import Data.Maybe (fromMaybe) |
| +import Data.Text (Text) |
| +import Data.Text qualified as T |
| +import Data.Text.Encoding qualified as T |
| +import Lucid (Html, renderBS) |
| +import Network.HTTP.Types |
| +import Network.Wai |
| + |
| +import BuildVersion (buildVersion) |
| +import Todo.Assets qualified as Assets |
| +import Todo.Cookie |
| +import Todo.Db (Db) |
| +import Todo.Db qualified as Db |
| +import Todo.Form |
| +import Todo.Html |
| +import Todo.Model |
| + |
| +data Config = Config |
| + { configOrigin :: Maybe ByteString |
| + -- ^ This app's own origin, e.g. @https://todo-haskell.bfj.oncarlos.com@. |
| + -- A POST whose @Origin@ header names any other is refused. |
| + , configSecure :: Bool |
| + -- ^ Served over https, so the cookie gets @Secure@. |
| + } |
| + |
| +-- | The build, as @GET /api/version@ reports it. |
| +version :: Text |
| +version = T.pack buildVersion |
| + |
| +-- | Sent on every response. @make bump@ edits this string to force a |
| +-- recompile of this module. |
| +serverName :: ByteString |
| +serverName = "todo-haskell" |
| + |
| +-- | The request header app.js sends to get 'fragment' back from an |
| +-- action instead of a redirect. |
| +fragmentHeader :: HeaderName |
| +fragmentHeader = "X-Fragment" |
| + |
| +-- | Form bodies past this are refused. A 10,000-character title of |
| +-- four-byte characters, percent-encoded, is about 120 KB. |
| +bodyLimit :: Int |
| +bodyLimit = 1024 * 1024 |
| + |
| +app :: Config -> Db -> Application |
| +app config db req respond = case pathInfo req of |
| + [] -> view All |
| + ["active"] -> view Active |
| + ["completed"] -> view Completed |
| + ["static", "base.css"] -> get $ asset "text/css; charset=utf-8" Assets.baseCss |
| + ["static", "index.css"] -> get $ asset "text/css; charset=utf-8" Assets.indexCss |
| + ["static", "app.css"] -> get $ asset "text/css; charset=utf-8" Assets.appCss |
| + ["static", "app.js"] -> get $ asset "text/javascript; charset=utf-8" Assets.appJs |
| + ["healthz"] -> get $ respond (plain status200 "ok") |
| + ["api", "version"] -> get $ respond (plain status200 (T.encodeUtf8 version)) |
| + ["todos"] -> post $ \list fields -> do |
| + let title = T.strip (fieldText "title" fields) |
| + if T.null title then pure () else Db.addTodo db list title |
| + pure True |
| + ["todos", "toggle-all"] -> post $ \list _ -> True <$ Db.toggleAll db list |
| + ["todos", "clear-completed"] -> post $ \list _ -> True <$ Db.clearCompleted db list |
| + ["todos", raw, verb] |
| + | Just todo <- parseTodoId raw -> case verb of |
| + "toggle" -> post $ \list _ -> Db.toggleTodo db list todo |
| + "destroy" -> post $ \list _ -> Db.deleteTodo db list todo |
| + "edit" -> post $ \list fields -> do |
| + let title = T.strip (fieldText "title" fields) |
| + if T.null title |
| + then Db.deleteTodo db list todo |
| + else Db.renameTodo db list todo title |
| + _ -> respond notFound |
| + _ -> respond notFound |
| + where |
| + method = requestMethod req |
| + |
| + get action |
| + | method == methodGet || method == methodHead = action |
| + | otherwise = respond (allow "GET, HEAD") |
| + |
| + -- GET /, /active, /completed, optionally with ?edit=<id>. |
| + view f = get $ do |
| + (list, cookie) <- visitor |
| + todos <- Db.listTodos db list |
| + let editing = do |
| + raw <- join (lookup "edit" (queryString req)) |
| + todo <- parseTodoId (T.decodeUtf8Lenient raw) |
| + if any (\t -> todoId t == todo && visible f t) todos then Just todo else Nothing |
| + respond . withHeaders cookie $ html status200 (page (View f todos editing version)) |
| + |
| + -- An action: check the origin, read the form, run it against the |
| + -- caller's own list. @run@ answers False when the todo it names isn't |
| + -- in that list. |
| + post run |
| + | method /= methodPost = respond (allow "POST") |
| + | not sameOrigin = respond (plain status403 "cross-origin request refused") |
| + | otherwise = |
| + readFields bodyLimit req >>= \case |
| + Nothing -> respond (plain status413 "form too large") |
| + Just fields -> do |
| + (list, cookie) <- visitor |
| + found <- run list fields |
| + let f = parseFilter (field "filter" fields) |
| + respond . withHeaders cookie =<< if |
| + | not found -> pure notFound |
| + | wantsFragment -> do |
| + todos <- Db.listTodos db list |
| + pure $ html status200 (fragment (View f todos Nothing version)) |
| + | otherwise -> pure $ responseLBS status303 [(hLocation, T.encodeUtf8 (filterPath f)), common] "" |
| + |
| + sameOrigin = case lookup "Origin" (requestHeaders req) of |
| + Nothing -> True |
| + Just origin -> Just origin == configOrigin config |
| + |
| + wantsFragment = lookup fragmentHeader (requestHeaders req) == Just "1" |
| + |
| + -- The caller's list, from their cookie, or a new empty one (and the |
| + -- header that hands them its cookie) if the cookie is missing or names |
| + -- nothing this app holds. |
| + visitor = do |
| + known <- maybe (pure Nothing) (Db.findList db) (readToken (lookup hCookie (requestHeaders req))) |
| + case known of |
| + Just list -> pure (list, []) |
| + Nothing -> do |
| + token <- newToken |
| + list <- Db.createList db token |
| + pure (list, [(hSetCookie, setCookie (configSecure config) token)]) |
| + |
| + asset contentType body = |
| + respond $ |
| + responseLBS |
| + status200 |
| + [ (hContentType, contentType) |
| + , (hContentLength, bytes (BL.fromStrict body)) |
| + , (hCacheControl, "public, max-age=86400") |
| + , common |
| + ] |
| + (BL.fromStrict body) |
| + |
| +fieldText :: Text -> Fields -> Text |
| +fieldText name = fromMaybe "" . field name |
| + |
| +html :: Status -> Html () -> Response |
| +html status doc = |
| + responseLBS |
| + status |
| + [ (hContentType, "text/html; charset=utf-8") |
| + , (hContentLength, bytes body) |
| + , (hCacheControl, "no-store") |
| + , ("Content-Security-Policy", csp) |
| + , ("X-Content-Type-Options", "nosniff") |
| + , ("Referrer-Policy", "same-origin") |
| + , common |
| + ] |
| + body |
| + where |
| + body = renderBS doc |
| + |
| +plain :: Status -> ByteString -> Response |
| +plain status body = |
| + responseLBS |
| + status |
| + [ (hContentType, "text/plain; charset=utf-8") |
| + , (hContentLength, bytes (BL.fromStrict body)) |
| + , (hCacheControl, "no-store") |
| + , common |
| + ] |
| + (BL.fromStrict body) |
| + |
| +notFound :: Response |
| +notFound = plain status404 "not found" |
| + |
| +allow :: ByteString -> Response |
| +allow methods = mapResponseHeaders (("Allow", methods) :) (plain status405 "method not allowed") |
| + |
| +withHeaders :: ResponseHeaders -> Response -> Response |
| +withHeaders extra = mapResponseHeaders (<> extra) |
| + |
| +common :: Header |
| +common = (hServer, serverName) |
| + |
| +bytes :: BL.ByteString -> ByteString |
| +bytes = T.encodeUtf8 . T.pack . show . BL.length |
| + |
| +csp :: ByteString |
| +csp = |
| + "default-src 'self'; script-src 'self'; style-src 'self'; img-src 'self' data:; \ |
| + \form-action 'self'; frame-ancestors 'none'; base-uri 'none'" |
diff --git a/apps/haskell/src/Todo/Assets.hs b/apps/haskell/src/Todo/Assets.hs| new file mode 100644 |
| index 0000000..469ef93 |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/Assets.hs |
| @@ -0,0 +1,20 @@ |
| +{-# LANGUAGE TemplateHaskell #-} |
| + |
| +-- | Files compiled into the binary. The two TodoMVC stylesheets come |
| +-- straight from the bakeoff's @shared/@ directory, so they're served byte |
| +-- for byte. |
| +module Todo.Assets |
| + ( baseCss |
| + , indexCss |
| + , appCss |
| + , appJs |
| + ) where |
| + |
| +import Data.ByteString (ByteString) |
| +import Data.FileEmbed (embedFile, makeRelativeToProject) |
| + |
| +baseCss, indexCss, appCss, appJs :: ByteString |
| +baseCss = $(makeRelativeToProject "../../shared/base.css" >>= embedFile) |
| +indexCss = $(makeRelativeToProject "../../shared/index.css" >>= embedFile) |
| +appCss = $(makeRelativeToProject "static/app.css" >>= embedFile) |
| +appJs = $(makeRelativeToProject "static/app.js" >>= embedFile) |
diff --git a/apps/haskell/src/Todo/Cookie.hs b/apps/haskell/src/Todo/Cookie.hs| new file mode 100644 |
| index 0000000..daff65d |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/Cookie.hs |
| @@ -0,0 +1,73 @@ |
| +{-# LANGUAGE CApiFFI #-} |
| + |
| +-- | The anonymous cookie that names a visitor's list. |
| +module Todo.Cookie |
| + ( cookieName |
| + , newToken |
| + , readToken |
| + , setCookie |
| + ) where |
| + |
| +import Control.Monad (when) |
| +import Data.ByteString (ByteString) |
| +import Data.ByteString qualified as BS |
| +import Data.ByteString.Builder qualified as B |
| +import Data.ByteString.Internal qualified as BSI |
| +import Data.ByteString.Lazy qualified as BL |
| +import Data.Char (isHexDigit, isLower, isDigit) |
| +import Data.Text (Text) |
| +import Data.Text.Encoding qualified as T |
| +import Data.Word (Word8) |
| +import Foreign.C.Types (CSize (..), CUInt (..)) |
| +import Foreign.Ptr (Ptr, plusPtr) |
| +import System.Posix.Types (CSsize (..)) |
| +import Web.Cookie |
| + |
| +cookieName :: ByteString |
| +cookieName = "todo_list" |
| + |
| +-- | Bytes of randomness in a token: 256 bits, written as 64 hex digits. |
| +tokenBytes :: Int |
| +tokenBytes = 32 |
| + |
| +foreign import capi unsafe "sys/random.h getrandom" |
| + c_getrandom :: Ptr Word8 -> CSize -> CUInt -> IO CSsize |
| + |
| +-- | A fresh token from the kernel's CSPRNG (getrandom(2), so no file |
| +-- under @/dev@ has to be visible to a sandboxed instance). |
| +newToken :: IO Text |
| +newToken = do |
| + bytes <- BSI.create tokenBytes (fill tokenBytes) |
| + pure . T.decodeLatin1 . BL.toStrict . B.toLazyByteString $ B.byteStringHex bytes |
| + where |
| + fill 0 _ = pure () |
| + fill n p = do |
| + got <- c_getrandom p (fromIntegral n) 0 |
| + -- A negative answer is EINTR or similar: just ask again. |
| + when (got < 0) $ fill n p |
| + when (got > 0) $ fill (n - fromIntegral got) (p `plusPtr` fromIntegral got) |
| + |
| +-- | The token in a request's @Cookie@ header, if it has the shape of one |
| +-- this app mints. Anything else, garbled or not, is treated as absent. |
| +readToken :: Maybe ByteString -> Maybe Text |
| +readToken header = do |
| + value <- lookup cookieName . parseCookies =<< header |
| + let ok c = isHexDigit c && (isDigit c || isLower c) |
| + if BS.length value == 2 * tokenBytes && BS.all (ok . BSI.w2c) value |
| + then Just (T.decodeLatin1 value) |
| + else Nothing |
| + |
| +-- | The @Set-Cookie@ value for a token. @secure@ is set when the app is |
| +-- served over https. |
| +setCookie :: Bool -> Text -> ByteString |
| +setCookie secure token = |
| + BL.toStrict . B.toLazyByteString . renderSetCookie $ |
| + defaultSetCookie |
| + { setCookieName = cookieName |
| + , setCookieValue = T.encodeUtf8 token |
| + , setCookiePath = Just "/" |
| + , setCookieMaxAge = Just (400 * 24 * 60 * 60) |
| + , setCookieHttpOnly = True |
| + , setCookieSecure = secure |
| + , setCookieSameSite = Just sameSiteLax |
| + } |
diff --git a/apps/haskell/src/Todo/Db.hs b/apps/haskell/src/Todo/Db.hs| new file mode 100644 |
| index 0000000..2c2ac2a |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/Db.hs |
| @@ -0,0 +1,135 @@ |
| +-- | SQLite storage: one file, WAL mode, one connection shared behind a |
| +-- lock. SQLite runs one writer at a time anyway, and a TodoMVC request |
| +-- is a handful of indexed statements, so a pool would buy nothing. |
| +module Todo.Db |
| + ( Db |
| + , open |
| + , close |
| + , findList |
| + , createList |
| + , listTodos |
| + , addTodo |
| + , toggleTodo |
| + , renameTodo |
| + , deleteTodo |
| + , toggleAll |
| + , clearCompleted |
| + ) where |
| + |
| +import Control.Concurrent.MVar |
| +import Control.Monad (forM_) |
| +import Data.Text (Text) |
| +import Data.Text qualified as T |
| +import Database.SQLite.Simple (Connection, Only (..), Query (..), execute, execute_, query, query_, withTransaction) |
| +import Database.SQLite.Simple qualified as SQL |
| +import Todo.Model |
| + |
| +newtype Db = Db (MVar Connection) |
| + |
| +-- | Opens (creating if needed) the database and brings its schema up to |
| +-- date. |
| +open :: FilePath -> IO Db |
| +open path = do |
| + conn <- SQL.open path |
| + -- journal_mode answers with a row, so it goes through query_. |
| + _ <- query_ conn "PRAGMA journal_mode = WAL" :: IO [Only Text] |
| + execute_ conn "PRAGMA synchronous = NORMAL" |
| + execute_ conn "PRAGMA foreign_keys = ON" |
| + execute_ conn "PRAGMA busy_timeout = 5000" |
| + migrate conn |
| + Db <$> newMVar conn |
| + |
| +-- | Folds the WAL back into the main file and closes the connection. |
| +close :: Db -> IO () |
| +close (Db var) = withMVar var $ \conn -> do |
| + _ <- query_ conn "PRAGMA wal_checkpoint(TRUNCATE)" :: IO [(Int, Int, Int)] |
| + SQL.close conn |
| + |
| +-- | The schema's history. Each entry runs once, in order, and the number |
| +-- applied is kept in @user_version@. Entries are only ever appended, and |
| +-- they only ever add: no drops, no rewrites. |
| +migrations :: [[Query]] |
| +migrations = |
| + [ [ "CREATE TABLE lists (\ |
| + \ id INTEGER PRIMARY KEY,\ |
| + \ token TEXT NOT NULL UNIQUE,\ |
| + \ created_at TEXT NOT NULL DEFAULT (strftime('%Y-%m-%dT%H:%M:%fZ', 'now')))" |
| + , "CREATE TABLE todos (\ |
| + \ id INTEGER PRIMARY KEY,\ |
| + \ list_id INTEGER NOT NULL REFERENCES lists (id),\ |
| + \ title TEXT NOT NULL,\ |
| + \ completed INTEGER NOT NULL DEFAULT 0,\ |
| + \ created_at TEXT NOT NULL DEFAULT (strftime('%Y-%m-%dT%H:%M:%fZ', 'now')))" |
| + , "CREATE INDEX todos_by_list ON todos (list_id, id)" |
| + ] |
| + ] |
| + |
| +migrate :: Connection -> IO () |
| +migrate conn = do |
| + applied <- query_ conn "PRAGMA user_version" |
| + let done = case applied of |
| + [Only n] -> n |
| + _ -> 0 |
| + forM_ (drop done (zip [1 :: Int ..] migrations)) $ \(n, statements) -> |
| + withTransaction conn $ do |
| + mapM_ (execute_ conn) statements |
| + -- PRAGMA takes no parameters, so the number is written in. |
| + execute_ conn (Query ("PRAGMA user_version = " <> T.pack (show n))) |
| + |
| +with :: Db -> (Connection -> IO a) -> IO a |
| +with (Db var) = withMVar var |
| + |
| +findList :: Db -> Text -> IO (Maybe ListId) |
| +findList db token = with db $ \conn -> do |
| + rows <- query conn "SELECT id FROM lists WHERE token = ?" (Only token) |
| + pure $ case rows of |
| + [Only n] -> Just (ListId n) |
| + _ -> Nothing |
| + |
| +createList :: Db -> Text -> IO ListId |
| +createList db token = with db $ \conn -> do |
| + execute conn "INSERT INTO lists (token) VALUES (?)" (Only token) |
| + ListId <$> SQL.lastInsertRowId conn |
| + |
| +listTodos :: Db -> ListId -> IO [Todo] |
| +listTodos db (ListId list) = with db $ \conn -> do |
| + rows <- query conn "SELECT id, title, completed FROM todos WHERE list_id = ? ORDER BY id" (Only list) |
| + pure [Todo (TodoId i) t c | (i, t, c) <- rows] |
| + |
| +addTodo :: Db -> ListId -> Text -> IO () |
| +addTodo db (ListId list) title = with db $ \conn -> |
| + execute conn "INSERT INTO todos (list_id, title) VALUES (?, ?)" (list, title) |
| + |
| +-- The functions that change one todo answer whether it was in that list. |
| + |
| +toggleTodo :: Db -> ListId -> TodoId -> IO Bool |
| +toggleTodo db (ListId list) (TodoId todo) = with db $ \conn -> do |
| + execute conn "UPDATE todos SET completed = NOT completed WHERE id = ? AND list_id = ?" (todo, list) |
| + changed conn |
| + |
| +renameTodo :: Db -> ListId -> TodoId -> Text -> IO Bool |
| +renameTodo db (ListId list) (TodoId todo) title = with db $ \conn -> do |
| + execute conn "UPDATE todos SET title = ? WHERE id = ? AND list_id = ?" (title, todo, list) |
| + changed conn |
| + |
| +deleteTodo :: Db -> ListId -> TodoId -> IO Bool |
| +deleteTodo db (ListId list) (TodoId todo) = with db $ \conn -> do |
| + execute conn "DELETE FROM todos WHERE id = ? AND list_id = ?" (todo, list) |
| + changed conn |
| + |
| +changed :: Connection -> IO Bool |
| +changed conn = (> 0) <$> SQL.changes conn |
| + |
| +-- | Completes everything, unless everything already is, in which case it |
| +-- makes everything active again. |
| +toggleAll :: Db -> ListId -> IO () |
| +toggleAll db (ListId list) = with db $ \conn -> withTransaction conn $ do |
| + rows <- query conn "SELECT EXISTS (SELECT 1 FROM todos WHERE list_id = ? AND NOT completed)" (Only list) |
| + let anyActive = case rows of |
| + [Only b] -> b |
| + _ -> False |
| + execute conn "UPDATE todos SET completed = ? WHERE list_id = ?" (anyActive, list) |
| + |
| +clearCompleted :: Db -> ListId -> IO () |
| +clearCompleted db (ListId list) = with db $ \conn -> |
| + execute conn "DELETE FROM todos WHERE list_id = ? AND completed" (Only list) |
diff --git a/apps/haskell/src/Todo/Form.hs b/apps/haskell/src/Todo/Form.hs| new file mode 100644 |
| index 0000000..4b89e7c |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/Form.hs |
| @@ -0,0 +1,32 @@ |
| +-- | Reading @application/x-www-form-urlencoded@ request bodies. |
| +module Todo.Form |
| + ( Fields |
| + , readFields |
| + , field |
| + ) where |
| + |
| +import Data.ByteString qualified as BS |
| +import Data.Text (Text) |
| +import Data.Text.Encoding qualified as T |
| +import Network.HTTP.Types.URI (parseSimpleQuery) |
| +import Network.Wai (Request, getRequestBodyChunk) |
| + |
| +type Fields = [(Text, Text)] |
| + |
| +-- | The body's fields, or 'Nothing' if it's bigger than @limit@ bytes. |
| +-- Bytes that aren't UTF-8 become U+FFFD rather than an error. |
| +readFields :: Int -> Request -> IO (Maybe Fields) |
| +readFields limit req = go 0 [] |
| + where |
| + go size chunks = do |
| + chunk <- getRequestBodyChunk req |
| + let size' = size + BS.length chunk |
| + if |
| + | BS.null chunk -> pure (Just (decode (BS.concat (reverse chunks)))) |
| + | size' > limit -> pure Nothing |
| + | otherwise -> go size' (chunk : chunks) |
| + decode body = [(text k, text v) | (k, v) <- parseSimpleQuery body] |
| + text = T.decodeUtf8Lenient |
| + |
| +field :: Text -> Fields -> Maybe Text |
| +field = lookup |
diff --git a/apps/haskell/src/Todo/Html.hs b/apps/haskell/src/Todo/Html.hs| new file mode 100644 |
| index 0000000..ce543cd |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/Html.hs |
| @@ -0,0 +1,123 @@ |
| +-- | The TodoMVC page, rendered on the server. It follows TodoMVC's own |
| +-- template, plus the plain forms that make every action work without |
| +-- JavaScript. @static/app.css@ lays those forms out and @static/app.js@ |
| +-- takes over from them when it runs. |
| +module Todo.Html |
| + ( View (..) |
| + , page |
| + , fragment |
| + ) where |
| + |
| +import Control.Monad (forM_, unless) |
| +import Data.Text (Text) |
| +import Data.Text qualified as T |
| +import Lucid |
| +import Lucid.Base (makeAttributes) |
| +import Todo.Model |
| + |
| +-- | Everything one render needs. |
| +data View = View |
| + { viewFilter :: Filter |
| + , viewTodos :: [Todo] |
| + -- ^ The whole list, whatever the filter. |
| + , viewEditing :: Maybe TodoId |
| + , viewAssetVersion :: Text |
| + -- ^ Appended to this app's own asset URLs, so a new build is fetched. |
| + } |
| + |
| +page :: View -> Html () |
| +page v = doctype_ >> html_ [lang_ "en"] (do |
| + head_ $ do |
| + meta_ [charset_ "utf-8"] |
| + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1"] |
| + title_ "TodoMVC" |
| + link_ [rel_ "stylesheet", href_ "/static/base.css"] |
| + link_ [rel_ "stylesheet", href_ "/static/index.css"] |
| + link_ [rel_ "stylesheet", href_ ("/static/app.css?v=" <> viewAssetVersion v)] |
| + script_ [type_ "module", src_ ("/static/app.js?v=" <> viewAssetVersion v)] ("" :: Text) |
| + body_ $ do |
| + section_ [class_ "todoapp"] $ do |
| + header_ [class_ "header"] $ do |
| + h1_ "todos" |
| + postForm v "/todos" $ |
| + input_ $ |
| + [class_ "new-todo", name_ "title", placeholder_ "What needs to be done?", autocomplete_ "off"] |
| + <> [autofocus_ | null (viewEditing v)] |
| + fragment v |
| + footer_ [class_ "info"] $ do |
| + p_ "Double-click to edit a todo" |
| + p_ $ do |
| + "Created by " |
| + a_ [href_ "https://bakeoff.bfj.oncarlos.com"] "the CARLOS bakeoff" |
| + " · Haskell" |
| + p_ $ do |
| + "Part of " |
| + a_ [href_ "http://todomvc.com"] "TodoMVC") |
| + |
| +-- | @section.main@ and @footer.footer@: the part of the page every |
| +-- action changes. With JavaScript on, actions answer with just this. |
| +fragment :: View -> Html () |
| +fragment v = do |
| + section_ ([class_ "main"] <> hiddenIf (null todos)) $ do |
| + input_ ([id_ "toggle-all", class_ "toggle-all", type_ "checkbox"] <> [checked_ | allDone]) |
| + label_ [for_ "toggle-all"] "Mark all as complete" |
| + postForm v "/todos/toggle-all" $ |
| + button_ [class_ "toggle-all-submit", data_ "action" "toggle-all"] "Mark all as complete" |
| + ul_ [class_ "todo-list"] $ |
| + forM_ (filter (visible (viewFilter v)) todos) (item v) |
| + footer_ ([class_ "footer"] <> hiddenIf (null todos)) $ do |
| + span_ [class_ "todo-count"] $ do |
| + strong_ (toHtml (show left)) |
| + if left == 1 then " item left" else " items left" |
| + ul_ [class_ "filters"] $ |
| + forM_ [minBound .. maxBound] $ \f -> do |
| + unless (f == minBound) " " |
| + li_ $ a_ ([href_ (filterPath f)] <> [class_ "selected" | f == viewFilter v]) (filterLabel f) |
| + postForm v "/todos/clear-completed" $ |
| + button_ ([class_ "clear-completed"] <> hiddenIf (left == length todos)) "Clear completed" |
| + where |
| + todos = viewTodos v |
| + left = length (filter (not . todoCompleted) todos) |
| + allDone = not (null todos) && left == 0 |
| + |
| +item :: View -> Todo -> Html () |
| +item v t = |
| + li_ ([data_ "id" tid] <> [class_ (T.unwords classes) | not (null classes)]) $ do |
| + div_ [class_ "view"] $ do |
| + input_ ([class_ "toggle", type_ "checkbox"] <> [checked_ | todoCompleted t]) |
| + label_ $ a_ [data_ "action" "edit", href_ editHref] (toHtml (todoTitle t)) |
| + postForm v (base <> "/toggle") $ |
| + button_ |
| + [ class_ "toggle-submit" |
| + , data_ "action" "toggle" |
| + , makeAttributes "aria-label" (if todoCompleted t then "Mark as active" else "Mark as complete") |
| + ] |
| + "" |
| + postForm v (base <> "/destroy") $ |
| + button_ [class_ "destroy", makeAttributes "aria-label" "Delete"] "" |
| + postForm v (base <> "/edit") $ |
| + input_ ([class_ "edit", name_ "title", value_ (todoTitle t)] <> [autofocus_ | editing]) |
| + where |
| + tid = todoIdText (todoId t) |
| + base = "/todos/" <> tid |
| + editing = viewEditing v == Just (todoId t) |
| + classes = ["completed" | todoCompleted t] <> ["editing" | editing] |
| + editHref = filterPath (viewFilter v) <> "?edit=" <> tid |
| + |
| +-- | A form that posts to one action, carrying the current filter so the |
| +-- redirect comes back to it. Laid out with @display: contents@, so it |
| +-- doesn't disturb TodoMVC's CSS. |
| +postForm :: View -> Text -> Html () -> Html () |
| +postForm v action body = |
| + form_ [method_ "post", action_ action, class_ "action"] $ do |
| + input_ [type_ "hidden", name_ "filter", value_ (filterName (viewFilter v))] |
| + body |
| + |
| +hiddenIf :: Bool -> [Attributes] |
| +hiddenIf b = [hidden_ "" | b] |
| + |
| +filterLabel :: Filter -> Html () |
| +filterLabel = \case |
| + All -> "All" |
| + Active -> "Active" |
| + Completed -> "Completed" |
diff --git a/apps/haskell/src/Todo/Model.hs b/apps/haskell/src/Todo/Model.hs| new file mode 100644 |
| index 0000000..afb3cd0 |
| --- /dev/null |
| +++ b/apps/haskell/src/Todo/Model.hs |
| @@ -0,0 +1,72 @@ |
| +-- | The shapes the rest of the app talks in. |
| +module Todo.Model |
| + ( ListId (..) |
| + , TodoId (..) |
| + , Todo (..) |
| + , Filter (..) |
| + , parseFilter |
| + , filterName |
| + , filterPath |
| + , visible |
| + , parseTodoId |
| + , todoIdText |
| + ) where |
| + |
| +import Data.Int (Int64) |
| +import Data.Text (Text) |
| +import Data.Text qualified as T |
| +import Data.Text.Read qualified as T |
| + |
| +-- | One visitor's list. Every query about todos is scoped by one. |
| +newtype ListId = ListId Int64 |
| + deriving (Eq, Show) |
| + |
| +newtype TodoId = TodoId Int64 |
| + deriving (Eq, Show) |
| + |
| +data Todo = Todo |
| + { todoId :: !TodoId |
| + , todoTitle :: !Text |
| + , todoCompleted :: !Bool |
| + } |
| + deriving (Eq, Show) |
| + |
| +data Filter = All | Active | Completed |
| + deriving (Eq, Show, Enum, Bounded) |
| + |
| +-- | The @filter@ form field. Anything missing or unknown means 'All'. |
| +parseFilter :: Maybe Text -> Filter |
| +parseFilter = \case |
| + Just "active" -> Active |
| + Just "completed" -> Completed |
| + _ -> All |
| + |
| +filterName :: Filter -> Text |
| +filterName = \case |
| + All -> "all" |
| + Active -> "active" |
| + Completed -> "completed" |
| + |
| +filterPath :: Filter -> Text |
| +filterPath = \case |
| + All -> "/" |
| + Active -> "/active" |
| + Completed -> "/completed" |
| + |
| +visible :: Filter -> Todo -> Bool |
| +visible = \case |
| + All -> const True |
| + Active -> not . todoCompleted |
| + Completed -> todoCompleted |
| + |
| +-- | A todo id as it appears in a path or a query: plain decimal digits, |
| +-- short enough to fit an 'Int64'. |
| +parseTodoId :: Text -> Maybe TodoId |
| +parseTodoId t |
| + | T.null t || T.length t > 18 || not (T.all (\c -> c >= '0' && c <= '9') t) = Nothing |
| + | otherwise = case T.decimal t of |
| + Right (n, rest) | T.null rest -> Just (TodoId n) |
| + _ -> Nothing |
| + |
| +todoIdText :: TodoId -> Text |
| +todoIdText (TodoId n) = T.pack (show n) |
diff --git a/apps/haskell/static/app.css b/apps/haskell/static/app.css| new file mode 100644 |
| index 0000000..0b6c6a8 |
| --- /dev/null |
| +++ b/apps/haskell/static/app.css |
| @@ -0,0 +1,45 @@ |
| +/* |
| + * The controls that make every action work without JavaScript. Each sits |
| + * exactly over the TodoMVC control it stands in for, and is invisible, so |
| + * the page looks the same either way. app.js puts the "js" class on |
| + * <html> and they go. |
| + */ |
| + |
| +form.action { |
| + display: contents; |
| +} |
| + |
| +.todo-list li label a { |
| + color: inherit; |
| + text-decoration: none; |
| +} |
| + |
| +.todo-list li .toggle-submit { |
| + position: absolute; |
| + top: 0; |
| + bottom: 0; |
| + left: 0; |
| + width: 40px; |
| + cursor: pointer; |
| +} |
| + |
| +.toggle-all-submit { |
| + position: absolute; |
| + top: -65px; |
| + left: 0; |
| + width: 45px; |
| + height: 65px; |
| + font-size: 0; |
| + cursor: pointer; |
| +} |
| + |
| +.js .todo-list li .toggle-submit, |
| +.js .toggle-all-submit { |
| + display: none; |
| +} |
| + |
| +/* With JavaScript a double-click on the label edits, so the link that |
| + does the same without it stops taking clicks. */ |
| +.js .todo-list li label a { |
| + pointer-events: none; |
| +} |
diff --git a/apps/haskell/static/app.js b/apps/haskell/static/app.js| new file mode 100644 |
| index 0000000..f4519ff |
| --- /dev/null |
| +++ b/apps/haskell/static/app.js |
| @@ -0,0 +1,88 @@ |
| +// Layered over the server-rendered page, which already works as plain |
| +// forms. With this running it behaves like TodoMVC's own apps: actions |
| +// happen without a page load, and a double-click edits. |
| +// |
| +// Every action posts the same form it would without JavaScript, with an |
| +// X-Fragment header. The server answers with fresh section.main and |
| +// footer.footer, which replace the old ones. Requests go one at a time, |
| +// in order. |
| + |
| +document.documentElement.classList.add('js'); |
| + |
| +const app = document.querySelector('.todoapp'); |
| +let queue = Promise.resolve(); |
| + |
| +function send(action, body) { |
| + queue = queue |
| + .then(async () => { |
| + const res = await fetch(action, { method: 'POST', headers: { 'X-Fragment': '1' }, body }); |
| + if (!res.ok) throw new Error(`${action}: ${res.status}`); |
| + const next = document.createElement('template'); |
| + next.innerHTML = await res.text(); |
| + for (const part of ['.main', '.footer']) { |
| + app.querySelector(part).replaceWith(next.content.querySelector(part)); |
| + } |
| + }) |
| + // The page is the source of truth: if anything went wrong, show it. |
| + .catch(() => location.reload()); |
| + return queue; |
| +} |
| + |
| +const fields = (form) => new URLSearchParams(new FormData(form)); |
| +const filter = () => app.querySelector('input[name="filter"]').value; |
| + |
| +app.addEventListener('submit', (e) => { |
| + const form = e.target; |
| + e.preventDefault(); |
| + if (form.querySelector('.edit')) { |
| + finishEditing(form.closest('li'), true); |
| + return; |
| + } |
| + const body = fields(form); |
| + send(form.action, body); |
| + const input = form.querySelector('.new-todo'); |
| + if (input) input.value = ''; |
| +}); |
| + |
| +app.addEventListener('change', (e) => { |
| + const box = e.target; |
| + if (box.matches('.toggle')) { |
| + send(`/todos/${box.closest('li').dataset.id}/toggle`, new URLSearchParams({ filter: filter() })); |
| + } else if (box.matches('.toggle-all')) { |
| + send('/todos/toggle-all', new URLSearchParams({ filter: filter() })); |
| + } |
| +}); |
| + |
| +app.addEventListener('dblclick', (e) => { |
| + const label = e.target.closest('.todo-list label'); |
| + if (!label) return; |
| + const li = label.closest('li'); |
| + const input = li.querySelector('.edit'); |
| + li.classList.add('editing'); |
| + input.focus(); |
| + input.setSelectionRange(input.value.length, input.value.length); |
| +}); |
| + |
| +app.addEventListener('keydown', (e) => { |
| + if (e.key === 'Escape' && e.target.matches('.edit')) finishEditing(e.target.closest('li'), false); |
| +}); |
| + |
| +app.addEventListener('focusout', (e) => { |
| + if (e.target.matches('.edit')) finishEditing(e.target.closest('li'), true); |
| +}); |
| + |
| +// Ends an edit once: Enter submits and then blurs, and Escape blurs too. |
| +function finishEditing(li, save) { |
| + if (!li.classList.contains('editing')) return; |
| + const input = li.querySelector('.edit'); |
| + li.classList.remove('editing'); |
| + if (save) { |
| + // Show the new title straight away; the server's answer follows. |
| + const title = input.value.trim(); |
| + if (title) li.querySelector('label a').textContent = title; |
| + else li.hidden = true; |
| + send(input.form.action, fields(input.form)); |
| + } else { |
| + input.value = input.defaultValue; |
| + } |
| +} |
diff --git a/apps/haskell/test/Spec.hs b/apps/haskell/test/Spec.hs| new file mode 100644 |
| index 0000000..a2437e5 |
| --- /dev/null |
| +++ b/apps/haskell/test/Spec.hs |
| @@ -0,0 +1,178 @@ |
| +-- | Drives the WAI application in-process, against a fresh in-memory |
| +-- database for each test. |
| +module Main (main) where |
| + |
| +import Control.Exception (bracket) |
| +import Control.Monad.IO.Class (liftIO) |
| +import Data.ByteString (ByteString) |
| +import Data.ByteString qualified as BS |
| +import Data.ByteString.Lazy qualified as BL |
| +import Data.Text qualified as T |
| +import Data.Text.Encoding qualified as T |
| +import Network.HTTP.Types |
| +import Network.Wai (Application, requestHeaders, requestMethod) |
| +import Network.Wai.Test |
| +import Test.Hspec |
| + |
| +import Todo.App |
| +import Todo.Db qualified as Db |
| + |
| +origin :: ByteString |
| +origin = "http://127.0.0.1:8080" |
| + |
| +withApp :: (Application -> IO a) -> IO a |
| +withApp run = bracket (Db.open ":memory:") Db.close $ \db -> |
| + run (app (Config (Just origin) False) db) |
| + |
| +get :: ByteString -> Session SResponse |
| +get path = request (setPath defaultRequest path) |
| + |
| +post :: ByteString -> [(ByteString, ByteString)] -> [Header] -> Session SResponse |
| +post path form headers = |
| + srequest $ |
| + SRequest |
| + (setPath defaultRequest {requestMethod = methodPost, requestHeaders = (hContentType, "application/x-www-form-urlencoded") : headers} path) |
| + (BL.fromStrict (BS.drop 1 (renderSimpleQuery True form))) |
| + |
| +body :: SResponse -> T.Text |
| +body = T.decodeUtf8 . BL.toStrict . simpleBody |
| + |
| +-- | Labels on the page, in order. |
| +labels :: SResponse -> [T.Text] |
| +labels r = |
| + [ T.takeWhile (/= '<') (T.drop 1 (T.dropWhile (/= '>') chunk)) |
| + | chunk <- drop 1 (T.splitOn "data-action=\"edit\"" (body r)) |
| + ] |
| + |
| +main :: IO () |
| +main = hspec $ around withApp $ do |
| + describe "pages" $ do |
| + it "serves an empty list and hands out a cookie" $ runSession $ do |
| + r <- get "/" |
| + assertStatus 200 r |
| + let cookie = lookup hSetCookie (simpleHeaders r) |
| + liftIO $ do |
| + cookie `shouldSatisfy` maybe False ("todo_list=" `BS.isPrefixOf`) |
| + cookie `shouldSatisfy` maybe False ("HttpOnly" `BS.isInfixOf`) |
| + cookie `shouldSatisfy` maybe False ("SameSite=Lax" `BS.isInfixOf`) |
| + cookie `shouldSatisfy` maybe False ("Path=/" `BS.isInfixOf`) |
| + assertBodyContains "<section class=\"main\" hidden=\"\">" r |
| + assertBodyContains "· Haskell" r |
| + |
| + it "keeps the cookie it handed out" $ runSession $ do |
| + _ <- get "/" |
| + r <- get "/" |
| + assertNoHeader hSetCookie r |
| + |
| + it "answers health and version checks" $ runSession $ do |
| + get "/healthz" >>= assertStatus 200 |
| + r <- get "/api/version" |
| + assertStatus 200 r |
| + assertBody (BL.fromStrict (T.encodeUtf8 version)) r |
| + |
| + it "serves the shared stylesheets byte for byte" $ runSession $ do |
| + r <- get "/static/index.css" |
| + want <- liftIO (BS.readFile "../../shared/index.css") |
| + assertBody (BL.fromStrict want) r |
| + |
| + it "says 404 for anything else" $ runSession $ |
| + get "/nope" >>= assertStatus 404 |
| + |
| + describe "actions" $ do |
| + it "adds a trimmed todo and redirects to the filter" $ runSession $ do |
| + r <- post "/todos" [("title", " buy milk "), ("filter", "active")] [] |
| + assertStatus 303 r |
| + assertHeader hLocation "/active" r |
| + page <- get "/" |
| + liftIO $ labels page `shouldBe` ["buy milk"] |
| + |
| + it "ignores a blank title" $ runSession $ do |
| + _ <- post "/todos" [("title", " ")] [] |
| + page <- get "/" |
| + liftIO $ labels page `shouldBe` [] |
| + |
| + it "sends an unknown filter back to /" $ runSession $ do |
| + r <- post "/todos" [("title", "x"), ("filter", "bogus")] [] |
| + assertHeader hLocation "/" r |
| + |
| + it "toggles, renames and deletes" $ runSession $ do |
| + mapM_ (\t -> post "/todos" [("title", t)] []) ["a", "b", "c"] |
| + post "/todos/1/toggle" [("filter", "all")] [] >>= assertStatus 303 |
| + active <- get "/active" |
| + liftIO $ labels active `shouldBe` ["b", "c"] |
| + completed <- get "/completed" |
| + liftIO $ labels completed `shouldBe` ["a"] |
| + _ <- post "/todos/2/edit" [("title", " bee ")] [] |
| + _ <- post "/todos/3/edit" [("title", " ")] [] |
| + page <- get "/" |
| + liftIO $ labels page `shouldBe` ["a", "bee"] |
| + _ <- post "/todos/1/destroy" [] [] |
| + page' <- get "/" |
| + liftIO $ labels page' `shouldBe` ["bee"] |
| + |
| + it "toggles all, and back when all were done" $ runSession $ do |
| + mapM_ (\t -> post "/todos" [("title", t)] []) ["a", "b"] |
| + _ <- post "/todos/1/toggle" [] [] |
| + _ <- post "/todos/toggle-all" [] [] |
| + done <- get "/completed" |
| + liftIO $ labels done `shouldBe` ["a", "b"] |
| + _ <- post "/todos/toggle-all" [] [] |
| + active <- get "/active" |
| + liftIO $ labels active `shouldBe` ["a", "b"] |
| + |
| + it "clears completed todos" $ runSession $ do |
| + mapM_ (\t -> post "/todos" [("title", t)] []) ["a", "b"] |
| + _ <- post "/todos/2/toggle" [] [] |
| + _ <- post "/todos/clear-completed" [] [] |
| + page <- get "/" |
| + liftIO $ labels page `shouldBe` ["a"] |
| + |
| + it "answers a fragment when app.js asks for one" $ runSession $ do |
| + r <- post "/todos" [("title", "x")] [(fragmentHeader, "1")] |
| + assertStatus 200 r |
| + liftIO $ body r `shouldSatisfy` T.isPrefixOf "<section class=\"main\">" |
| + |
| + it "opens the editor with ?edit=" $ runSession $ do |
| + _ <- post "/todos" [("title", "x")] [] |
| + r <- get "/?edit=1" |
| + assertBodyContains "<li data-id=\"1\" class=\"editing\">" r |
| + assertBodyContains "action=\"/todos/1/edit\"" r |
| + |
| + describe "safety" $ do |
| + it "refuses a cross-origin post and accepts its own origin" $ runSession $ do |
| + post "/todos" [("title", "evil")] [("Origin", "https://evil.example")] >>= assertStatus 403 |
| + post "/todos" [("title", "fine")] [("Origin", origin)] >>= assertStatus 303 |
| + page <- get "/" |
| + liftIO $ labels page `shouldBe` ["fine"] |
| + |
| + it "keeps lists apart" $ \application -> do |
| + runSession (post "/todos" [("title", "mine")] [] >> pure ()) application |
| + runSession |
| + ( do |
| + post "/todos/1/toggle" [] [] >>= assertStatus 404 |
| + post "/todos/1/edit" [("title", "stolen")] [] >>= assertStatus 404 |
| + post "/todos/1/destroy" [] [] >>= assertStatus 404 |
| + page <- get "/" |
| + liftIO $ labels page `shouldBe` [] |
| + ) |
| + application |
| + |
| + it "gives a garbled cookie a fresh list" $ runSession $ do |
| + r <- request (setPath defaultRequest {requestHeaders = [(hCookie, "todo_list=%%%")]} "/") |
| + assertStatus 200 r |
| + assertHeaderContains' hSetCookie "todo_list=" r |
| + |
| + it "escapes titles and keeps Unicode" $ runSession $ do |
| + _ <- post "/todos" [("title", T.encodeUtf8 "<img src=x> & \"q\" naïve 🚀")] [] |
| + r <- get "/" |
| + assertBodyContains (BL.fromStrict (T.encodeUtf8 "<img src=x> & "q" naïve 🚀")) r |
| + assertHeader hContentLength (T.encodeUtf8 (T.pack (show (BL.length (simpleBody r))))) r |
| + |
| + it "takes a 10,000 character title" $ runSession $ do |
| + let long = T.replicate 10000 "æ—¥" |
| + post "/todos" [("title", T.encodeUtf8 long)] [] >>= assertStatus 303 |
| + r <- get "/" |
| + liftIO $ labels r `shouldBe` [long] |
| + where |
| + assertHeaderContains' name needle r = |
| + liftIO $ lookup name (simpleHeaders r) `shouldSatisfy` maybe False (needle `BS.isPrefixOf`) |
diff --git a/apps/haskell/todo-haskell.cabal b/apps/haskell/todo-haskell.cabal| new file mode 100644 |
| index 0000000..4e5390e |
| --- /dev/null |
| +++ b/apps/haskell/todo-haskell.cabal |
| @@ -0,0 +1,74 @@ |
| +cabal-version: 3.0 |
| +name: todo-haskell |
| +version: 0.1.0.0 |
| +synopsis: Server-rendered TodoMVC for the CARLOS bakeoff |
| +license: NONE |
| +build-type: Simple |
| +extra-source-files: |
| + ../../shared/base.css |
| + ../../shared/index.css |
| + static/app.css |
| + static/app.js |
| + |
| +common shared |
| + default-language: GHC2021 |
| + default-extensions: |
| + OverloadedStrings |
| + LambdaCase |
| + MultiWayIf |
| + ghc-options: -Wall -Wcompat |
| + |
| +library |
| + import: shared |
| + hs-source-dirs: src gen |
| + exposed-modules: |
| + Todo.App |
| + Todo.Assets |
| + Todo.Cookie |
| + Todo.Db |
| + Todo.Form |
| + Todo.Html |
| + Todo.Model |
| + other-modules: |
| + BuildVersion |
| + build-depends: |
| + , base >=4.18 && <5 |
| + , bytestring >=0.11 && <0.13 |
| + , cookie >=0.4.6 && <0.6 |
| + , file-embed >=0.0.15 && <0.1 |
| + , http-types >=0.12 && <0.13 |
| + , lucid2 >=0.0.20230706 && <0.1 |
| + , sqlite-simple >=0.4.18 && <0.5 |
| + , text >=2.0 && <2.2 |
| + , wai >=3.2.3 && <3.3 |
| + |
| +executable todo-haskell |
| + import: shared |
| + hs-source-dirs: app |
| + main-is: Main.hs |
| + build-depends: |
| + , base |
| + , bytestring |
| + , network >=3.1 && <3.3 |
| + , text |
| + , todo-haskell |
| + , unix >=2.8 && <2.9 |
| + , wai |
| + , warp >=3.3.25 && <3.5 |
| + ghc-options: -threaded -rtsopts "-with-rtsopts=-N2" |
| + |
| +test-suite spec |
| + import: shared |
| + type: exitcode-stdio-1.0 |
| + hs-source-dirs: test |
| + main-is: Spec.hs |
| + build-depends: |
| + , base |
| + , bytestring |
| + , http-types |
| + , text |
| + , todo-haskell |
| + , wai |
| + , wai-extra >=3.1 && <3.2 |
| + , hspec >=2.10 && <2.12 |
| + ghc-options: -threaded |