.gitignore

@@ -1,26 +1,28 @@
 *.swp
 *.swo
-favicon.ico
+# A site operator dropping their own favicon at the repo root -- 6a34784.
+# Anchored, or it also swallows the default we ship in www/img/icon.
+/favicon.ico
 dist/
 www/assets
 data/
 blib/
-nytprof/
-nytprof.out
-nytprof*
-www/nytprof
 pm_to_blib
 pod2htmd.tmp
 www/scripts/list.min.json
 www/scripts/highlight.min.js
-www/scripts/chart.js
-www/scripts/reveal.js
+www/scripts/chart.min.js
+www/scripts/reveal.min.js
 www/styles/obsidian.min.css
 www/styles/reveal.css
 www/styles/reveal-white.css
 www/.well_known
 config/auth.db
 config/has_users
+# The vault key, when bin/tcms-vault-key --file put one here rather than the
+# service handing one over.  Committing it would put the key in the same place
+# as everything it protects, which is the one thing it exists not to be.
+config/secrets.key
 config/main.cfg
 config/setup
 Makefile
@@ -29,14 +31,11 @@ MYMETA.json
 node_modules/
 www/statics/
 totp/
-nginx/tcms.conf
 fail2ban/tcms-jail.conf
 logs/
 run/
-dns/tcms.conf
-dns/zones.db
-dns/zone.sql
-dns/default.zone
-dns/default.zone.sql
 *-shm
 *-wal
+.xslate_cache/
+*.swn
+cover_db/

.perlcriticrc

@@ -0,0 +1,297 @@
+# Troglodyne perlcritic policy, for a distribution that declares use 5.040 or
+# later.
+#
+# There are two of these.  This one is for code that runs on a perl you control,
+# and perlcriticrc.compat is for code that runs on whatever perl is already
+# installed.  The packaging-perl skill asks which you are writing before it
+# copies one, because the answer decides more than this file: it decides the
+# use line in every module and test, and perl: in prereqs.yml.
+#
+# The difference between the two is five policies.  A modern perl refuses what
+# they report, so naming them here would buy nothing:
+#
+#   TestingAndDebugging::RequireUseStrict       strict is on from 5.012
+#   Objects::ProhibitIndirectSyntax             no indirect from 5.036
+#   InputOutput::ProhibitBarewordFileHandles    no bareword_filehandles from
+#   InputOutput::ProhibitBarewordDirHandles       5.038
+#   Modules::RequireEndWithOne                  module_true from 5.038
+#
+# Two more go the same way at 5.042, and are named below because this file
+# assumes only 5.040.  Delete them once your floor is 5.041 or later, which
+# selects the 5.042 bundle:
+#
+#   Variables::ProhibitPerl4PackageNames        no apostrophe as a package
+#                                                 separator from 5.042
+#   CodeLayout::RequireASCII                    source::encoding "ascii" from
+#                                                 5.042, which is stricter than
+#                                                 the policy and not skippable
+#
+# tCMS: a policy commented out as #[Name], with no space, is one that the tree
+# does not pass yet.  The change that fixes the tree for it enables it.
+severity  = 1
+only      = 1
+force     = 0
+verbose   = 1
+criticism-fatal = 1
+color     = 1
+allow-unsafe = 1
+# Usability
+[Modules::RequirePerlVersion]
+[Documentation::RequirePod]
+# Security
+[ValuesAndExpressions::PreventSQLInjection]
+# Drop this one at 5.041 and later.  It also applies to POD, where the only
+# thing it tends to catch is a contributor's name in the section Dist::Zilla
+# generates, and spelling somebody's name wrong is not a code standard.
+[CodeLayout::RequireASCII]
+[RegularExpressions::RequireDefault]
+strict = 1
+[RegularExpressions::PreventUselessMetacharacterEscapes]
+# PEBCAK catches
+[BuiltinFunctions::ProhibitDeleteOnArrays]
+[Subroutines::ProhibitAmbiguousFunctionCalls]
+[ValuesAndExpressions::ProhibitSingleArgArraySlice]
+[ValuesAndExpressions::ProhibitDefinedBeforeLength]
+[Variables::ProhibitUselessVarClearing]
+[Subroutines::ProhibitTailRecursion]
+[Bangs::ProhibitUselessRegexModifiers]
+[Bangs::ProhibitCommentedOutCode]
+[Tics::ProhibitUseBase]
+[Plicease::ProhibitLeadingZeros]
+[RegularExpressions::ProhibitEmptyAlternatives]
+[ValuesAndExpressions::UnexpandedSpecialLiteral]
+[CodeLayout::ProhibitIfIfSameLine]
+[ValuesAndExpressions::ConstantBeforeLt]
+[ValuesAndExpressions::ProhibitDuplicateHashKeys]
+# any access checks are necessarily a TOCTOU waiting to happen
+[ValuesAndExpressions::ProhibitFiletest_f]
+[ValuesAndExpressions::ProhibitFiletest_rwxRWX]
+# Bikeshed
+[CognitiveComplexity::ProhibitExcessCognitiveComplexity]
+warn_level = 40
+info_level = 30
+[Variables::ProhibitUselessInitialization]
+[PreferredModules]
+config = .preferred_modules.ini
+[logicLAB::RequireSheBang]
+formats = #!/usr/bin/env perl
+# Performance
+[logicLAB::ProhibitShellDispatch]
+[ProhibitPipeOpen]
+[Performance::ProhibitRegexForSimpleSubstring]
+[RegularExpressions::ProhibitRegexToStripAffix]
+[RegularExpressions::ProhibitRegexToChomp]
+[BuiltinFunctions::ProhibitChainingSameListSub]
+[RegularExpressions::ProhibitRegexForStringEquality]
+[Subroutines::ProhibitUnderscorePrivateSubs]
+[Subroutines::ProhibitSingleUseLexicalSubs]
+[ValuesAndExpressions::ProhibitLiteralArithmetic]
+[BuiltinFunctions::ProhibitIndirectBooleanGrep]
+# What ProhibitMutatingListFunctions reports, which this replaces, and a block
+# that changes $_ through a sub that it calls.
+[ControlStructures::ProhibitMutatingListFunctionsStricter]
+# An if, elsif, else or unless whose block holds no statement, a comment
+# being none.  Loops are left alone, because a loop condition can do the work.
+[ControlStructures::ProhibitEmptyConditionalBlocks]
+# A sub that returns the result of a syscall or an eval, called where nothing
+# looks at the result.  The same functions as RequireCheckedSyscalls below.
+[ErrorHandling::RequireCheckedIndirectResults]
+exclude_functions = print say
+[ProhibitUseLib]
+[ProhibitUsageSubs]
+# tCMS: help() is the interface of a data model and a datasource that links
+# the documentation of its query language, so it is not a usage message.
+sub_names = usage _usage print_usage usage_message
+[RequireQwForLiteralLists]
+[ProhibitNoWarningsRedefine]
+[RequireFatalWarnings]
+[ProhibitUnusedImports]
+# Modules imported for a side effect rather than for a symbol, which the policy
+# cannot see.  `re` is here because every file says `use re '/aa'`.  Add your
+# own: IO::Prompter installs prompt() from a custom import rather than @EXPORT,
+# and anything loaded by name from a string is invisible the same way.
+# tCMS: Exporter, because use Exporter 'import' imports the method that perl
+# calls, which no line of the module names.
+allow = re Exporter
+# Off in a distribution that is only a library: it counts calls from bin/ and
+# lib/, and every sub a library exists to offer is called from neither -- a
+# module with one public sub and no bin/ reports that sub, which is the policy
+# working correctly and saying nothing.  Turn it on for a distribution that also
+# ships programs, and add the authordep line to dist.ini when you do.
+#
+# allow_subs then lists the subs that are called in a way it cannot see: named
+# in a string and called as $obj->$name, handed to something else that calls
+# them, or called only from a directory it does not read.  Name each one and say
+# which, so the next person can tell an exemption from an oversight.
+#
+[ProhibitUnusedDefinitions]
+# tCMS:
+#   generic_route, @routes, %aliases  tPSGI reads them out of the router package
+#   posts, order                       named by a post type's x-tcms-datasource
+#   enrich                             named by a post type's sidecar
+#   create_statement, log_message      Log::Dispatch calls them
+#   series, users                      a post's callback names them
+allow_subs = TCMS::generic_route Trog::DataSource::DirIndex::posts Trog::DataSource::DirIndex::order Trog::DataSource::ProvisionedVirt::posts Trog::Enrich::Invoice::enrich Trog::Log::DBI::create_statement Trog::Log::DBI::log_message Trog::Log::Syslog::log_message Trog::Routes::HTML::series Trog::Routes::HTML::users
+allow_globals = @TCMS::routes %TCMS::aliases
+# A sub that only one subclass uses, and a sub that two subclasses define where
+# the class above them defines none.  It reads bin/ and lib/ through
+# Perl::Critic::Distribution, as ProhibitUnusedDefinitions does, so the two
+# share one parse.  A library whose subclasses live in other distributions
+# names in allow_subs each hook that only one of its own subclasses uses.
+[ProhibitMisplacedMethods]
+[ProhibitPrintSTDERR]
+[InputOutput::ProhibitRepeatedPrints]
+# Perl::Critic's own policies.  only = 1 loads nothing that is not named, so
+# each of these has to be, and the ones that are absent are absent on purpose.
+#
+# Not here, because something above already does the job better:
+#   CodeLayout::ProhibitQuotedWordLists         RequireQwForLiteralLists
+#   ControlStructures::ProhibitCascadingIfElse  CognitiveComplexity, which
+#   ControlStructures::ProhibitDeepNests          scores nesting and every
+#   Subroutines::ProhibitExcessComplexity         break in flow, where these
+#                                                 count branches
+#   ControlStructures::ProhibitMutatingListFunctions
+#                                               ProhibitMutatingListFunctionsStricter,
+#                                                 which reports all of it, and
+#                                                 a sub that the block calls
+#   InputOutput::ProhibitBacktickOperators      logicLAB::ProhibitShellDispatch
+#   Modules::ProhibitEvilModules                PreferredModules
+#   Subroutines::ProhibitUnusedPrivateSubroutines  ProhibitUnusedDefinitions,
+#                                                 which counts calls from bin/
+#                                                 and lib/, private or not
+#   TestingAndDebugging::RequireUseWarnings     RequireFatalWarnings
+#   ValuesAndExpressions::ProhibitLeadingZeros  Plicease::ProhibitLeadingZeros
+#   Modules::RequireVersionVar                  [PkgVersion] in dist.ini
+#   ErrorHandling::RequireCarping               die with context, and
+#                                                 Carp::Always for the trace
+#
+# Nor the five the language enforces under this file's floor.  The header says
+# which they are, and perlcriticrc.compat is where they live.
+#
+# Documentation::RequirePodSections is out as well: the sections it asks for are
+# the ones Pod::Weaver writes at build, and weaver.ini names them AUTHORS and
+# COPYRIGHT AND LICENSE where the policy wants AUTHOR and LICENSE AND COPYRIGHT.
+[BuiltinFunctions::ProhibitBooleanGrep]
+[BuiltinFunctions::ProhibitLvalueSubstr]
+[BuiltinFunctions::ProhibitReverseSortBlock]
+[BuiltinFunctions::ProhibitShiftRef]
+[BuiltinFunctions::ProhibitSleepViaSelect]
+[BuiltinFunctions::ProhibitStringyEval]
+[BuiltinFunctions::ProhibitStringySplit]
+[BuiltinFunctions::ProhibitUniversalCan]
+[BuiltinFunctions::ProhibitUniversalIsa]
+[BuiltinFunctions::ProhibitVoidGrep]
+[BuiltinFunctions::ProhibitVoidMap]
+[BuiltinFunctions::RequireBlockGrep]
+[BuiltinFunctions::RequireBlockMap]
+[BuiltinFunctions::RequireGlobFunction]
+[BuiltinFunctions::RequireSimpleSortBlock]
+[ClassHierarchies::ProhibitAutoloading]
+[ClassHierarchies::ProhibitExplicitISA]
+[ClassHierarchies::ProhibitOneArgBless]
+[CodeLayout::ProhibitHardTabs]
+[CodeLayout::ProhibitTrailingWhitespace]
+[CodeLayout::RequireConsistentNewlines]
+# [CodeLayout::RequireTidyCode] is off on purpose.  git-hooks/pre-commit runs
+# perltidy over every staged Perl file before it runs this profile, so every
+# commit is tidy whatever this policy would say.  In an editor, the policy only
+# repeated that, and ran perltidy over the whole file on every check.
+[CodeLayout::RequireTrailingCommas]
+[ControlStructures::ProhibitLabelsWithSpecialBlockNames]
+[ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions]
+[ControlStructures::ProhibitUnreachableCode]
+[ControlStructures::ProhibitUntilBlocks]
+[ControlStructures::ProhibitYadaOperator]
+[Documentation::PodSpelling]
+spell_command = aspell --lang=en_US list
+stop_words_file = .pod_stopwords
+[Documentation::RequirePackageMatchesPodName]
+[ErrorHandling::RequireCheckingReturnValueOfEval]
+[InputOutput::ProhibitExplicitStdin]
+[InputOutput::ProhibitInteractiveTest]
+[InputOutput::ProhibitJoinedReadline]
+[InputOutput::ProhibitOneArgSelect]
+[InputOutput::ProhibitReadlineInForLoop]
+[InputOutput::ProhibitTwoArgOpen]
+[InputOutput::RequireBracedFileHandleWithPrint]
+[InputOutput::RequireBriefOpen]
+[InputOutput::RequireCheckedOpen]
+[InputOutput::RequireCheckedSyscalls]
+# tCMS: say prints as print does.
+exclude_functions = print say
+[InputOutput::RequireEncodingWithUTF8Layer]
+[Miscellanea::ProhibitFormats]
+[Miscellanea::ProhibitTies]
+[Miscellanea::ProhibitUnrestrictedNoCritic]
+[Miscellanea::ProhibitUselessNoCritic]
+[Modules::ProhibitAutomaticExportation]
+[Modules::ProhibitConditionalUseStatements]
+[Modules::RequireBarewordIncludes]
+[Modules::RequireFilenameMatchesPackage]
+[Modules::RequireNoMatchVarsWithUseEnglish]
+[NamingConventions::Capitalization]
+# tCMS: each renderer is named for the content type it renders, and each
+# script's package for the script.  The policy tests each part of a package
+# name on its own, so these are the parts.
+package_exemptions = main tcms login useradd blob css email html json text
+[RegularExpressions::ProhibitCaptureWithoutTest]
+[RegularExpressions::ProhibitComplexRegexes]
+[RegularExpressions::ProhibitEnumeratedClasses]
+[RegularExpressions::ProhibitFixedStringMatches]
+[RegularExpressions::ProhibitSingleCharAlternation]
+[RegularExpressions::ProhibitUnusedCapture]
+[RegularExpressions::RequireBracesForMultiline]
+[RegularExpressions::RequireDotMatchAnything]
+[RegularExpressions::RequireExtendedFormatting]
+[Subroutines::ProhibitAmpersandSigils]
+[Subroutines::ProhibitBuiltinHomonyms]
+# tCMS: read, write and delete are methods of every data model.  index is the
+# route that every page ends in, which a theme's routes call by that name.
+# shutdown is a method of Sys::Virt::Domain, which a test fakes.
+allow = read write delete index shutdown
+[Subroutines::ProhibitManyArgs]
+[Subroutines::ProhibitNestedSubs]
+[Subroutines::ProhibitReturnSort]
+[Subroutines::ProhibitSubroutinePrototypes]
+[Subroutines::ProtectPrivateSubs]
+[Subroutines::RequireArgUnpacking]
+[Subroutines::RequireFinalReturn]
+# tCMS: a sub that forks ends its child with POSIX::_exit, which never returns.
+terminal_funcs = POSIX::_exit
+[TestingAndDebugging::ProhibitProlongedStrictureOverride]
+[TestingAndDebugging::RequireTestLabels]
+[ValuesAndExpressions::ProhibitCommaSeparatedStatements]
+[ValuesAndExpressions::ProhibitComplexVersion]
+[ValuesAndExpressions::ProhibitEscapedCharacters]
+[ValuesAndExpressions::ProhibitLongChainsOfMethodCalls]
+[ValuesAndExpressions::ProhibitMismatchedOperators]
+[ValuesAndExpressions::ProhibitMixedBooleanOperators]
+[ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters]
+[ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator]
+[ValuesAndExpressions::ProhibitVersionStrings]
+[ValuesAndExpressions::RequireConstantVersion]
+[ValuesAndExpressions::RequireQuotedHeredocTerminator]
+[ValuesAndExpressions::RequireUpperCaseHeredocTerminator]
+[Variables::ProhibitAugmentedAssignmentInDeclaration]
+[Variables::ProhibitConditionalDeclarations]
+# Variables::ProhibitEvilVariables is not listed: it declines to load until it
+# is given variables to prohibit, and nobody has named any.
+[Variables::ProhibitLocalVars]
+[Variables::ProhibitMatchVars]
+# Drop this one at 5.041 and later, with RequireASCII above.
+[Variables::ProhibitPerl4PackageNames]
+[Variables::ProhibitReusedNames]
+# Stricter than the core ProhibitUnusedVariables, which reports only a bare
+# `my $x;` and misses a variable that is assigned and never read.
+[Variables::ProhibitUnusedVarsStricter]
+# A method takes the arguments of its interface, whether it reads them or not.
+allow_unused_subroutine_arguments = 1
+# Anything that returns a guard, which does its work by being held to the end of
+# its scope: a mock, a mocked file, a change of directory, a lock.
+# allow_if_computed_by = Test::MockModule->new Test::MockFile->file
+[Variables::ProtectPrivateVars]
+[Variables::RequireLexicalLoopIterators]
+[Variables::RequireLocalizedPunctuationVars]
+[Variables::RequireNegativeIndices]
+# Extensions to perl -c
+[CompileTime]

.perltidyrc

@@ -0,0 +1,398 @@
+# Words Documentation::PodSpelling takes as spelled right, named in .perlcriticrc.
+# aspell is asked for American English, which is what the POD here is written in,
+# so what is left is vocabulary no dictionary has -- commands, daemons, file and
+# option names, module names -- and the pieces of a token aspell splits at a
+# digit, like the IPv of IPv4.  A misspelling does not belong here: fix it.
+#
+# One word per line, sorted without regard to case, so that adding one is a
+# one-line diff and nobody has to read the whole file to decide whether it is
+# already in it.
+#
+# Put each part of your own name and of the copyright holder's in here, one per
+# line.  PodSpelling reads the AUTHORS and COPYRIGHT sections that Pod::Weaver
+# generates, and a surname is in no dictionary.  The licence words below are
+# from the text weaver.ini puts in the COPYRIGHT section of every module.
+accessor
+accessors
+ACL
+acl
+acls
+addon
+aes
+AIO
+allowlist
+API
+arg
+args
+argv
+arrayref
+auth
+authdb
+authenticator
+autodetect
+autodetected
+autodetecting
+autodetects
+autogen
+backend
+backends
+BackPAN
+backtick
+basename
+baz
+bool
+bugtracker
+cacheable
+cfg
+checkboxes
+checksummed
+checksumming
+CHECKSUMS
+checksums
+chmod
+chmodded
+chmodding
+chmods
+chown
+chowned
+chowning
+chowns
+chroot
+chrooted
+chrooting
+chroots
+CIDR
+CIDRs
+ciphertext
+CLI
+codename
+coderef
+conf
+config
+configs
+contactemail
+CPAN
+cpanm
+CPUs
+cron
+crons
+csp
+css
+CVE
+datasource
+datasources
+datastore
+DDL
+decrypt
+decrypted
+deduped
+deduplicate
+deduplicated
+deduplicates
+deduplicating
+dep
+deps
+dereference
+dev
+DHCP
+dir
+dirs
+displayname
+distro
+distros
+DKIM
+DMARC
+DN
+DNS
+doctype
+dom
+dotfiles
+dropdown
+dryrun
+DSN
+dzil
+ECDSA
+ENV
+env
+etags
+favicon
+fb
+filehandle
+filesystem
+filetest
+flatfile
+footbar
+formatter
+formatters
+FQDN
+fqdn
+fred
+frontend
+FTS
+fts
+gcm
+GiB
+gitignore
+GraphQL
+greppable
+gzip
+hardcode
+hardcoded
+hardcodes
+hardcoding
+hashref
+hashrefs
+heredoc
+hostname
+hotplug
+href
+hrefs
+hsts
+html
+HTTPS
+https
+hup
+ico
+imager
+IMAP
+indexable
+INI
+ini
+init
+inkscape
+inlined
+inlining
+inotify
+ipads
+iphones
+IPs
+IPv
+journald
+js
+jsalert
+JSON
+json
+keepass
+keypair
+keyspace
+KiB
+kolon
+lang
+LDAP
+LDAPS
+LDIF
+leftbar
+libmagic
+libravatar
+libvirt
+lifecycle
+logname
+lookups
+loopback
+lowercased
+lowercases
+lowercasing
+LTS
+MACs
+Makefile
+makefile
+makefiles
+memoize
+memoized
+memoizes
+memoizing
+MERCHANTABILITY
+MetaCPAN
+MiB
+midtitle
+mimetype
+minify
+misconfigure
+misconfigured
+misconfigures
+misconfiguring
+mistyped
+msg
+mtime
+mtimes
+multiline
+MX
+nameserver
+nameservers
+namespace
+nginx
+nginxproxy
+NIC
+nocache
+NONINFRINGEMENT
+nosniff
+NTP
+nullary
+OAuth
+OOM
+OpenAPI
+OpenAPIv
+openapiv
+overcommit
+overcommits
+overcommitted
+overcommitting
+paginator
+param
+params
+passwordless
+payor
+PCI
+PCIe
+pdf
+pdfs
+PEM
+perlcritic
+perlcriticrc
+perltidy
+PKI
+plaintext
+png
+POSIX
+pragmas
+preflight
+prev
+provisioner
+proxied
+proxying
+psgi
+qemu
+queryable
+quotemeta'd
+ramdisk
+readdir
+readme
+recurse
+recursed
+recurses
+recursing
+regenerable
+renderer
+repo
+repos
+reprovision
+reprovisioning
+requestid
+resetpass
+revalidate
+rightbar
+RPC
+RSA
+rss
+rsync
+rsynced
+rsyncing
+rsyncs
+rsyslog
+ruleset
+runtime
+scaffolded
+scp
+sessid
+setsid'd
+sftp
+SHA
+sha
+SMTP
+snapshotting
+SRV
+sshd
+SSL
+stderr
+stdin
+stdout
+stylesheet
+stylesheets
+Subclasses
+subdir
+subdirectories
+subdirectory
+sublicense
+subnet
+substring
+subtest
+sudo
+svg
+symlink
+symlinked
+symlinking
+symlinks
+sysctl
+syslog
+systemd
+TCMS
+tcms
+TCP
+teardown
+templated
+templating
+textarea
+themeclone
+timestamp
+TLD
+TLDs
+TLS
+tmux
+TODO
+tokenizer
+toolchain
+topbar
+totp
+tpm
+tpsgi
+trigram
+trog
+troglodyne
+truthy
+tx
+TXT
+txt
+udev
+UDP
+UI
+UID
+umask
+uncached
+unconfigured
+undecorated
+undef
+undefine
+undefines
+undefining
+unindexed
+unix
+unlink
+unlinked
+unlinking
+unlinks
+unparameterized
+unstretched
+URI
+uri
+URIs
+useradd
+UUID
+uuid
+validator
+vhost
+vhosts
+virdomainscreenshot
+virt
+VM
+VMs
+VPN
+VPNs
+WAL
+webserver
+whitespace
+wilma
+xhr
+xml
+xsl
+xslate
+YAML

.preferred_modules.ini

@@ -0,0 +1,57 @@
+[JSON]
+[JSON::PP]
+[JSON::XS]
+prefer = Cpanel::JSON::XS
+reason = "Use a correct & fast JSON parser"
+
+[YAML]
+[YAML::PP]
+[YAML::Syck]
+prefer = YAML::XS
+reason = "Use a correct & fast YAML parser"
+
+[Sereal]
+[Storable]
+prefer = Cpanel::JSON::XS
+reason = "JSON/YAML is preferred serialization format"
+
+[File::Slurper]
+prefer = File::Slurper::Temp
+for = write_binary write_text
+reason = "Avoid mangling files with concurrent writes"
+
+[constant]
+prefer = Readonly
+reason = "A Readonly variable interpolates, has a sigil to find it by, and refuses an assignment at run time"
+
+[perl/rand]
+prefer = Crypt::PRNG
+reason = builtin rand() insecure
+
+[perl/sleep]
+prefer = Time::HiRes
+reason = "The builtin sleeps whole seconds, so a poll interval cannot be shorter than a second"
+
+; tCMS: no [perl/time].  Its times are stored whole-second timestamps, such as
+; a post's created, and not intervals, and the tests set the clock through
+; CORE::GLOBAL::time, which Time::HiRes::time does not use.
+
+[perl/alarm]
+prefer = Time::HiRes
+reason = "The builtin takes whole seconds, so it cannot time out sooner than a second"
+
+[perl/readdir]
+reason="Use File::Find::find() instead"
+
+[Term::ReadKey]
+[IO::Prompt]
+[IO::Prompt::Tiny]
+[Term::Prompt]
+[Prompt::Timeout]
+prefer = IO::Prompter
+reason = "One way to ask for input; it suppresses echo and copes with not having a terminal"
+
+[MIME::Base32::XS]
+[Encode::Base2N]
+prefer = MIME::Base32
+reason = "MIME::Base32::XS corrupts the heap and pads its output, and Encode::Base2N needs a C++ build that cpm cannot install"

.tests-covering-map.pl

@@ -0,0 +1,67 @@
+#!/usr/bin/env perl
+use 5.040;
+use warnings FATAL => 'all';
+use re '/aa';
+
+=head1 NAME
+
+.tests-covering-map.pl - which tests reach the files that no test loads, for
+tests-covering
+
+=head1 DESCRIPTION
+
+git-hooks/pre-commit asks tests-covering which tests a commit can break.
+tests-covering follows the Perl that each test loads, and asks this map about
+every other file in the diff.  See "THE MAP" in L<Perl::Tests::Covering>.
+
+The map answers C<q{}>, which is C<NO_TESTS>, for the files of tCMS that
+C<prove -l t/> never reads:
+
+=over
+
+=item Documentation
+
+Markdown, such as F<Readme.md> and F<design.md>, POD in F<.pod> files outside
+F<lib/>, F<CHANGELOG> and F<LICENSE>.
+
+=item The build and the install
+
+F<Makefile.PL>, F<Installer.mk>, F<package.json> and F<package-lock.json>.
+C<make> and C<npm> read them, and no test does.
+
+=item The tools and the hooks
+
+The C<perltidy> and C<perlcritic> configuration and the files that it reads,
+F<.mailmap>, F<.gitignore>, F<.gitattributes>, this map, F<git-hooks/> and
+F<.github/>.
+
+=item The author tests
+
+F<xt/>, which the hooks do not run.
+
+=back
+
+Anything else, it leaves unexplained, and the hook then runs every test.  A
+file that a test reads without loading it, such as a template or a fixture,
+wants a rule here that names the tests that read it.
+
+=cut
+
+# Read by the tools, by make or by people, and by no test.
+my %NO_TESTS = map { $_ => 1 } qw{
+  CHANGELOG LICENSE
+  Makefile.PL Installer.mk package.json package-lock.json
+  .perltidyrc .perlcriticrc .perlcriticrc.compat .pod_stopwords .preferred_modules.ini .preferred_binaries.ini
+  .mailmap .gitignore .gitattributes .tests-covering-map.pl
+};
+
+return sub {
+    my ($path) = @_;
+
+    return q{} if $NO_TESTS{$path};
+    return q{} if $path =~ m{\A(?:git-hooks|[.]github|xt)/}sx;
+    return q{} if $path =~ m{[.]md\z}sx;
+    return q{} if $path =~ m{[.]pod\z}sx && $path !~ m{\Alib/}sx;
+
+    return;
+};

CHANGELOG

@@ -0,0 +1,127 @@
+# CLAUDE.md
+
+This file is the procedure for work in this repository.  The POD and the files
+named below say what the code is and how it is written.
+
+tCMS is a CMS for perl, run by tPSGI, in which a post can be content of any type.
+Read `design.md` first: it says what a post is, why the routing table is
+data, and where a given change belongs.
+
+## Read the code before you change it
+
+Before you answer a question about the code here, look for something in it, or
+edit it, invoke `perl-slop:reading-perl`.
+
+Most of the code here is older than the conversation about it.  A line that
+looks pointless is usually the scar of something that went wrong once.  The
+reason is in the commit, not in the file.  So read before the first edit, not
+after the tests fail.
+
+The same pass asks whether the code that you want to write is already here,
+under a name that you did not search for.  Two subs that do one job are a
+defect, whichever one is better.
+
+## What perl this runs on
+
+Every module, script and test says `use 5.040`, and `MIN_PERL_VERSION` in
+`Makefile.PL` says the same.  `.perlcriticrc` depends on it.  The header of
+that file names the policies that this version of perl makes unnecessary.  So
+if you raise or lower the floor, change the profile as well as the `use` lines.
+
+## Where it is written down
+
+| | |
+|---|---|
+| `Readme.md` | what tCMS is for, and how to deploy it |
+| `design.md` | the architecture, and where a given change belongs |
+| `.perlcriticrc` | the policies, which are the house style made enforceable |
+| `CHANGELOG` | what changed, per major version |
+| `Makefile.PL` | what has to be installed to run tCMS, and to develop it |
+| `Installer.mk` | the directories and the front-end files that an install needs |
+
+## Finishing a changeset
+
+Before you commit, apply these skills in this order:
+
+1. `perl-slop:data-perl`: make sure that the data is defined, coerced,
+   validated and scoped in the way that perl expects.
+2. `perl-slop:testing-perl`: make sure that each behavior that you added or
+   changed has a test, and that the test is the right kind.
+3. `perl-slop:reviewing-perl`: read the whole diff back against it.  This pass
+   finds a second copy of something that the library already does.  It also
+   finds a call out to the shell, and a comment that belongs in the commit
+   message.
+
+Then run `podchecker` on each changed file.  Run `perl -Ilib -c` on each
+changed script that no test loads, because the tests do not compile it.
+
+The pre-commit hook does the rest.  It tidies the Perl that you staged, runs
+perlcritic on it, and runs the tests that the commit can break, which
+`tests-covering` chooses.  The post-commit hook keeps the records of
+`tests-covering` up to date, in the background.  If a step fails, the hook stops the
+commit and prints the reason.  Do not run `perltidy` or `perlcritic` yourself,
+and do not run the tests to decide whether a change is ready to commit.
+
+The hook names each test that failed.  Its output does not say why.  If a test
+fails, run that file yourself with `-v`, and read the output:
+
+```
+prove -lv t/<file>.t
+```
+
+Do the same to see a new test fail before you fix what it tests.
+
+In each clone that you commit from, install both hooks once.  Git does not
+install them for you, and without the hooks the tree drifts from its style:
+
+```
+cp git-hooks/pre-commit git-hooks/post-commit .git/hooks/
+```
+
+A file that no test loads, such as a fixture, gets its tests from
+`.tests-covering-map.pl`.  A path that the map cannot place runs every test.
+If a commit runs every test but does not touch everything, the map probably
+needs a rule.  Add the rule in the same change, and name the tests that read
+the file.
+
+## When something is slow
+
+Use `perl-slop:profiling-perl`.  Measure before you conclude anything, and
+measure again after a change.  "It is just slow" is not a finding.  A line
+number and a percentage is a finding.
+
+## Installing what development needs
+
+The hooks and `.perlcriticrc` need the develop prerequisites in `Makefile.PL`.
+When `.perlcriticrc` names a policy from another distribution, add that
+distribution there in the same change.
+
+```
+cpanm --installdeps --with-develop .
+```
+
+## Commits and pull requests
+
+Make a branch.  Do not commit to the default branch.
+
+A commit message here says what was wrong and why the change fixes it.  Write
+it in prose and in the imperative mood.  Name the behavior, not the diff, for
+example "Ask the pool whether it takes O_DIRECT, rather than guessing from its
+name".  The message has a job.  `perl-slop:reading-perl` describes a person who
+finds your line with `git blame` two years from now.  The message is the only
+thing that can still tell that person why.  For the same reason, the why goes
+in the message and not in a comment.
+
+After you make sure that something works, say what you ran and what it said.
+A claim that the tests pass needs the line that shows them passing.  A claim
+about your own work needs its evidence too, such as the URL from `gh pr
+create` or the sha from `git push`.  A PR number that nobody can open is worse
+than no number.
+
+If the code of a branch depends on another branch, stack it on that branch.
+If only a test of it depends on the other branch, do not stack it.  A change
+whose tests need a fix from somebody else is still an independent change.
+Open it against the default branch, and say in the description what must
+merge first.  A stacked branch merges into its base, whatever that base is.
+If the base reached the default branch by another route, the stacked change
+reaches nowhere, and nothing says so.

Dockerfile

@@ -1,13 +0,0 @@
-FROM troglodyne/base:latest
-
-ARG port=5000
-LABEL description="tCMS: a Perl CMS by Troglodyne LLC"
-
-ADD . /home/tcms
-RUN chown -R tcms /home/tcms
-
-USER tcms
-
-RUN make install
-ENTRYPOINT ["/usr/bin/starman","www/server.psgi"]
-CMD ['-p',$port]

Dockerfile.build

@@ -1,17 +0,0 @@
-FROM ubuntu:21.04
-
-USER root
-RUN useradd tcms
-
-ADD ./Makefile /home/tcms/Makefile
-ADD ./Makefile.PL /home/tcms/Makefile.PL
-RUN mkdir /home/tcms/.tcms
-RUN mkdir -p /home/tcms/www/scripts
-RUN chown -R tcms /home/tcms
-
-WORKDIR /home/tcms
-
-RUN apt-get update
-RUN apt-get upgrade -y
-RUN apt-get install -y make
-RUN make prereq-debian

Installer.mk

@@ -1,52 +1,16 @@
 SHELL := /bin/bash
-SERVER_NAME := $(shell bin/tcms-hostname)
-
-.PHONY: depend
-depend:
-	[ -f "/etc/debian_version" ] && make -f Installer.mk prereq-debs; /bin/true;
-	make -f Installer.mk prereq-perl prereq-frontend
 
 .PHONY: install
 install:
 	test -d www/themes || mkdir -p www/themes
 	test -d data/files || mkdir -p data/files
-	test -d www/assets || mkdir -p www/assets
+	test -d www/assets/private || mkdir -p www/assets/private
 	test -d www/statics || mkdir -p www/statics
 	test -d totp/ || mkdir -p totp
 	test -d ~/.tcms || mkdir ~/.tcms
-	test -d logs/ && mkdir -p logs/; /bin/true
+	test -d logs || mkdir -p logs
 	$(RM) pod2htmd.tmp;
 
-.PHONY: install-service
-install-service:
-	mkdir -p ~/.config/systemd/user
-	cp service-files/systemd.unit ~/.config/systemd/user/tCMS.service
-	sed -ie 's#__REPLACEME__#$(shell pwd)#g' ~/.config/systemd/user/tCMS.service
-	systemctl --user daemon-reload
-	systemctl --user enable tCMS
-	systemctl --user start tCMS
-	loginctl enable-linger $(USER)
-
-.PHONY: prereq-debian
-prereq-debian: prereq-debs prereq-perl prereq-frontend prereq-node
-
-.PHONY: prereq-debs
-prereq-debs:
-	sudo apt-get update
-	sudo apt-get install -y sqlite3 nodejs npm libsqlite3-dev libdbd-sqlite3-perl cpanminus starman libxml2 curl cmake \
-		uwsgi uwsgi-plugin-psgi fail2ban nginx certbot postfix dovecot-imapd dovecot-pop3d postgrey spamassassin amavis clamav\
-		opendmarc opendkim opendkim-tools libunbound-dev \
-	    libtext-xslate-perl libplack-perl libconfig-tiny-perl libdatetime-format-http-perl libjson-maybexs-perl          \
-	    libuuid-tiny-perl libcapture-tiny-perl libconfig-simple-perl libdbi-perl libfile-slurper-perl libfile-touch-perl \
-	    libfile-copy-recursive-perl libxml-rss-perl libmodule-install-perl libio-string-perl uuid-dev                    \
-	    libmoose-perl libmoosex-types-datetime-perl libxml-libxml-perl liblist-moreutils-perl libclone-perl libpath-tiny-perl \
-		selinux-utils setools policycoreutils-python-utils policycoreutils selinux-basics auditd \
-		pdns-tools pdns-server pdns-backend-sqlite3 libmagic-dev autotools-dev dh-autoreconf
-
-.PHONY: prereq-perl
-prereq-perl:
-	sudo cpanm -n --installdeps .
-
 .PHONY: prereq-node
 prereq-node:
 	npm i
@@ -57,12 +21,15 @@ prereq-frontend:
 		"https://raw.githubusercontent.com/chalda-pnuzig/emojis.json/master/dist/list.min.json" \
 		"https://raw.githubusercontent.com/highlightjs/cdn-release/main/build/highlight.min.js" \
 		"https://cdn.jsdelivr.net/npm/chart.js" \
-		"https://github.com/hakimel/reveal.js/blob/master/dist/reveal.js"; popd
+		"https://raw.githubusercontent.com/hakimel/reveal.js/master/dist/reveal.js"; popd
+	mv www/scripts/chart.js www/scripts/chart.min.js
+	mv www/scripts/reveal.js www/scripts/reveal.min.js
 	mkdir -p www/styles; pushd www/styles && curl -L --remote-name-all \
 		"https://raw.githubusercontent.com/highlightjs/cdn-release/main/build/styles/obsidian.min.css" \
 	    "https://raw.githubusercontent.com/hakimel/reveal.js/master/dist/reveal.css" \
 		"https://raw.githubusercontent.com/hakimel/reveal.js/master/dist/theme/white.css"; popd
 	mv www/styles/white.css www/styles/reveal-white.css
+	sed -i 's/Source Sans Pro,//g' www/styles/reveal-white.css
 
 .PHONY: reset
 reset: reset-remove install
@@ -77,119 +44,6 @@ reset-remove:
 	rm config/has_users; /bin/true
 	rm config/setup; /bin/true
 
-.PHONY: fail2ban
-fail2ban:
-	cp fail2ban/tcms-jail.tmpl fail2ban/tcms-jail.conf
-	sed -i 's#__LOGDIR__#$(shell pwd)#g' fail2ban/tcms-jail.conf
-	sed -i 's#__DOMAIN__#$(shell bin/tcms-hostname)#g' fail2ban/tcms-jail.conf
-	sudo rm /etc/fail2ban/jail.d/$(shell bin/tcms-hostname).conf; /bin/true
-	sudo rm /etc/fail2ban/filter.d/$(shell bin/tcms-hostname).conf; /bin/true
-	sudo ln -sr fail2ban/tcms-jail.conf   /etc/fail2ban/jail.d/$(shell bin/tcms-hostname).conf
-	sudo ln -sr fail2ban/tcms-filter.conf /etc/fail2ban/filter.d/$(shell bin/tcms-hostname).conf
-	sudo systemctl reload fail2ban
-
-.PHONY: nginx
-nginx:
-	[ -n "$$SERVER_NAME" ] || ( echo "Please set the SERVER_NAME environment variable before running (e.g. test.test)" && /bin/false )
-	sed 's/\%SERVER_NAME\%/$(SERVER_NAME)/g' nginx/tcms.conf.tmpl > nginx/tcms.conf.intermediate
-	sed 's/\%SERVER_SOCK\%/$(shell pwd)/g' nginx/tcms.conf.intermediate > nginx/tcms.conf
-	rm nginx/tcms.conf.intermediate
-	mkdir run
-	chown $(USER):www-data run
-	chmod 0770 run
-	sudo mkdir -p '/var/www/$(SERVER_NAME)'
-	sudo mkdir -p '/var/www/mail.$(SERVER_NAME)'
-	sudo mkdir -p '/etc/letsencrypt/live/$(SERVER_NAME)'
-	[ -e "/etc/nginx/sites-enabled/$$SERVER_NAME.conf" ] && sudo rm "/etc/nginx/sites-enabled/$$SERVER_NAME.conf"; /bin/true
-	sudo ln -sr nginx/tcms.conf '/etc/nginx/sites-enabled/$(SERVER_NAME).conf'
-	# Make a self-signed cert FIRST, because certbot has a chicken/egg problem
-	sudo openssl req -x509 -config etc/openssl.conf -nodes -newkey rsa:4096 -subj '/CN=$(SERVER_NAME)' -addext 'subjectAltName=DNS:www.$(SERVER_NAME),DNS:mail.$(SERVER_NAME)' -keyout '/etc/letsencrypt/live/$(SERVER_NAME)/privkey.pem' -out '/etc/letsencrypt/live/$(SERVER_NAME)/fullchain.pem' -days 365
-	sudo systemctl reload nginx
-	# Now run certbot and get that http dcv. We have to do a "gamer move" so that certbot doesn't complain about live dir existing.
-	sudo rm -rf '/etc/letsencrypt/live/$(SERVER_NAME)'
-	sudo certbot certonly --webroot -w '/var/www/$(SERVER_NAME)/' -d '$(SERVER_NAME)' -d 'www.$(SERVER_NAME)' -w '/var/www/mail.$(SERVER_NAME)' -d 'mail.$(SERVER_NAME)'
-	sudo systemctl reload nginx
-
-.PHONY: mail
-mail: dkim dmarc
-	# Dovecot
-	sudo cp /etc/dovecot/conf.d/10-ssl.conf /etc/dovecot/conf.d/10-ssl.conf.orig
-	sudo sed -i 's/^\(ssl_cert\s*=\).*/\1<\/etc\/letsencrypt\/live\/$(SERVER_NAME)\/fullchain.pem/g' /etc/dovecot/conf.d/10-ssl.conf
-	sudo sed -i 's/^\(ssl_key\s*=\).*/\1\<\/etc\/letsencrypt\/live\/$(SERVER_NAME)\/privkey.pem/g' /etc/dovecot/conf.d/10-ssl.conf
-	# Postfix
-	sudo cp /etc/postfix/main.cf /etc/postfix/main.cf.orig
-	sudo sed -i 's/^\(smtpd_tls_cert_file\s*=\).*/\1\/etc\/letsencrypt\/live\/$(SERVER_NAME)\/fullchain.pem/g' /etc/postfix/main.cf
-	sudo sed -i 's/^\(smtpd_tls_key_file\s*=\).*/\1\/etc\/letsencrypt\/live\/$(SERVER_NAME)\/privkey.pem/g' /etc/postfix/main.cf
-	# XXX we should not do these two.
-	sudo sed -i 's/^\(myhostname\s*=\).*/\1$(SERVER_NAME)/g' /etc/postfix/main.cf
-	sudo echo '$(SERVER_NAME)' > /etc/mailname
-	# Configure postfix to put on its socks and shoes.  This all implicitly relies on good defaults in the opendkim/opendmarc packages.
-	sudo postconf -e milter_default_action=accept
-	sudo postconf -e milter_protocol=2
-	sudo postconf -e smtpd_milters=local:opendkim/opendkim.sock,local:opendmarc/opendmarc.sock
-	sudo postconf -e non_smtpd_milters=\$smtpd_milters
-	sudo service postfix reload
-	# TODO setup various mail aliases and so forth, e.g. postmaster@, soa@, the various lists etc
-
-.PHONY: dkim
-dkim:
-	sudo mkdir -p /etc/opendkim/keys/$(SERVER_NAME)
-	sudo opendkim-genkey --directory /etc/opendkim/keys/$(SERVER_NAME) -s mail -d $(SERVER_NAME)
-	sudo openssl rsa -in /etc/opendkim/keys/$(SERVER_NAME)/mail.private -pubout > /tmp/mail.public
-	sudo mv /tmp/mail.public /etc/opendkim/keys/$(SERVER_NAME)/mail.public
-	sudo chown -R opendkim:opendkim /etc/opendkim
-	sudo mail/mongle_dkim_config $(SERVER_NAME)
-	sudo service opendkim enable
-	sudo service opendkim start
-
-.PHONY: dmarc
-dmarc:
-	sudo mail/mongle_dmarc_config $(SERVER_NAME) mail.$(SERVER_NAME)
-	sudo service opendmarc enable
-	sudo service opendmarc start
-
-.PHONY: dns
-dns:
-	cp dns/tcms.tmpl dns/tcms.conf
-	sed -i 's#__DIR__#$(shell pwd)#g' dns/tcms.conf
-	sed -i 's#__DOMAIN__#$(SERVER_NAME)#g' dns/tcms.conf
-	[[ -e /etc/powerdns/pdns.d/$(SERVER_NAME).conf ]] && sudo rm /etc/powerdns/pdns.d/$(SERVER_NAME).conf
-	sudo cp dns/tcms.conf /etc/powerdns/pdns.d/$(SERVER_NAME).conf
-	sudo mkdir /etc/systemd/resolved.conf.d/; /bin/true
-	sudo cp dns/10-disable-stub-resolver.conf /etc/systemd/resolved.conf.d/
-	sudo chown -R systemd-resolve:systemd-resolve /etc/systemd/resolved.conf.d/
-	sudo chmod 0660 /etc/systemd/resolved.conf.d/10-disable-stub-resolver.conf
-	sudo systemctl restart systemd-resolved
-	# Build the zone database and initialize the zone for our domain
-	rm dns/zones.db; /bin/true
-	sqlite3 dns/zones.db < /usr/share/pdns-backend-sqlite3/schema/schema.sqlite3.sql
-	bin/build_zone > dns/default.zone
-	zone2sql --gsqlite --zone=dns/default.zone --zone-name=$(SERVER_NAME) > dns/default.zone.sql
-	sqlite3 dns/zones.db < dns/default.zone.sql
-	# Bind mount our dns/ folder so that pdns can see it in chroot
-	sudo mkdir /var/spool/powerdns/$(SERVER_NAME); /bin/true
-	sudo chown pdns:pdns /var/spool/powerdns/$(SERVER_NAME); /bin/true
-	sudo cp /etc/fstab /tmp/fstab.new
-	sudo chown $(USER) /tmp/fstab.new
-	echo "$(shell pwd)/dns /var/spool/powerdns/$(SERVER_NAME) none defaults,bind 0 0" >> /tmp/fstab.new
-	sort < /tmp/fstab.new | uniq | grep -o '^[^#]*' > /tmp/fstab.new
-	sudo chown root:root /tmp/fstab.new
-	sudo mv /etc/fstab /etc/fstab.bak
-	sudo mv /tmp/fstab.new /etc/fstab
-	sudo mount /var/spool/powerdns/$(SERVER_NAME)
-	# Don't need no bind
-	[[ -e /etc/powerdns/pdns.d/bind.conf ]] && sudo rm /etc/powerdns/pdns.d/bind.conf
-	# Fix broken service configuration
-	sudo bin/configure_pdns
-	sudo cp dns/10-powerdns.conf /etc/rsyslog.d/10-powerdns.conf 
-	sudo systemctl daemon-reload
-	sudo service rsyslog restart
-	sudo service pdns enable
-	sudo service pdns start
-
 .PHONY: githook
 githook:
 	cp git-hooks/pre-commit .git/hooks
-
-.PHONY: all
-all: prereq-debian install fail2ban nginx mail dns githook

LICENSE

@@ -1,77 +1,171 @@
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use ExtUtils::MakeMaker;
 
 WriteMakefile(
-  VERSION   => '0.01',
-  META_MERGE        => {
-    "meta-spec" => { version => 2 },
-    resources => {
-      repository => {
-          type => 'git',
-          url  => 'git@github.com:Troglodyne-Internet-Widgets/tCMS.git',
-          web  => 'https://github.com/Troglodyne-Internet-Widgets/tCMS',
-      },
+    VERSION => '0.01',
+
+    # Every module, script and test declares 'use 5.040'.
+    MIN_PERL_VERSION => '5.040000',
+    META_MERGE       => {
+        "meta-spec" => { version => 2 },
+
+        # What the hooks and .perlcriticrc need, which nothing at run time does.
+        # Add a line whenever .perlcriticrc names a policy from another distribution.
+        prereqs => {
+            develop => {
+                requires => {
+                    'Perl::Critic'                                                                   => '0',
+                    'Perl::Tidy'                                                                     => '0',
+                    'Devel::Cover'                                                                   => '0',
+                    'Perl::Tests::Covering'                                                          => '0.002',
+                    'Perl::Critic::Policy::Modules::RequirePerlVersion'                              => '0',
+                    'Perl::Critic::Policy::Documentation::RequirePod'                                => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::PreventSQLInjection'                => '0',
+                    'Perl::Critic::Policy::CodeLayout::RequireASCII'                                 => '0',
+                    'Perl::Critic::Policy::RegularExpressions::RequireDefault'                       => '0',
+                    'Perl::Critic::Policy::BuiltinFunctions::ProhibitDeleteOnArrays'                 => '0',
+                    'Perl::Critic::Policy::Subroutines::ProhibitAmbiguousFunctionCalls'              => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ProhibitSingleArgArraySlice'        => '0',
+                    'Perl::Critic::Policy::Bangs::ProhibitUselessRegexModifiers'                     => '0',
+                    'Perl::Critic::Policy::Bangs::ProhibitCommentedOutCode'                          => '0',
+                    'Perl::Critic::Policy::Tics::ProhibitUseBase'                                    => '0',
+                    'Perl::Critic::Policy::Plicease::ProhibitLeadingZeros'                           => '0',
+                    'Perl::Critic::Policy::RegularExpressions::ProhibitEmptyAlternatives'            => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::UnexpandedSpecialLiteral'           => '0',
+                    'Perl::Critic::Policy::CodeLayout::ProhibitIfIfSameLine'                         => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ConstantBeforeLt'                   => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ProhibitDuplicateHashKeys'          => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ProhibitFiletest_f'                 => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ProhibitFiletest_rwxRWX'            => '0',
+                    'Perl::Critic::Policy::CognitiveComplexity::ProhibitExcessCognitiveComplexity'   => '0',
+                    'Perl::Critic::Policy::Variables::ProhibitUselessInitialization'                 => '0',
+                    'Perl::Critic::Policy::PreferredModules'                                         => '0',
+                    'Perl::Critic::Policy::logicLAB::RequireSheBang'                                 => '0',
+                    'Perl::Critic::Policy::logicLAB::ProhibitShellDispatch'                          => '0',
+                    'Perl::Critic::Policy::Performance::ProhibitRegexForSimpleSubstring'             => '0',
+                    'Perl::Critic::Policy::RegularExpressions::ProhibitRegexToStripAffix'            => '0',
+                    'Perl::Critic::Policy::RegularExpressions::ProhibitRegexToChomp'                 => '0',
+                    'Perl::Critic::Policy::BuiltinFunctions::ProhibitChainingSameListSub'            => '0',
+                    'Perl::Critic::Policy::RegularExpressions::ProhibitRegexForStringEquality'       => '0',
+                    'Perl::Critic::Policy::Subroutines::ProhibitUnderscorePrivateSubs'               => '0',
+                    'Perl::Critic::Policy::Subroutines::ProhibitSingleUseLexicalSubs'                => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLiteralArithmetic'          => '0',
+                    'Perl::Critic::Policy::BuiltinFunctions::ProhibitIndirectBooleanGrep'            => '0',
+                    'Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctionsStricter' => '0',
+                    'Perl::Critic::Policy::ControlStructures::ProhibitEmptyConditionalBlocks'        => '0',
+                    'Perl::Critic::Policy::ErrorHandling::RequireCheckedIndirectResults'             => '0',
+                    'Perl::Critic::Policy::CompileTime'                                              => '0',
+                    'Perl::Critic::Policy::ProhibitPipeOpen'                                         => '0',
+                    'Perl::Critic::Policy::ProhibitUseLib'                                           => '0',
+                    'Perl::Critic::Policy::ProhibitUsageSubs'                                        => '0',
+                    'Perl::Critic::Policy::RequireQwForLiteralLists'                                 => '0',
+                    'Perl::Critic::Policy::ProhibitNoWarningsRedefine'                               => '0',
+                    'Perl::Critic::Policy::RequireFatalWarnings'                                     => '0',
+                    'Perl::Critic::Policy::ProhibitUnusedImports'                                    => '0',
+                    'Perl::Critic::Policy::ProhibitMisplacedMethods'                                 => '0',
+                    'Perl::Critic::Policy::ProhibitPrintSTDERR'                                      => '0',
+                    'Perl::Critic::Policy::InputOutput::ProhibitRepeatedPrints'                      => '0',
+                    'Perl::Critic::Policy::ValuesAndExpressions::ProhibitDefinedBeforeLength'        => '0',
+                    'Perl::Critic::Policy::Variables::ProhibitUselessVarClearing'                    => '0.001',
+                    'Perl::Critic::Policy::Subroutines::ProhibitTailRecursion'                       => '0.001',
+                    'Perl::Critic::Policy::RegularExpressions::PreventUselessMetacharacterEscapes'   => '0',
+                    'Perl::Critic::Policy::Variables::ProhibitUnusedVarsStricter'                    => '0',
+                    'Perl::Critic::Policy::ProhibitUnusedDefinitions'                                => '0.007',
+                },
+            },
+        },
+        resources => {
+            repository => {
+                type => 'git',
+                url  => 'git@github.com:Troglodyne-Internet-Widgets/tCMS.git',
+                web  => 'https://github.com/Troglodyne-Internet-Widgets/tCMS',
+            },
+        },
+    },
+    PREREQ_PM => {
+        'Trog::TOTP'                          => '1.008',
+        'Trog::SQLite'                        => '0.004',
+        'CGI::Cookie'                         => '0',
+        'Capture::Tiny'                       => '0',
+        'Carp'                                => '0',
+        'Config::Simple'                      => '0',
+        'Crypt::Argon2'                       => '0',
+        'CryptX'                              => '0',
+        'DBD::SQLite'                         => '0',
+        'DBI'                                 => '0',
+        'Date::Format'                        => '0',
+        'DateTime::Format::HTTP'              => '0',
+        'Digest::SHA'                         => '0',
+        'Errno'                               => '0',
+        'File::Basename'                      => '0',
+        'File::Copy'                          => '0',
+        'File::Slurper'                       => '0',
+        'File::Slurper::Temp'                 => '0',
+        'File::Touch'                         => '0',
+        'File::Path'                          => '0',
+        'File::Which'                         => '0',
+        'File::Temp'                          => '0',
+        'HTML::SocialMeta'                    => '0',
+        'HTTP::Body'                          => '0',
+        'IO::String'                          => '0',
+        'IO::Compress::Gzip'                  => '0',
+        'IO::Prompter'                        => '0',
+        'Imager'                              => '0',
+        'Imager::File::ICO'                   => '0',
+        'Imager::File::PNG'                   => '0',
+        'Imager::QRCode'                      => '0',
+        'JSON::MaybeXS'                       => '0',
+        'JSON::Validator::Schema::Troglodyne' => '0',
+        'Sys::Virt'                           => '0',
+        'Sys::Hostname::FQDN'                 => '0',
+        'List::Util'                          => '0',
+        'Mojo::File'                          => '0',
+        'POSIX'                               => '0',
+        'Ref::Util'                           => '0',
+        'Pod::Html'                           => '0',
+        'Starman'                             => '0',
+        'Text::Xslate'                        => '0',
+        'URL::Encode'                         => '0',
+        'UUID'                                => '0',
+        'WWW::Sitemap::XML'                   => '0',
+        'WWW::SitemapIndex::XML'              => '0',
+        'CSS::Minifier::XS'                   => '0',
+        'JavaScript::Minifier::XS'            => '0',
+        'Path::Tiny'                          => '0',
+        'Log::Dispatch'                       => '0',
+        'Log::Dispatch::FileRotate'           => '0',
+        'URI'                                 => '0',
+        'FindBin::libs'                       => '0',
+        'Carp::Always'                        => '0',
+        'HTTP::Tiny::UNIX'                    => '0',
+        'Email::MIME'                         => '0',
+        'Email::Sender::Simple'               => '0',
+        'POSIX::strptime'                     => '0',
+        'Log::Dispatch::DBI'                  => '0',
+        'Log::Syslog::Fast'                   => '0',
+        'Module::Runtime'                     => '0',
+        'Net::IP'                             => '0',
+        'File::LibMagic'                      => '0',
+        'Linux::Perl::inotify'                => '0',
     },
-  },
-  PREREQ_PM => {
-    'Trog::TOTP'           => '0',
-    'CGI::Cookie'            => '0',
-    'Capture::Tiny'          => '0',
-    'Carp'                   => '0',
-    'Config::Simple'         => '0',
-    'DBD::SQLite'            => '0',
-    'DBI'                    => '0',
-    'Date::Format'           => '0',
-    'DateTime::Format::HTTP' => '0',
-    'Digest::SHA'            => '0',
-    'Errno'                  => '0',
-    'File::Basename'         => '0',
-    'File::Copy'             => '0',
-    'File::Slurper'          => '0',
-    'File::Touch'            => '0',
-    'HTML::SocialMeta'       => '0',
-    'HTTP::Body'             => '0',
-    'IO::String'             => '0',
-    'Imager::QRCode'         => '0',
-    'JSON::MaybeXS'          => '0',
-    'List::Util'             => '0',
-    'Mojo::File'             => '0',
-    'POSIX'                  => '0',
-    'Pod::Html'              => '0',
-    'Starman'                => '0',
-    'Text::Xslate'           => '0',
-    'URL::Encode'            => '0',
-    'UUID'                   => '0',
-    'WWW::Sitemap::XML'      => '0',
-    'WWW::SitemapIndex::XML' => '0',
-    'CSS::Minifier::XS'      => '0',
-    'JavaScript::Minifier::XS' => '0',
-    'Digest::SHA'            => '0',
-    'Path::Tiny'             => '0',
-    'IO::Compress::Brotli'   => '0',
-    'IO::Compress::Gzip'     => '0',
-    'IO::Compress::Deflate'  => '0',
-    'HTTP::Parser::XS'       => '0',
-    'Log::Dispatch'          => '0',
-    'Log::Dispatch::FileRotate' => '0',
-    'Digest::SHA'               => '0',
-    'MIME::Base32::XS'          => '0',
-    'URI'                       => '0',
-    'FindBin::libs'             => '0',
-    'Carp::Always'              => '0',
-    'HTTP::Tiny::UNIX'          => '0',
-    'Email::MIME'               => '0',
-    'Email::Sender::Simple'     => '0',
-    'POSIX::strptime'           => '0',
-    'Log::Dispatch::DBI'        => '0',
-    'Email::MIME'               => '0',
-    'Email::Sender::Simple'     => '0',
-    'DNS::Unbound'              => '0',
-    'Net::IP'                   => '0',
-    'File::LibMagic'            => '0',
-    'Linux::Perl::inotify'      => '0',
-  },
-  test => {TESTS => 't/*.t'}
+    test => { TESTS => 't/*.t' }
 );
+
+__END__
+
+=head1 NAME
+
+Makefile.PL - what tCMS needs installed
+
+=head1 DESCRIPTION
+
+PREREQ_PM lists what tCMS needs at run time.  The develop prerequisites list
+what the git hooks and .perlcriticrc need as well.
+
+    cpanm --installdeps .                  # to run tCMS
+    cpanm --installdeps --with-develop .   # to work on it
+
+=cut

Readme.md

@@ -4,64 +4,102 @@ tCMS
 A flexible perl CMS which supports multiple data models and content types.
 Should be readily portable/hostable between any other system that runs tCMS due to being largely self-contained.
 
-tCMS is built fully around ubuntu hosts at the moment.
+tCMS exists for **disintermediation from aggregators**: your content, at your
+domain, in your database, under your rules.  It is built so that standing up a
+site hosting content of any imaginable type is a day's work rather than a
+project -- which is to say, it is built for people who get paid to deliver the
+thing a client actually asked for.
 
-Deployment is currently:
+**See [design.md](design.md) for the architecture**: what a post is, why the
+routing table is data, how to add a content type without writing Perl, and where
+any given change belongs.  Start there if you are going to work on tCMS or build
+something on top of it.
+
+tCMS is built to be run by tPSGI.
+
+Simple deployment is currently:
 * make -f Installer.mk depend
 * make -f Installer.mk install
+* Setup tPSGI (supposing this clone is in a subdir tCMS of the tPSGI clone):
+
+.tpsgi.conf :
+```
+http_user=www-data
+user=INSERT_MY_USERNAME_HERE
+domain=INSERT_MY_DOMAIN_NAME_HERE
+routers=tCMS/lib/TCMS.pm
+indices=
+custom_log="/var/log/www/tpsgi.log"
+basedir="tCMS"
+```
 
 Then:
 * open tmux or screen
-* `sudo ./tcms`
-OR (if you want tCMS as a systemd service for the current user):
-* `make install-service`
+* `HOME=. bin/tpsgi -p 5001`
 
-This sets up nginx, reverse proxy and SSL certs for you.
-You must set up the user which runs tCMS to have the primary group www-data if you want to be able to run without sudo or run as a usermode service.
-It is strongly suggested that you chmod everything but the run/ directory to be 0700, particularly in a shared environment.
+You won't want to run like this in production, but this is probably how you want to develop your themes
+or hack on tCMS itself.
 
-It also sets up the mailserver and DNS for you.
+Nothing hands a vault key to a tPSGI you started yourself: the systemd credential
+and the unit that imports it are not in the picture, and `service/tpsgi.sh`, which
+is what would have put it in the environment, never ran.  So if you want /secrets
+to work while developing, mint one into the checkout:
 
-You should add the pdns group to the user you use to run tCMS, so that the zone management features will work.
+    bin/tcms-vault-key --file
 
-A Dockerfile and deployment scripts are provided for your convenience in building/running containers based on this:
-```
-# Build and run the server
-./fulldeploy.sh
-# Just run the server with latest changes
-./dockerdeploy.sh
-# Extract configuration & local data, then spin down the server
-./docker-exfil.sh
-```
-There is also podman container code; see images/README.md
+That writes `config/secrets.key`, which is the last place Trog::Vault looks.  It
+is the right thing for development and testing and the wrong thing for a
+production host, for the reason under Stored Secrets: it sits next to the database
+it protects, so anything that backs up one backs up the other.  `.gitignore` keeps
+it out of the repository; keeping it out of your backups is on you.
+
+Production Deployment
+====================
 
-The user guide is self-hosted; After you first login, hit the 'Manual' section in the backend.
+See the trog-provisioner repository.
 
-Rate-Limiting is expected to be handled at the level of the webserver proxying requests to this application.
-See ufw/setup-rules as an example of the easy way to setup rules/limiting for all the services you need to run tCMS.
+You will be interested particularly in:
 
-Migration of tCMS1 sites
-=========================
+- Provisioner::Recipe::tcms
+- Provisioner::Recipe::tpsgi
+- Provisioner::Recipe::nginxproxy
 
-See migrate.pl, and modify the $docroot variable appropriately
+Many of the advanced features of tCMS won't work quite right without the configurations encoded therein.
 
 Content Types
 =============
+See [design.md](design.md#post-types) for how post types work and what the
+sidecar can declare.  In brief:
+
 Content templates are modular.
 Add in a template to www/templates/html/components/forms which describe the content *and* how to edit it.
 Our post data storage being JSON allows us the flexibility to have any kind of meta associated with posts, so go hog wild.
 
+You describe the type of data provided in a sidecar JSON file alongside the form's template.
+There's a wizard you can use to build these!
+
+The wizard's "Start from" dropdown reopens any type that already exists, filling the
+form in from its sidecar so you can change one thing and save it back.  Each type
+carries a description saying what it is for, which the dropdown shows and a
+collapsed textarea lets you edit.
+
+The canned blocks an editor reuses -- preview.tx, tags.tx, attachments.tx and the
+rest -- have sidecars of their own beside them in components/, saying which fields
+each one collects.  That is how the wizard knows a preview image is a box to tick
+rather than a custom field to list, and how a type built by the wizard keeps the
+preview image its editor uploaded.
+
+From there you make Series of the content type you want; tag the series with 'topbar' if you want it to show up in the top links.
+
 Currently supported:
 * Microblogs
 * Blogs
 * Files (Video/Audio/Images/Other)
 * About Pages
-* Post Series
 * Presentations
-
-Planned development:
-* LaTeX
-* Test Plans / Issues (crossover with App::Prove::Elasticsearch)
+Virtualization Data:
+* Hypervisors
+* Guests
 
 Embedding Posts within other Posts
 ==================================
@@ -84,20 +122,250 @@ These will be added as classes to the embedded post, so you can theme this appro
 
 Data Models
 ===========
-* DUMMY - A JSON blob.  Used for testing mostly, but could be handy for very small sites.
-* Flat File - Pretty much the tCMS1 data model; a migration script is forthcoming
+Posts are normally stored as a file somewhere.
 
-Planned Development:
-* Elasticsearch - Documents are ideally indexed in a search engine, should be nice and fast too.
-* Git - More for the APE crossover
-
-Supported PSGI servers
-======================
-
-Starman and uWSGI
-
-In production, I would expect you to run under uWSGI, and the `tcms-uwsgi` command in the TLD runs this.
-Otherwise, you can run `tcms` to start starman normally.
+* DUMMY - A JSON blob.  Used for testing mostly, but could be handy for very small sites.
+* Flat File - Pretty much the tCMS1 data model, but with an SQLite index bolted on.
+* SQLite - The posts themselves in SQLite, blob and all.
+
+Pick one with general.data_model in your config.
+
+The SQLite model stores each version of each post as the same JSON blob the flat
+file model would have written, and projects everything worth querying back out of
+it as GENERATED ALWAYS ... VIRTUAL columns, which cost no storage and cannot drift
+from the post they came from.  Filtering, paging and search are then the
+database's job rather than a grep over every post on disk -- on a 20,000 post
+site, a search goes from about 2.5 seconds to about 3 milliseconds.  Search is an
+FTS5 index built with the trigram tokenizer, so it keeps the case insensitive
+substring matching the search box always had.
+
+Adding a queryable field is one ALTER TABLE and one CREATE INDEX in the next
+update file beside the schema, such as schema/sqlite.schema.v1.update.sql.
+Trog::SQLite runs each update file once per database, in order.  No migration of
+the data, because the data itself never moves:
+
+    ALTER TABLE posts ADD COLUMN subhead TEXT
+        GENERATED ALWAYS AS (json_extract(post_data, '$.subhead')) VIRTUAL;
+    CREATE INDEX posts_subhead ON posts(subhead);
+
+For a post type's own custom fields you don't have to write that yourself: the
+Post Type Wizard offers an "Index this field" checkbox per field, off by default,
+and saving the type does the above for every field that has it ticked.  Untick it
+and the index goes away again on the next save.  It is worth ticking for a field
+you actually search or filter on, and not otherwise -- an index costs a little
+on every save and some disk.
+
+On a data model with no notion of an index the checkbox simply does nothing, so
+the wizard doesn't have to know which model the site is running.
+
+To move an existing flat file site over, run bin/migrate.pl from the tCMS root
+and then set data_model=SQLite and restart.  It copies rather than moves, so
+data/files is left alone and the way back is to set data_model back.  It is safe
+to re-run -- run it once against the live site, then again after a final quiet
+period to pick up whatever was written in between.  --dry-run tells you what it
+would do.
+
+Data Sources
+============
+Sometimes you want to consider something else authoritative that isn't a datamodel under our control.
+
+* Virt - Talk to a libvirt HV to list guests.
+* ProvisionedVirt - Virt, plus the recipe each guest was built from and a button to build it again.
+* DirIndex - List the contents of a directory.
+
+ProvisionedVirt is a subclass of Virt, and shows what subclassing one is for: it
+inherits the libvirt half unchanged and adds the other half of the story, which is
+that a guest on a Troglodyne hypervisor was provisioned from a recipe on disk.
+Tell it where trog-provisioner is checked out and it shows each guest's
+recipes.d/$domain.yaml and offers a Reprovision button running bin/provision,
+which generates the guest's configuration from that recipe and then builds it:
+
+    [provisioner]
+        trog_provisioner = /home/you/Code/trog-provisioner
+
+Leave that out and it degrades to a plain guest listing.  The recipes themselves
+are not in the checkout -- they describe an installation rather than the software,
+so trog-provisioner keeps them in /etc/trog-provisioner, or wherever
+TROG_PROVISIONER_CONFIG says, and we read them from the same place.
+
+Reprovisioning is not recoverable: it destroys the guest and builds it again, and
+whatever the recipe does not describe does not come back.  It is POST and admin
+only, it refuses outright for the guest tCMS is itself running on (as Virt already
+refuses to power that one off), and nothing it runs goes near a shell.
+
+A provision takes minutes and an HTTP worker does not have minutes, so the work
+is handed to a detached process.  Nothing waits on it, which means it has to
+report on itself: it writes logs/reprovision/$domain.log and a status beside it,
+and the guest's entry shows which of
+
+    reprovisioning / provisioned / reprovision failed / reprovision interrupted
+
+it is, who asked for it, and a link to read the whole log.  While one is running
+the button is not offered, so a second cannot be started by double clicking.  A
+run whose status still says 'running' but whose process is gone reads as
+interrupted rather than as going on forever -- that is a guess from the only
+evidence there is, and it is the honest one.
+
+The button asks for two passwords, and neither is written to the config, the log,
+or the process table -- they go down the provisioner's stdin as a credentials
+block and nowhere else.
+
+The first is your KeePass passphrase, because every recipe inherits secret: values
+from _base.  The alternative would be keeping the master password for every secret
+you hold in a file the webserver can read.
+
+The second is your sudo password on the hypervisor, and it is optional because it
+is usually unnecessary: give that login passwordless sudo and there is nothing to
+ask for.  Where you cannot, sudo over ssh has no terminal to ask at, so a run that
+needs one and was not given one dies several minutes in on a prompt nobody will
+ever see.  Leave the field empty if this does not apply to you.
+
+Typing them every time has its own cost -- a passphrase you have to have to hand
+is one you write down somewhere -- so you can tick "remember these" and have them
+stored in your vault instead.  After that the button asks for a TOTP code, which
+is spent on that one reprovision and exchanged for both.  See Stored Secrets,
+below.
+
+Stored Secrets
+==============
+
+Some of what tCMS does for you needs a password that is not tCMS's.  /secrets is
+where each user keeps those, and what is kept there is sealed with a key the
+database does not contain, so a stolen `config/auth.db` is ciphertext.
+
+Reprovisioning uses two of them, `provisioner` and `provisioner_sudo`, and the
+reprovision dialog is the easy way to put them there.
+
+AES-256-GCM per row, under a key derived for that row from a fresh random salt,
+with the username and the secret's name bound in as associated data -- so a row
+cannot be lifted into somebody else's account or renamed into being the answer to
+a different question.  Nothing renders a value back; if you have forgotten one,
+replace it.
+
+The master key is looked for in `TPSGI_VAULT_KEY`, then
+`$CREDENTIALS_DIRECTORY/tpsgi-vault`, then `config/secrets.key`.  Use the first:
+tPSGI's `bin/build_service` mints it and puts it in systemd's credential store,
+sealed to this machine's TPM if it has one, and its unit hands it over before it
+chroots -- so it never touches a disk here.  It is named for tPSGI rather than
+tCMS because tPSGI owns the unit and runs whatever is in the directory.
+`bin/tcms-vault-key --file` writes one to `config/secrets.key` instead.  That is
+what to use when you are running tPSGI by hand rather than under systemd, which
+is the ordinary way to develop against this and to debug it -- see Development
+above.  It is also the answer on a machine with no systemd at all, and there it
+is the weaker choice: a key beside the database it protects is a key in the same
+backup as the database it protects.
+
+tCMS deletes the key from its environment as it loads, because one of the things
+it forks is a provisioner it hands a decrypted password to.  With no key there is
+no vault: nothing is stored, nothing already stored is offered, and everything
+that would have used one goes on asking for the password directly.
+
+The key lives and dies with the machine.  It is deliberately not in any backup,
+not in the checkout, and not something trog-provisioner carries onto a rebuilt
+guest -- so rebuilding the host means every stored secret is gone and each user
+stores theirs again.  That is the intended cost.  Nothing breaks in the meantime:
+a row that will not open says so on /secrets, the reprovision button goes back to
+asking for the passphrase, and no code is spent finding out.
+
+What unlocks a secret is a TOTP code, and a code is spent when it is used -- a
+code authorizes one thing rather than everything you can do in its window.
+That includes logging in, so if you have just logged in you will be waiting for
+the next code.  That is the cost, and it is thirty seconds.
+
+DirIndex is the one to copy if you are writing your own.  Point a series at a
+directory with its "Directory to index" field, build a child type in the wizard
+with DirIndex as its datasource, and every file in there becomes a post carrying
+its name, path, size, mtime, extension and content type -- so a downloads page, a
+gallery or a release listing is a template and nothing else.  It will only index
+directories under www/ -- which the webserver already serves, so a listing
+discloses nothing a guessed URL would not -- and never www/assets/private.
+
+That last is a guard rail rather than a protection: nginx gates those files by
+auth_requesting the /authenticated route, so a listing of them would not hand the
+files out, only the names.  Sharing that directory is operator error, and
+refusing it turns a mistake in a text field into a line in the log.  See the POD
+in lib/Trog/DataSource/DirIndex.pm.
+
+A post type names one in its sidecar with x-tcms-datasource, and a series of that
+type then lists whatever the source builds instead of posts somebody wrote.  The
+series is still an ordinary post; only its children are synthesized, and they are
+rebuilt on every view rather than stored.
+
+A source has to provide posts($series, $query).  It may also provide:
+
+* filter($query, @posts) - apply the reader's search to the posts it built.
+  Those posts have never been near the datastore, so the search the reader typed
+  would otherwise be answered against the datastore and then thrown away along
+  with the posts it filtered.  Trog::DataSource::filter is the default, and
+  searches a post's title and body; implement your own to search the fields your
+  posts actually carry, as Virt does for a guest's name, state and hypervisor.
+* order($query, @posts) - the order they belong in.  Defaults to newest first,
+  then by title, then by id.  Pagination hands out page 2 of an order, so there
+  has to be one and it has to be the same one next time somebody asks.
+* lang() and help() - what the search box on such a page is searching, and where
+  to read about it.  The data model's answer describes the datastore, which is
+  not what these pages are serving.
+* EDITABLE - whether the wizard should generate an editor for the type.  A source
+  building its posts from somewhere else has nothing to edit, and saying nothing
+  means no.
+* CACHEABLE - whether its pages may be saved as static renders.  Saying nothing
+  means no; see below.
+
+Datasource pages would be cached as statics exactly like any other page, which
+raises the question of what throws that cache away -- saving a post will not,
+because no post was saved when somebody dropped a file in a directory.  So a
+source has to say which of the two it is:
+
+* CACHEABLE - it knows what it depends on and says when that changes, so its
+  pages may be cached.  Saying nothing means no, and that is the safe way round:
+  a source whose author has not thought about invalidation gets the answer that
+  is merely slow rather than the one that is wrong.  DirIndex says yes because it
+  watches the directory; Virt says no, because a guest's state is the point of
+  the page and nothing could ever tell us it changed.
+
+A source declaring CACHEABLE should say when it changes, using tPSGI's watch
+facility, as DirIndex does:
+
+    $tpsgi->add_watch( $directory, sub {
+        my ( $watcher, $change ) = @_;
+        $watcher->invalidate_renders('html');
+    }, key => "something stable" );
+
+Pass an explicit key.  posts() runs per request, so a closure built there has a
+new address every time and the default key would stack another copy of the same
+callback on every view.  Use the tPSGI object the callback is handed rather than
+the one from the request that registered it: watches are shared between workers,
+and whichever worker notices the change is the one that has to act on it.
+
+Such pages paginate by page number rather than by the created cursor stored posts
+use.  A datasource has already built every post by the time the paginator sees
+them, so there is nothing to save by paging with a cursor -- and it would not
+work anyway for a source that stamps everything with the time it built them, as
+libvirt guests are: every cursor on the page is the same instant, so Prev asks
+for everything older than now and gets nothing.
+
+See lib/Trog/DataSource.pm for the whole contract.
+
+Components
+==========
+Sometimes you re-use a template a lot. Sometimes it also needs special handling.
+This is when you write a 'component'.  Example:
+
+Trog::Component::EmojiPicker -> renders www/templates/html/components/emojis.tx
+
+A component is a module in the Trog::Component namespace with a render(%args)
+method returning a string.  Templates call it by name:
+
+    <: component('EmojiPicker') :>
+    <: component('Gallery', { album => $post.id, cols => 3 }) :>
+
+The optional hash is flattened into the component's render(); nullary components
+ignore it.  Output comes back marked raw, so no | mark_raw is needed.  Routes
+don't have to know a component exists -- the template asks for what it wants.
+
+The page furniture is built this way: Header, Footer, HtmlTitle, MidTitle,
+TopBar, LeftBar, RightBar, FootBar and CategoryBar are what index.tx is made of,
+and PostHeader/PostFooter are the per-series header and footer posts.tx pulls in.
 
 Ideas to come:
 =============

bin/build_index.pl

@@ -1,17 +1,42 @@
-#!/usr/bin/perl
+#!/usr/bin/env perl
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-use lib 'lib';
+use FindBin::libs;
 use Trog::Data;
 use Trog::Config;
 use Trog::SQLite::TagIndex;
 
-# Use this to build the post index after you import data, otherwise it's not needed
+=head1 SYNOPSIS
 
-my $conf   = Trog::Config::get();
-my $search = Trog::Data->new($conf);
+Rebuild the FlatFile model's tag index and route table, data/posts.db, from the
+posts in data/files.
 
-Trog::SQLite::TagIndex::build_index($search);
-Trog::SQLite::TagIndex::build_routes($search);
+Use this to build the index after you import posts, otherwise it is not needed:
+tCMS keeps the index up to date as it writes posts, so the only time it gets out
+of step with the flat files is when something other than tCMS put them there.
+
+The SQLite model keeps its tags and routes with the posts, and has no separate
+index.  On a site served from it, this says so and changes nothing.
+
+=head2 USAGE
+
+    bin/build_index.pl
+
+Takes no arguments, and must be run from the tCMS root, as the data paths in
+the configuration are relative to it.
+
+Safe to re-run.  It empties the index first and builds it again, in one
+transaction, so tags and routes that no post has any more are gone afterwards.
+
+=cut
+
+my $data = Trog::Data->new( Trog::Config::get() );
+if ( !$data->isa('Trog::Data::FlatFile') ) {
+    say "This site serves from " . ref($data) . ", which has no separate index.  Nothing to do.";
+    exit 0;
+}
+
+Trog::SQLite::TagIndex::rebuild($data);

bin/build_zone

@@ -1,157 +0,0 @@
-#!/usr/bin/env perl
-
-=head1 build_zone
-
-Build the basic zone for a tCMS site and import it into powerdns.
-Otherwise, make it a post so you can edit it in the config backend.
-
-In general this should not be called outside of Installer.mk.
-
-=head2 OPTIONS
-
-=head3 subdomain
-
-Specify a subdomain, such as 'foo' to add to the domain.
-
-May be passed multiple times.
-
-=head3 gsv
-
-Google site verification string goes into TXT record
-
-=head3 cname
-
-Specify a cname, such as 'bar' to add to the domain.
-
-By default, the cnames 'www', 'mail' and 'chat' are set up, as these are essential tCMS services setup by the makefile before this.
-
-May be passed multiple times.
-
-=cut
-
-use strict;
-use warnings;
-
-no warnings qw{experimental};
-use feature qw{signatures state};
-
-use FindBin::libs;
-use Trog::Config();
-use Trog::Zone();
-use Trog::Auth;
-
-use DNS::Unbound;
-use Net::DNS::Packet;
-
-use Text::Xslate;
-use Net::IP;
-
-use Getopt::Long qw{GetOptionsFromArray};
-
-$ENV{NOHUP} = 1;
-
-exit main(@ARGV) unless caller;
-
-sub main(@args) {
-
-    my %options;
-    GetOptionsFromArray(\@args,
-        'subdomain=s@' => \$options{subdomains},
-        'gsv=s'        => \$options{gsv},
-        'cname=s@'     => \$options{cnames},
-    );
-
-    # Paranoia, some versions of getopt don't do this
-    $options{cnames}     //= [];
-    $options{subdomains} //=[];
-
-    my $domain = Trog::Config->get()->param('general.hostname');
-    die "Hostname not set in tCMS configuration.  Please set this first." unless $domain;
-
-    my $user = Trog::Auth::primary_user;
-    die "Primary tCMS user not yet set up" unless $user;
-
-    # Get a flesh start
-    Trog::Zone::delzone($domain);
-
-    my ($ip)  = domain2ips($domain, 'A');
-    my ($ip6) = domain2ips($domain, 'AAAA');
-
-    my $data = {
-        ip  => $ip,
-        ip6 => $ip6,
-        ip_reversed  => Net::IP->new($ip)->reverse_ip(),
-        ip6_reversed => Net::IP->new($ip6)->reverse_ip(),
-        title => $domain,
-        nameservers => ["ns1.$domain"],
-        subdomains  => [map { { name => $_, ip => domain2ips("$_.$domain", "A"), "ip6" => domain2ips("$_.$domain", "AAAA"), nameservers => ["ns1.$_.$domain"] } } @{$options{subdomains}}],
-        cnames      => [(qw{www mail chat},@{$options{cnames}})],
-        gsv_string  => $options{gsv} // '',
-        version    => 0,
-        dkim_pkey => extract_pkey($domain),
-        acme_challenge => get_dns_dcv_string( $domain ),
-        visibility => 'private',
-        acls       => [qw{admin}],
-        aliases    => [],
-        tags       => ['zone'],
-        form       => 'dns.tx',
-        callback   => "Trog::Routes::TXT::zone",
-        id         => undef,
-        created    => undef,
-        local_href => "/text/zone/$domain",
-        href       => "/text/zone/$domain",
-        user       => $user,
-    };
-
-    my $zone = Trog::Zone::addzone($data);
-    print $data->{data};
-
-    return 0;
-}
-
-sub extract_pkey ( $domain ) {
-    open(my $fh, '<', "/etc/opendkim/keys/$domain/mail.public");
-    my @lines = map { chomp $_; $_ } readline $fh;
-    close $fh;
-    shift @lines;
-    pop @lines;
-    return join('', @lines);
-}
-
-sub get_dns_dcv_string( $domain ) {
-    return "TODO";
-}
-
-sub domain2ips( $domain, $type ) {
-    # XXX would be great to use state here, but felipe
-    my $resolver = DNS::Unbound->new();
-
-    my $p = $resolver->resolve( $domain, $type )->answer_packet();
-    my @rrs = Net::DNS::Packet->new( \$p )->answer;
-
-    my @addr = map { $_->address } @rrs;
-    @addr=(get_local_ip($type)) unless @addr;
-    return @addr;
-}
-
-my $addrout='';
-sub get_local_ip( $type ) {
-    $addrout //=qx{ip addr};
-    return $type eq 'A' ? _ipv4() : _ipv6();
-}
-
-sub _ipv4 {
-    state $ip;
-    return $ip if $ip;
-    ($ip) = $addrout =~ m{inet\s+([\d|\.|/]+)\s+scope\s+global}gmx;
-    return $ip;
-}
-
-sub _ipv6 {
-    state $ip6;
-    return $ip6 if $ip6;
-    ($ip6) = $addrout =~ m{inet6\s+([a-f|\d|:|/]+)\s+scope\s+global\s+dynamic\s+mngtmpaddr}gmx;
-    # We have to strip the CIDR off of it, or it breaks Net::IP's brain.
-    $ip6 =~ s|/\d+$||;
-    return $ip6;
-}

bin/favicon_mongler.pl

@@ -1,12 +1,69 @@
-#!/usr/bin/perl
+#!/usr/bin/env perl
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use Cwd            ();
 use File::Basename ();
 use File::Which    ();
-use File::Copy     ();
+use File::Temp     ();
+use List::Util     qw{uniq};
+
+use Imager ();
+
+=head1 SYNOPSIS
+
+Render a favicon SVG out to every size and format a browser might ask for.
+
+=head2 USAGE
+
+    bin/favicon_mongler.pl /path/to/favicon.svg
+
+Writes favicon-<size>.png next to the source SVG for each size below, plus a
+favicon.ico, which is what browsers guess at when a page doesn't tell them
+otherwise.
+
+The PNG sizes are the ones which actually get asked for: 32 and 48 for the tab
+and the desktop shortcut, 167 and 180 for iPads and iPhones, and 192 and 512
+for the web app manifest.  Everything but the .ico is named in either
+components/header.tx or Trog::Routes::JSON::webmanifest, so adding a size here
+means adding it there too, and vice versa.
+
+=head2 CAVEATS
+
+Needs inkscape on the PATH to do the rendering, and dies if it isn't there.
+
+Works with either era of inkscape.  1.0 reworked the command line and renamed
+the export flag from -e to -o, and 1.x rejects -e outright, so the version is
+read off the binary rather than assumed -- see export_flag().
+
+Overwrites whatever is already at those paths without asking.
+
+Note that inkscape only ever exports PNG -- it has no idea what an .ico is.
+Asking it for one, as this script used to, gets you a PNG with the wrong
+extension.  The real container is assembled with Imager afterwards.
+
+=cut
+
+# Inkscape 1.0 reworked the command line: the export flag went from -e to -o,
+# and 1.x errors out on -e rather than quietly accepting it.  Ask the binary
+# which era it belongs to instead of guessing -- this script has already been
+# flipped between the two by hand twice (e23b678, then back in 5f0cdca).
+my sub export_flag ($bin) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate the setup at file scope
+
+    # Shelling out, on purpose and on the record.  system() cannot hand back
+    # what the child printed, and reaching for a pipe open instead would only
+    # be picking the spelling ProhibitShellDispatch happens not to look at --
+    # which is what Troglodyne::ProhibitPipeOpen now exists to stop.  $bin is
+    # quoted because File::Which returns whatever path it found, spaces and all.
+    my $version = qx{"$bin" --version};    ## no critic (logicLAB::ProhibitShellDispatch)
+
+    my ($major) = ( $version // '' ) =~ m/Inkscape\s+(\d+)/;
+    die "Could not read a version out of `$bin --version`, got: " . ( $version // '(nothing)' ) unless defined $major;
+
+    return $major >= 1 ? '-o' : '-e';
+}
 
 die "Usage:\n    favicon_mongler.pl /path/to/favicon.svg" unless $ARGV[0];
 my $icon = Cwd::abs_path( $ARGV[0] );
@@ -14,21 +71,48 @@ my $bin  = File::Which::which('inkscape');
 die "Please install inkscape" if !$bin;
 my $dir = File::Basename::dirname($icon) || die "Can't figure out dir from $icon";
 
-my %files = (
-    32  => 'ico',
-    48  => 'png',
-    167 => 'png',
-    180 => 'png',
-    192 => 'png',
-    512 => 'png',
-);
-foreach my $size ( sort { $b <=> $a } keys(%files) ) {
-    print "*** Generating ${size}x${size} .$files{$size} now... ***\n";
-    my @cmd = ( $bin, '-w', $size, '-h', $size, $icon, '-e', "$dir/favicon-$size.$files{$size}" );
-    system(@cmd) && die "Failed to run @cmd: $!";
-    print "*** Wrote $dir/favicon-$size.$files{$size} ***\n\n";
+my $export = export_flag($bin);
+
+# The sizes the site links to directly.
+my @png_sizes = qw{32 48 167 180 192 512};
+
+# The sizes that go inside favicon.ico.  16 is not linked anywhere on its own,
+# so it only ever exists as a member of the container.
+my @ico_sizes = qw{16 32 48};
+
+# Somewhere to put the sizes we need but don't want to leave lying around.
+my $scratch = File::Temp->newdir();
+
+# Render each size from the vector source rather than downscaling one big
+# raster -- at 16 and 32 pixels the difference is the whole ballgame.
+my %rendered;
+foreach my $size ( reverse sort { $a <=> $b } uniq( @png_sizes, @ico_sizes ) ) {
+    my $keep = grep { $_ == $size } @png_sizes;
+    my $out  = $keep ? "$dir/favicon-$size.png" : "$scratch/favicon-$size.png";
+
+    print "*** Generating ${size}x${size} .png now... ***\n";
+    my @cmd = ( $bin, '-w', $size, '-h', $size, $icon, $export, $out );
+
+    # There is no maintained Perl SVG rasterizer to bind instead -- Imager has
+    # no SVG reader, and Image::LibRSVG was last released in 2006 -- so driving
+    # the renderer as a subprocess is the only option here.
+    system(@cmd) and die "Failed to run @cmd: " . ( $? == -1 ? $! : 'exit status ' . ( $? >> 8 ) );    ## no critic (logicLAB::ProhibitShellDispatch)
+    print "*** Wrote $out ***\n\n";
+
+    $rendered{$size} = $out;
 }
 
-File::Copy::copy( "$dir/favicon-32.ico", "$dir/favicon.ico" );
+# An .ico is a container of several images, and browsers do pick the size they
+# want out of it, so give them all three rather than one scaled at display time.
+print "*** Generating favicon.ico (@{[ join 'x, ', @ico_sizes ]}x) now... ***\n";
+my @members = map {
+    my $img = Imager->new;
+    $img->read( file => $rendered{$_} ) or die "Could not read $rendered{$_}: " . $img->errstr;
+    $img;
+} @ico_sizes;
+
+Imager->write_multi( { file => "$dir/favicon.ico", type => 'ico' }, @members )
+  or die "Could not write $dir/favicon.ico: " . Imager->errstr;
+print "*** Wrote $dir/favicon.ico ***\n";
 
 0;

bin/migrate.pl

@@ -1,218 +1,195 @@
-#!/usr/bin/perl
+#!/usr/bin/env perl
 
-#Migrate tCMS1 data to tCMS2 flat file data model
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-use strict;
-use warnings;
+use FindBin::libs;
 
-use JSON::MaybeXS;
-use File::Slurper();
-use HTML::Parser;
-use UUID::Tiny ':std';
-use File::Copy;
-use DateTime;
+use Getopt::Long qw{GetOptions};
+use Time::HiRes  ();
 
-#Edit this to be whatever you need it to be
-my $docroot = "/var/www/teodesian.net/doc";
+use Trog::Config;
+use Trog::Data::FlatFile;
+use Trog::Data::SQLite;
 
-my $dir = "/var/www/teodesian.net/doc/microblog/";
+=head1 SYNOPSIS
 
-opendir( my $dh, $dir ) or die;
-my @days = grep { !/^\./ } readdir $dh;
-closedir $dh;
+Move a site from the FlatFile data model to the SQLite one.
 
-my $ring = JSON::MaybeXS->new();
-foreach my $day (@days) {
+=head2 USAGE
 
-    opendir( my $dht, "$dir/$day" ) or die;
-    my @times = grep { !/^\./ } readdir $dht;
-    closedir $dht;
+    bin/migrate.pl [--dry-run] [--batch N] [--quiet]
 
-    my ( $month, $date, $year ) = split( /\./, $day );
+Must be run from the tCMS root, as the data paths are relative to it.
 
-    foreach my $time (@times) {
+    --dry-run   Say what would be carried over, and write nothing.
+    --batch N   Posts per transaction.  Default 500.
+    --quiet     Only complain; say nothing on success.
 
-        my ( $hour, $min, $sec ) = split( /:/, $time );
+=head2 WHAT IT DOES
 
-        my $data;
-        my $file = "$dir/$day/$time";
+Reads every version of every post out of data/files and writes them into
+data/posts.sqlite, oldest version first, so that the version bookkeeping ends up
+the way it would have if the posts had been written there all along.
 
-        print "Migrate $file\n";
-        eval {
-            my $content = File::Slurper::read_text($file);
-            $data = $ring->decode($content);
-            $data = json_remap($data);
-        };
-        $data = html_post($file) unless $data;
+Nothing is deleted.  data/files is left exactly as it found it, and so is the
+flat file model's tag index in data/posts.db, so the way back is to put
+data_model back to FlatFile.
 
-        my $dt = DateTime->new(
-            year   => $year + 2000,
-            month  => $month,
-            day    => $date,
-            hour   => $hour,
-            minute => $min,
-            second => $sec,
-        );
-        $data->{created} = $dt->epoch();
+Safe to re-run.  Post versions already carried over are skipped rather than
+duplicated, which also makes it safe to run once against a live site and again
+after a final quiet period to pick up whatever was written in between.
 
-        $data->{id}      = $data->{created};
-        $data->{tags}    = [ 'public', 'news' ];
-        $data->{version} = 0;
+When it has finished, switch the site over in config/main.cfg:
 
-        open( my $fh, '>', "data/files/$data->{created}" ) or die;
-        print $fh encode_json( [$data] );
-        close $fh;
-    }
+    [general]
+        data_model=SQLite
+
+...and restart, so the workers build the new model rather than the old one.
+
+=head2 TERMINATION CONDITIONS
+
+Exits non-zero if any post could not be carried over, having written everything
+it could.  Each batch is a transaction, so a batch that fails is not half
+applied, and re-running picks up from what actually landed.
+
+=cut
+
+# So that progress and complaints interleave in the order they happened when
+# this is piped to a log rather than watched.
+STDOUT->autoflush(1);
+STDERR->autoflush(1);
+
+my $usage = "Usage: bin/migrate.pl [--dry-run] [--batch N] [--quiet]\n";
+
+# Printed and exited rather than died, so that a usage error exits 2.
+sub usage_error (@complaint) {
+    print {*STDERR} @complaint, $usage;    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+    exit 2;
 }
 
-# Migrate blog posts
-$dir = "$docroot/blog";
-
-opendir( my $bh, $dir ) or die;
-my @blogs = grep { -f "$dir/$_" } readdir $bh;
-closedir $bh;
-
-my $offset = 0;
-
-foreach my $post (
-    sort {
-        my $anum = $a =~ m/^(\d*)-/;
-        my $bnum = $b =~ m/^(\d*)-/;
-        $b <=> $a
-    } @blogs
-) {
-    my $postname = $post;
-    $postname =~ s/^\d*-//g;
-    $postname =~ s/\.post$//g;
-    my $content = File::Slurper::read_text("$dir/$post");
-
-    my $data = {
-        title => $postname,
-        data  => $content,
-        tags  => [ 'blog', 'public' ],
-    };
+my ( $dry_run, $quiet, $batch_size ) = ( 0, 0, 500 );
+GetOptions(
+    'dry-run' => \$dry_run,
+    'quiet'   => \$quiet,
+    'batch=i' => \$batch_size,
+) or usage_error();
+
+usage_error("--batch must be a positive number of posts.\n") if $batch_size < 1;
 
-    my ( undef, undef, undef, undef, $uid, undef, undef, undef, undef, $ctime ) = stat("$dir/$post");
-    my $user = lc( getpwuid($uid) );
-    $user = scalar( grep { $user eq $_ } qw{/sbin/nologin www-data} ) ? 'nobody' : $user;
-    $data->{user} = $user;
-    $ctime += $offset;
-    $data->{created} = $ctime;
-    $data->{id}      = $ctime;
-    $data->{href}    = "/blog/$ctime";
-    $data->{version} = 0;
-
-    print "Migrate blog post '$post'\n";
-    open( my $fh, '>', "data/files/$data->{created}" ) or die;
-    print $fh encode_json( [$data] );
-    close $fh;
-
-    $offset--;
+sub say_unless_quiet (@args) {
+    return if $quiet;
+    say @args;
+    return;
 }
-exit 0;
-my $vdir = "$docroot/fileshare/video";
-opendir( my $vh, $vdir ) or die;
-my @vidyas = grep { -f "$vdir/$_" && $_ =~ m/\.m4v$/ } readdir $vh;
-closedir $vh;
-
-foreach my $vid (@vidyas) {
-    my $postname = $vid;
-    $postname =~ s/_/ /g;
-    $postname =~ s/\.mv4$//g;
-
-    my $data = {
-        title   => $postname,
-        data    => "Description forthcoming",
-        tags    => [ 'video', 'public' ],
-        preview => "/img/sys/testpattern.jpg",
-    };
 
-    my ( undef, undef, undef, undef, $uid, undef, undef, undef, undef, $ctime ) = stat("$vdir/$vid");
-    my $user = lc( getpwuid($uid) );
-    $user            = scalar( grep { $user eq $_ } qw{/sbin/nologin www-data} ) ? 'nobody' : $user;
-    $data->{user}    = $user;
-    $data->{created} = $ctime;
-    $data->{id}      = $ctime;
-    $data->{href}    = "/assets/$ctime-$vid";
-    $data->{version} = 0;
-
-    #Copy over the video
-    File::Copy::copy( "$vdir/$vid", "www/assets/$ctime-$vid" );
-
-    print "Migrate video '$vid'\n";
-    open( my $fh, '>', "data/files/$data->{created}" ) or die;
-    print $fh encode_json( [$data] );
-    close $fh;
+my $config = Trog::Config::get();
+my $from   = Trog::Data::FlatFile->new($config);
+my $to     = Trog::Data::SQLite->new($config);
+
+# raw, so we get the history rather than only the current version of each post,
+# and so that no acl filtering stands between a migration and the data it is
+# supposed to be moving.
+my $started = [ Time::HiRes::gettimeofday() ];
+my @posts   = $from->get( raw => 1, limit => 0 );
+if ( !@posts ) {
+    print {*STDERR} "No posts found in data/files -- is this a tCMS root, and is it on the FlatFile model?\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+    exit 2;
 }
 
-sub json_remap {
-    my $json = shift;
-
-    return {
-        preview    => $json->{"image"},
-        data       => $json->{"comment"},
-        user       => lc( $json->{"poster"} ),
-        title      => $json->{"title"},
-        audio_href => $json->{"audio"},
-        href       => $json->{"url"},
-        video_href => $json->{"video"},
+# Oldest first: write() appends, and the version bookkeeping is maintained as it
+# goes, so feeding it in order is what makes first_id and latest_id right.
+@posts = sort { ( $a->{id} // '' ) cmp ( $b->{id} // '' ) || ( $a->{version} // 0 ) <=> ( $b->{version} // 0 ) } @posts;
+
+# One query rather than one per post.
+my $present = $to->versions_present();
+
+# Separately: an array in a list assignment swallows everything after it.
+my @batch;
+my ( $written, $skipped, $failed ) = ( 0, 0, 0 );
+
+sub flush_batch () {
+    return unless @batch;
+
+    if ($dry_run) {
+        $written += scalar(@batch);
+        @batch = ();
+        return;
+    }
+
+    local $@;
+    eval {
+        $to->write( \@batch );
+        $written += scalar(@batch);
+        1;
+    } or do {
+        my $error = $@;
+        $error =~ s/\n.*//s;
+
+        # A batch is one transaction, so one bad post took every other post in
+        # the batch down with it.  Go back over them one at a time: a migration
+        # wants everything that can land to land, and a list naming exactly what
+        # could not -- not five hundred posts rejected on account of one.
+        print {*STDERR} "A batch of " . scalar(@batch) . " failed ($error); retrying it one post at a time.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+
+        foreach my $post (@batch) {
+            local $@;
+            eval {
+                $to->write( [$post] );
+                $written++;
+                1;
+            } or do {
+                my $why = $@;
+                $why =~ s/\n.*//s;
+                $failed++;
+                print {*STDERR} "  could not write $post->{id} version " . ( $post->{version} // 0 ) . ": $why\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+            };
+        }
     };
+
+    @batch = ();
+    return;
+}
+
+foreach my $post (@posts) {
+    if ( !$post->{id} ) {
+        print {*STDERR} "Skipping a post with no id, which is not something this can carry over\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+        $failed++;
+        next;
+    }
+
+    if ( $present->{ $post->{id} }{ $post->{version} // 0 } ) {
+        $skipped++;
+        next;
+    }
+
+    push( @batch, $post );
+    flush_batch() if @batch >= $batch_size;
+}
+flush_batch();
+
+my $elapsed = Time::HiRes::tv_interval($started);
+
+if ($dry_run) {
+    say_unless_quiet( sprintf( "Would carry over %d post version(s); %d already present.", $written, $skipped ) );
+    say_unless_quiet("Nothing was written.  Re-run without --dry-run to do it.");
+    exit( $failed ? 1 : 0 );
 }
 
-sub html_post {
-    my $file          = shift;
-    my $is_first_link = 1;
-    my $data          = { data => '', href => '' };
-
-    my $p = HTML::Parser->new(
-        handlers => [
-            start => [
-                sub {
-                    my ( $self, $attr, $text, $tagname ) = @_;
-                    if ( $tagname eq 'a' && $is_first_link ) {
-                        $data->{href} = $attr->{href};
-                        return;
-                    }
-                    return if $is_first_link;
-                    return if $tagname eq 'hr';
-                    $data->{data} .= $text;
-                },
-                'self, attr, text,tagname'
-            ],
-            text => [
-                sub {
-                    my ( $self, $attr, $text, $tagname ) = @_;
-                    if ($is_first_link) {
-                        $data->{title} .= $text;
-                        return;
-                    }
-                    $data->{data} .= $text;
-                },
-                'self, attr, text,tagname'
-            ],
-            end => [
-                sub {
-                    my ( $self, $attr, $text, $tagname ) = @_;
-                    if ( $tagname eq 'a' && $is_first_link ) {
-                        $is_first_link = 0;
-                        return;
-                    }
-                    return if $is_first_link;
-                    $data->{data} .= $text;
-                },
-                'self, attr, text,tagname'
-            ],
-        ],
-    );
-    $p->parse_file($file);
-
-    #Get the user name from ownership
-    my ( undef, undef, undef, undef, $uid, undef, undef, undef, undef, $ctime ) = stat($file);
-    my $user = lc( getpwuid($uid) );
-    $user = scalar( grep { $user eq $_ } qw{/sbin/nologin www-data} ) ? 'nobody' : $user;
-    $data->{user} = $user;
-
-    $data->{created} = $ctime;
-
-    return $data;
+# Worth stating plainly rather than trusting the counters: they say what this
+# thought it did, and the databases say what is actually there.
+my $expected = scalar( grep { $_->{id} } @posts );
+my $have     = 0;
+$have += scalar( keys %$_ ) foreach values %{ $to->versions_present() };
+
+say_unless_quiet( sprintf( "Carried over %d post version(s), skipped %d already present, in %.1fs.", $written, $skipped, $elapsed ) );
+say_unless_quiet( sprintf( "data/files holds %d post version(s); data/posts.sqlite now holds %d.", $expected, $have ) );
+
+if ( $failed || $have < $expected ) {
+    print {*STDERR} sprintf( "%d post version(s) did not make it across.  Fix what the errors above name and re-run; what landed will be skipped.\n", $failed || ( $expected - $have ) );    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+    exit 1;
 }
+
+say_unless_quiet("Set general.data_model to SQLite in config/main.cfg and restart to serve from it.");
+exit 0;

bin/migrate2.pl

@@ -1,150 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-# Migrate early on tcms3 flatfile sites to 'all posts are series code' (august 2021) code
-
-use FindBin;
-
-use lib "$FindBin::Bin/../lib";
-
-use Trog::Config;
-use Trog::Data;
-use List::Util;
-use UUID::Tiny;
-
-use Trog::SQLite;
-use Trog::SQLite::TagIndex;
-
-# Kill the post index
-unlink "$FindBin::Bin/../data/posts.db";
-$ENV{NOHUP} = 1;
-
-sub uuid { return UUID::Tiny::create_uuid_as_string( UUID::Tiny::UUID_V1, UUID::Tiny::UUID_NS_DNS ); }
-
-# Modify these variables to suit your installation.
-my $user         = 'george';
-my @extra_series = ();
-
-my $conf        = Trog::Config::get();
-my $search_info = Trog::Data->new($conf);
-
-my @all = $search_info->get( raw => 1, limit => 0 );
-
-my %posts;
-foreach my $post (@all) {
-    $posts{ $post->{id} } //= [];
-
-    # Re-do the IDs
-    push( @{ $posts{ $post->{id} } }, $post );
-}
-
-foreach my $timestamp ( keys(%posts) ) {
-    my $file_to_kill = "$FindBin::Bin/../data/files/$timestamp";
-    my $new_id       = uuid();
-
-    # Preserve old URLs
-    foreach my $post ( @{ $posts{$timestamp} } ) {
-        delete $post->{app};
-        delete $post->{preview_file};
-        delete $post->{wallpaper_file};
-
-        delete $post->{scheme};
-        delete $post->{route};
-        delete $post->{domain};
-
-        $post->{id}         = $new_id;
-        $post->{local_href} = "/posts/$new_id";
-        $post->{aliases}    = ["/posts/$timestamp"];
-        $post->{callback}   = "Trog::Routes::HTML::posts";
-        $post->{method}     = 'GET';
-        @{ $post->{tags} } = grep { defined $_ } @{ $post->{tags} };
-
-        $post->{content_type} //= 'text/html';
-        $post->{form} = 'microblog.tx';
-        $post->{form} = 'blog.tx' if grep { $_ eq 'blog' } @{ $post->{tags} };
-        $post->{form} = 'file.tx' if $post->{content_type} =~ m/^video\//;
-        $post->{form} = 'file.tx' if $post->{content_type} =~ m/^audio\//;
-        $post->{form} = 'file.tx' if $post->{content_type} =~ m/^image\//;
-        if ( grep { $_ eq 'about' } @{ $post->{tags} } ) {
-            $post->{form}       = 'profile.tx';
-            $post->{local_href} = "/users/$post->{user}";
-            $post->{callback}   = "Trog::Routes::HTML::users";
-        }
-        if ( grep { $_ eq 'series' } @{ $post->{tags} } ) {
-            $post->{form}       = 'series.tx';
-            $post->{callback}   = "Trog::Routes::HTML::series";
-            $post->{child_form} = 'microblog.tx';
-            $post->{child_form} = 'blog.tx' if $post->{title} =~ m/^blog/i;
-            $post->{child_form} = 'file.tx' if $post->{title} =~ m/^video\//;
-            $post->{child_form} = 'file.tx' if $post->{title} =~ m/^audio\//;
-            $post->{child_form} = 'file.tx' if $post->{title} =~ m/^image\//;
-            $post->{local_href} = "/$post->{aclname}";
-            $post->{aliases}    = [ "/series/$timestamp", "/series/$new_id" ];
-        }
-
-        $search_info->write( [$post] );
-        unlink $file_to_kill if -f $file_to_kill;
-    }
-}
-
-# Rebuild the index
-Trog::SQLite::TagIndex::build_index($search_info);
-Trog::SQLite::TagIndex::build_routes($search_info);
-
-# Add in the series
-my $series = [
-    {
-        "aclname"    => "series",
-        "acls"       => [],
-        aliases      => [],
-        "callback"   => "Trog::Routes::HTML::series",
-        method       => 'GET',
-        "data"       => "Series",
-        "href"       => "/series",
-        "local_href" => "/series",
-        "preview"    => "/img/sys/testpattern.jpg",
-        "tags"       => [qw{series topbar}],
-        visibility   => 'public',
-        "title"      => "Series",
-        user         => $user,
-        form         => 'series.tx',
-        child_form   => 'series.tx',
-    },
-    {
-        "aclname"    => "about",
-        "acls"       => [],
-        aliases      => [],
-        "callback"   => "Trog::Routes::HTML::series",
-        method       => 'GET',
-        "data"       => "About",
-        "href"       => "/about",
-        "local_href" => "/about",
-        "preview"    => "/img/sys/testpattern.jpg",
-        "tags"       => [qw{series topbar public}],
-        visibility   => 'public',
-        "title"      => "About",
-        user         => $user,
-        form         => 'series.tx',
-        child_form   => 'profile.tx',
-    },
-    {
-        "aclname"      => "admin",
-        acls           => [],
-        aliases        => [],
-        "callback"     => "Trog::Routes::HTML::config",
-        'method'       => 'GET',
-        "content_type" => "text/plain",
-        "data"         => "Config",
-        "href"         => "/config",
-        "local_href"   => "/config",
-        "preview"      => "/img/sys/testpattern.jpg",
-        "tags"         => [qw{admin}],
-        visibility     => 'private',
-        "title"        => "Configure tCMS",
-        user           => $user,
-    },
-];
-
-$search_info->add( @$series, @extra_series );

bin/migrate3.pl

@@ -1,73 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-# Migrate early on tcms3 flatfile sites to store rather than compute much data (dec 2021) code
-
-use FindBin;
-
-use lib "$FindBin::Bin/../lib";
-
-use Trog::Config;
-use Trog::Data;
-use List::Util;
-use UUID::Tiny;
-
-use Trog::SQLite;
-use Trog::SQLite::TagIndex;
-
-# Kill the post index
-unlink "$FindBin::Bin/../data/posts.db";
-$ENV{NOHUP} = 1;
-
-sub uuid { return UUID::Tiny::create_uuid_as_string( UUID::Tiny::UUID_V1, UUID::Tiny::UUID_NS_DNS ); }
-
-# Modify these variables to suit your installation.
-my $user         = 'george';
-my @extra_series = ();
-
-my $conf        = Trog::Config::get();
-my $search_info = Trog::Data->new($conf);
-
-my @all = $search_info->get( raw => 1, limit => 0 );
-foreach my $post (@all) {
-    if ( defined $post->{form} && $post->{form} eq 'series.tx' ) {
-        $post->{tiled} = scalar( grep { $_ eq $post->{local_href} } qw{/files /audio /video /image /series /about} );
-    }
-    if ( !defined $post->{visibility} ) {
-        $post->{visibility} = 'public'   if grep { $_ eq 'public' } @{ $post->{tags} };
-        $post->{visibility} = 'private'  if grep { $_ eq 'private' } @{ $post->{tags} };
-        $post->{visibility} = 'unlisted' if grep { $_ eq 'unlisted' } @{ $post->{tags} };
-    }
-
-    # Otherwise re-save the posts with is_video etc
-    $search_info->add($post);
-}
-
-# Rebuild the index
-Trog::SQLite::TagIndex::build_index($search_info);
-Trog::SQLite::TagIndex::build_routes($search_info);
-
-# Add in the series
-my $series = [
-    {
-        "acls"       => [],
-        aliases      => [],
-        "callback"   => "Trog::Routes::HTML::posts",
-        method       => 'GET',
-        "data"       => "All Posts",
-        "href"       => "/posts",
-        "local_href" => "/posts",
-        "preview"    => "/img/sys/testpattern.jpg",
-        "tags"       => [qw{series}],
-        visibility   => 'unlisted',
-        "title"      => "All Posts",
-        user         => $user,
-        form         => 'series.tx',
-        child_form   => 'series.tx',
-        aclname      => 'posts',
-    },
-];
-
-#$search_info->add(@$series,@extra_series);

bin/migrate4.pl

@@ -1,22 +0,0 @@
-#!/usr/bin/env perl
-
-# Migrate to 2FA
-
-use strict;
-use warnings;
-
-use FindBin;
-
-use lib "$FindBin::Bin/../lib";
-
-use Trog::SQLite;
-
-sub _dbh {
-    my $file   = 'schema/auth.schema';
-    my $dbname = "config/auth.db";
-    return Trog::SQLite::dbh( $file, $dbname );
-}
-
-my $dbh = _dbh();
-
-$dbh->do("ALTER TABLE user ADD COLUMN totp_secret TEXT DEFAULT NULL;");

bin/migrate5.pl

@@ -1,22 +0,0 @@
-#!/usr/bin/env perl
-
-# Password reset code
-
-use strict;
-use warnings;
-
-use FindBin;
-
-use lib "$FindBin::Bin/../lib";
-
-use Trog::SQLite;
-
-sub _dbh {
-    my $file   = 'schema/auth.schema';
-    my $dbname = "config/auth.db";
-    return Trog::SQLite::dbh( $file, $dbname );
-}
-
-my $dbh = _dbh();
-
-$dbh->do("ALTER TABLE user ADD COLUMN contact_email TEXT DEFAULT NULL;");

bin/migrate6.pl

@@ -1,60 +0,0 @@
-#!/usr/bin/env perl
-
-# Display names
-
-use strict;
-use warnings;
-
-use FindBin;
-
-use lib "$FindBin::Bin/../lib";
-
-use Trog::SQLite;
-
-sub _dbh {
-    my $file   = 'schema/auth.schema';
-    my $dbname = "config/auth.db";
-    return Trog::SQLite::dbh( $file, $dbname );
-}
-
-my $dbh = _dbh();
-
-$dbh->do("ALTER TABLE user ADD COLUMN display_name TEXT DEFAULT NULL;");
-
-# Update all the profile type posts to have correct display names
-use Trog::Auth;
-use JSON::MaybeXS;
-use File::Slurper;
-use URI::Escape;
-use Data::Dumper;
-
-my $global_changes;
-opendir( my $dh, 'data/files' );
-while ( my $entry = readdir $dh ) {
-    my $fname = "data/files/$entry";
-    next unless -f $fname;
-    my $contents = File::Slurper::read_binary($fname);
-    my $decoded  = JSON::MaybeXS::decode_json($contents);
-    next unless List::Util::any { $_->{is_profile} } @$decoded;
-
-    # If the title on the profile post responsds to a username, then let's change that to a display name
-    my $made_changes;
-    foreach my $revision (@$decoded) {
-        my $user         = $revision->{title};
-        my $display_name = Trog::Auth::username2display($user);
-        next unless $display_name;
-        print "converting $user to display name $display_name\n";
-        $revision->{title}      = $display_name;
-        $revision->{local_href} = "/users/$display_name";
-        $made_changes           = 1;
-    }
-    next unless $made_changes;
-
-    print "Writing changes to $fname\n";
-    my $encoded = JSON::MaybeXS::encode_json($decoded);
-    File::Slurper::write_binary( $fname, $encoded );
-
-    # Next, waste and rebuild the posts index for these user posts
-    $global_changes = 1;
-}
-print "Changes made.  Please rebuild the posts index.\n" if $global_changes;

bin/reset_install

@@ -5,5 +5,6 @@ rm config/has_users
 rm config/main.cfg
 rm config/setup
 rm data/posts.db
+rm -rf www/assets/private
 rm www/assets/*
 rm data/files/*

bin/tcms-hostname

@@ -1,21 +1,75 @@
 #!/usr/bin/env perl
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use FindBin::libs;
 
 use Trog::Config();
+use Getopt::Long qw{GetOptionsFromArray};
+
+=head1 SYNOPSIS
+
+Get, or set, the hostname this tCMS instance serves.
+
+Everything which needs to know the site's domain -- TOTP enrollment, the DNS
+zone, generated URLs -- reads it out of the configuration, so this is where it
+gets put there in the first place.
+
+=head2 USAGE
+
+    bin/tcms-hostname                  # print the configured hostname
+    bin/tcms-hostname example.com      # set it, then print it
+    bin/tcms-hostname --user           # print it as a valid username
+
+=head2 OPTIONS
+
+=over 4
+
+=item --user
+
+Print the hostname mangled into something usable as a system username: dots
+become dashes, and it's truncated to 32 characters.  Does not change what is
+stored in the configuration.
+
+=back
+
+=head2 CAVEATS
+
+Writes to $Trog::Config::home_cfg rather than saving over whatever get()
+loaded, as that is the tracked config/default.cfg until the instance has a
+configuration of its own.
+
+Dies if asked to print a hostname which was never set.
+
+=cut
+
+my $user;
+GetOptionsFromArray(
+    \@ARGV,
+    'user' => \$user,
+);
 
 my $hostname = $ARGV[0];
 
 my $conf = Trog::Config->get();
 if ($hostname) {
-    $conf->param('general.hostname', $hostname);
-    $conf->save();
+    $conf->param( 'general.hostname', $hostname );
+
+    # write(), not save().  save() writes back to whatever file get() loaded,
+    # which is the tracked config/default.cfg until the instance has saved a
+    # configuration of its own.
+    $conf->write($Trog::Config::home_cfg) or die "Could not write $Trog::Config::home_cfg";
 }
 
 my $domain = $conf->param('general.hostname');
 die "Hostname not set in tCMS configuration.  Please set this first by passing the hostname to bin/tcms-hostname." unless $domain;
 
+# Transform the domain name into something maximally compatible with being a username.
+if ($user) {
+    $domain = substr( $domain, 0, 32 );
+    $domain =~ s/\./-/g;
+}
+
 print "$domain\n";

bin/tcms-useradd

@@ -2,27 +2,30 @@
 
 package tcms::useradd;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use FindBin::libs;
 use Getopt::Long;
 use Pod::Usage;
+use IO::Prompter();
 use List::Util qw{first};
 
 use Trog::Auth;
+use Trog::Log;
 use Trog::Data;
 use Trog::Config;
-use Trog::Log;
-
-# Don't murder our terminal when done
-$ENV{NOHUP} = 1;
 
 =head1 SYNOPSIS
 
-Add or edit a tCMS user.  In the event of a user edit, every option save for user is optional.
+Add or edit a tCMS user.  In the event of a user edit, every option save for user is optional,
+and the ones you leave out keep whatever value they already had.
+
+Creating a user who does not exist yet needs --password, --display_name and --contact_email,
+as there is no existing profile post to inherit them from.
 
-does not update user pages.  Use this to reset user passwords or fix broken users.
+Use this to reset user passwords or fix broken users.
 
 =head2 USAGE
 
@@ -38,7 +41,20 @@ Specify the user to add, or edit if the user already exists.
 
 =item --password
 
-Set a password for the user.  Leave blank if you want to keep the password for an existing user.
+Set a password for the user.  Omit the option entirely if you want to keep the
+password an existing user already has.
+
+Passing --password with no value prompts for one instead, with echo off, which
+keeps it out of your shell history and off your screen:
+
+    tcms-useradd --user foo --password           # prompts, twice, to confirm
+
+It can also be piped in, in which case it is read once and not confirmed:
+
+    echo hunter2 | tcms-useradd --user foo --password
+
+Note that setting a password kills any session the user currently holds, so
+they will have to log back in.
 
 =item --display_name
 
@@ -61,49 +77,126 @@ Display this output.
 
 =cut
 
-sub main {
-    Trog::Log::log_init();
+# Read a password off the terminal without echoing it, so it stays out of the
+# shell history and off the screen.  Falls back to a plain read when we aren't
+# on a TTY, which is what makes `echo hunter2 | tcms-useradd ...` work.  Returns
+# undef only at the end of the input, and q{} for an empty line.
+my sub read_password ($prompt) {
+    my $password = IO::Prompter::prompt( $prompt, -echo => q{}, -in => *STDIN, -out => *STDERR );
+    return $password ? "$password" : undef;
+}
 
+# What a brand new user's profile post looks like before we merge anything over
+# the top of it.  Mirrors what setup() builds for the very first user.
+my sub default_user_post {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate main()
+    return {
+        data       => 'Default user',
+        preview    => '/img/avatar/humm.gif',
+        wallpaper  => '/img/sys/testpattern.jpg',
+        tags       => ['about'],
+        visibility => 'public',
+        acls       => ['admin'],
+        callback   => 'Trog::Routes::HTML::users',
+        method     => 'GET',
+        form       => 'profile.tx',
+        aliases    => [],
+    };
+}
+
+sub main (@args) {
     my %options;
     Getopt::Long::GetOptionsFromArray(
-        \@_,
+        \@args,
         'user=s'          => \$options{user},
         'display_name=s'  => \$options{display_name},
         'help|?'          => \$options{help},
-        'password=s'      => \$options{password},
+        'password:s'      => \$options{password},
         'contact_email=s' => \$options{contact_email},
         'acl=s@'          => \$options{acl},
     );
     pod2usage( -exitval => 0, -verbose => 1 ) if $options{help};
 
+    unless ( $options{user} ) {
+        print {*STDERR} "--user is required.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+        return 2;
+    }
+
+    # --password with no value means "ask me", as opposed to leaving the option
+    # out entirely, which means "leave the password alone".
+    if ( defined $options{password} && !$options{password} ) {
+        $options{password} = read_password("New password for '$options{user}': ");
+
+        unless ( $options{password} ) {
+            print {*STDERR} "No password provided.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+            return 2;
+        }
+
+        # A person at a terminal always enters a line, even an empty one, so
+        # they always confirm.  Piped input with one line has no second line,
+        # and there is nothing to confirm against.
+        my $again = read_password("Confirm: ");
+        if ( defined $again && $options{password} ne $again ) {
+            print {*STDERR} "Passwords did not match.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+            return 2;
+        }
+    }
+
     $options{acl} //= [];
     $options{acl} = [ $options{acl} ] if $options{acl} && ref $options{acl} ne 'ARRAY';
     $options{acl} = ['admin'] unless @{ $options{acl} };
 
-    Trog::Auth::killsession( $options{user} );
-    eval { Trog::Auth::useradd( $options{user}, $options{display_name}, $options{password}, $options{acl}, $options{contact_email} ) } or do {
-        return 1;
-    };
+    # Log to the file the server writes, as the user this run adds or edits.
+    Trog::Log::log_init( 'logs/tcms.log', 'info' );
+    $Trog::Log::user = $options{user} // 'nobody';
 
-    # Find the user's post and edit it
+    # Find the user's existing post, if they have one.
     my $conf = Trog::Config::get();
     my $data = Trog::Data->new($conf);
 
     my @userposts = $data->get( tags => ['about'], acls => [qw{admin}] );
     my $user_obj  = first { ( $_->{user} || '' ) eq $options{user} } @userposts;
-    my %merged    = (
+
+    # A user we've never seen before has no post to edit, so start from the
+    # defaults rather than dereferencing undef.
+    my $is_new = !$user_obj;
+    $user_obj //= default_user_post();
+
+    if ($is_new) {
+        unless ( $options{password} && $options{display_name} && $options{contact_email} ) {
+            print {*STDERR} "User '$options{user}' does not exist yet.\nCreating one needs --password, --display_name and --contact_email.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+            return 2;
+        }
+    }
+
+    # Only the options actually passed should win.  Merging %options wholesale
+    # writes an undef over every field the caller didn't mention, which is how
+    # resetting a password used to blank out the display name and contact email.
+    my %provided = map { $_ => $options{$_} } grep { defined $options{$_} } qw{user display_name contact_email};
+
+    my %merged = (
         %$user_obj,
-        %options,
-        $options{display_name} ? ( local_href => "/users/$options{display_name}" ) : ( local_href => $user_obj->{local_href} ),
+        %provided,
     );
 
-    # We don't want the password in plain text
-    delete $merged{password};
+    # The display name is the title of the post, and the URL it lives at.
+    $merged{title}      = $merged{display_name}          if $merged{display_name};
+    $merged{local_href} = "/users/$merged{display_name}" if $merged{display_name};
 
-    # The ACLs a user posesses is not necessarily what ACLs you need to view or edit a user's profile.
-    delete $merged{acl};
+    Trog::Auth::killsession( $options{user} );
+
+    local $@;
+    eval { Trog::Auth::useradd( $options{user}, $merged{display_name}, $options{password}, $options{acl}, $merged{contact_email} ); 1 } or do {
+        print {*STDERR} "Could not add user '$options{user}': $@";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+        return 1;
+    };
+
+    eval { $data->add( \%merged ); 1 } or do {
+        my @errors = ref $@ eq 'ARRAY' ? @{$@} : ($@);
+        print {*STDERR} "Saved the credentials for '$options{user}', but their profile post was rejected:\n" . join( "\n", @errors ) . "\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+        return 1;
+    };
 
-    $data->add( \%merged );
+    print "@{[ $is_new ? 'Added' : 'Updated' ]} user '$options{user}'.\n";
     return 0;
 }
 

bin/tcms-vault-key

@@ -0,0 +1,105 @@
+#!/usr/bin/env perl
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin::libs;
+
+use Crypt::Misc  ();
+use Crypt::PRNG  ();
+use Fcntl        qw{O_CREAT O_EXCL O_WRONLY};
+use Getopt::Long qw{GetOptions};
+
+use Trog::Vault ();
+
+=head1 SYNOPSIS
+
+Write a vault key into config/secrets.key, for a tCMS that is not being handed
+one by the service that starts it.
+
+=head2 USAGE
+
+    bin/tcms-vault-key --file
+
+=head2 WHEN YOU WANT THIS
+
+Developing, mostly.  Running tPSGI by hand -- HOME=. bin/tpsgi -p 5001, in a
+tmux, so you can watch it and restart it -- is the ordinary way to work on tCMS,
+and nothing in that path hands over a vault key: there is no unit importing a
+systemd credential, and service/tpsgi.sh, which is what would have put it in the
+environment, never ran.  So /secrets does not work until you put a key where
+Trog::Vault can find one, and this is how.
+
+The other time is a machine with no systemd at all, and there it is a compromise
+rather than a convenience.
+
+=head2 WHEN YOU DO NOT
+
+On a production host.  tPSGI's bin/build_service makes the key and puts it in
+systemd's credential store, sealed to this machine if it has a TPM to seal it to,
+and its unit hands it to tCMS before it chroots -- so the key is never on a disk
+that tCMS can see, and never in a backup of tCMS.
+
+A key file in the checkout gives up exactly that.  It sits next to the database
+it protects, so whatever copies one copies the other, and the encryption stops
+being worth anything the moment both are somewhere they should not be.
+.gitignore keeps it out of the repository; keeping it out of your backups is on
+you.
+
+=head2 WHAT THE KEY IS
+
+Every secret a user stores through /secrets is encrypted under a key derived
+from this one.  It is not in the database, which is the whole point: without it
+config/auth.db is ciphertext.
+
+There is one key per installation and it does not need rotating on a schedule.
+It is meant to live and die with the machine -- nothing backs it up, and
+trog-provisioner does not carry it onto a rebuilt guest -- so a rebuild loses
+every stored secret and each user stores theirs again.  That is the intended
+cost of the key not being anywhere the database is.
+
+Replacing it has the same effect.  Everything sealed under the old one stops
+opening and says so, on /secrets and wherever it was going to be used, rather
+than presenting as corruption or as a thing worth trying again.
+
+=cut
+
+my ( $file, $help );
+GetOptions(
+    'file' => \$file,
+    'help' => \$help,
+) or exit 2;
+
+if ( $help || !$file ) {
+    print <<"USAGE";
+Usage: bin/tcms-vault-key --file
+
+Writes $Trog::Vault::key_file, for a tCMS nothing is handing a vault key to:
+running tPSGI by hand while developing, or a machine with no systemd.
+On a production host tPSGI's bin/build_service does this properly, and better;
+see perldoc bin/tcms-vault-key.
+USAGE
+    exit( $help ? 0 : 2 );
+}
+
+# One call that creates the key, private from the start, and fails if anything,
+# even a dangling symlink, is already at that path.
+my $fh;
+if ( !sysopen( $fh, $Trog::Vault::key_file, O_WRONLY | O_CREAT | O_EXCL, oct('600') ) ) {
+    die "Could not write $Trog::Vault::key_file: $!\n" unless $!{EEXIST};
+
+    # Printed and exited rather than died, so that it exits 2: refusing to
+    # clobber the one thing that cannot be regenerated is not a crash.
+    print {*STDERR} "There is already a key at $Trog::Vault::key_file.  Move it out of the way if you really mean to replace it, and read what that costs first: perldoc bin/tcms-vault-key\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+    exit 2;
+}
+
+print {$fh} Crypt::Misc::encode_b64( Crypt::PRNG::random_bytes($Trog::Vault::key_bytes) ) . "\n";
+close($fh) or die "Could not write $Trog::Vault::key_file: $!\n";
+
+print <<"SAID";
+Wrote $Trog::Vault::key_file.  Restart tCMS to pick it up.
+Fine for development.  On a production host, let tPSGI's bin/build_service hand one
+over instead, so the key is not sitting next to the database it protects.
+SAID

bin/tcmslogin

@@ -0,0 +1,118 @@
+#!/usr/bin/env perl
+
+package tcms::login;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin::libs;
+use Getopt::Long;
+use Pod::Usage;
+use IO::Prompter();
+
+use Trog::Auth;
+use Trog::Log;
+
+=head1 SYNOPSIS
+
+Log a user in and print the resulting session cookie, so that you can hand it
+to call.pl and exercise authenticated routes without a browser.
+
+=head2 USAGE
+
+    tcmslogin --user foo --password bar
+
+    # Which is meant to be used like this:
+    call.pl GET /admin/wyzzerdd '' "$(tcmslogin --user foo --password bar)"
+
+The cookie is printed to STDOUT and nothing else is, so it is safe to capture.
+Everything else the script has to say goes to STDERR.
+
+Note that logging in wastes any session the user already holds -- the session
+table keeps one row per user -- so running this will log that user out of their
+browser.
+
+=head2 OPTIONS
+
+=over 4
+
+=item --user
+
+The user to log in.  Required.
+
+=item --password
+
+That user's password.  Leaving the option out, or passing it with no value,
+reads it from STDIN instead, which keeps it out of your shell history:
+
+    tcmslogin --user foo             # prompts, with echo off
+    tcmslogin --user foo --password  # same
+    echo hunter2 | tcmslogin --user foo
+
+=item --token
+
+The user's current TOTP code, if they have 2FA enabled.
+
+=item --raw
+
+Print just the session id, without the C<tcmslogin=> prefix.
+
+=item --help, --man
+
+Display this output.
+
+=back
+
+=cut
+
+sub main (@args) {
+    my %options;
+    Getopt::Long::GetOptionsFromArray(
+        \@args,
+        'user=s'     => \$options{user},
+        'password:s' => \$options{password},
+        'token=s'    => \$options{token},
+        'raw'        => \$options{raw},
+        'help|?'     => \$options{help},
+    );
+    pod2usage( -exitval => 0, -verbose => 1 ) if $options{help};
+
+    unless ( $options{user} ) {
+        print {*STDERR} "--user is required.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+        return 2;
+    }
+
+    # Log to the file the server writes, as the user who is logging in.
+    Trog::Log::log_init( 'logs/tcms.log', 'info' );
+    $Trog::Log::user = $options{user};
+
+    # Omitted entirely or passed with no value both mean "ask me".
+    if ( !$options{password} ) {
+        my $typed = IO::Prompter::prompt( "Password for '$options{user}': ", -echo => q{}, -in => *STDIN, -out => *STDERR );
+        $options{password} = $typed ? "$typed" : undef;
+    }
+    unless ( $options{password} ) {
+        print {*STDERR} "No password provided.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+        return 2;
+    }
+
+    # mksession() tells us nothing about *why* it said no, by design -- it is
+    # the same '' for an unknown user, a bad password and a bad TOTP code.
+    my $session = Trog::Auth::mksession( $options{user}, $options{password}, $options{token}, 'tcmslogin' );
+    unless ($session) {
+        print {*STDERR} <<"SAID";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
+Login failed for '$options{user}'.
+Check the password, and pass --token if this user has 2FA enabled.
+Use bin/tcms-useradd --user $options{user} --password ... to reset it.
+SAID
+        return 1;
+    }
+
+    print $options{raw} ? "$session\n" : "tcmslogin=$session\n";
+    return 0;
+}
+
+exit main(@ARGV) unless caller;
+
+1;

bin/totp

@@ -1,20 +1,42 @@
 #!/usr/bin/env perl
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use FindBin::libs;
 
 use Trog::Auth;
 use Trog::Config;
 
+=head1 SYNOPSIS
+
+Print a user's TOTP enrollment details, so that they can set up 2FA without
+going through the web UI -- or get back in when they've lost their
+authenticator and you need to read them the current code.
+
+=head2 USAGE
+
+    bin/totp username
+
+Prints the otpauth:// URI (what a QR code would encode), the base32 secret to
+type into an authenticator by hand, and the code which is valid right now.
+
+Note that this hands out everything needed to generate that user's codes
+forever, so treat the output like a password.
+
+=head2 CAVEATS
+
+Requires general.hostname to be set in the tCMS configuration, as the domain is
+part of what an authenticator shows the user.  Set it with bin/tcms-hostname.
+
+=cut
+
 my $user   = shift @ARGV;
 my $domain = Trog::Config->get()->param('general.hostname');
 
 die "Must provide a user"                   unless $user;
 die "Must Set domain in configuration file" unless $domain;
 
-my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp( $user, $domain );
-print "TOTP URI: $uri\n";
-print "Secret: " . $totp->base32secret() . "\n";
-print "Current Auth code: " . $totp->expected_totp_code(time) . "\n";
+my ( $uri, undef, undef, undef, $totp ) = Trog::Auth::totp( $user, $domain );
+print "TOTP URI: $uri\n" . "Secret: " . $totp->base32secret() . "\n" . "Current Auth code: " . $totp->expected_totp_code(time) . "\n";

call.pl

@@ -1,23 +0,0 @@
-#!/usr/bin/perl
-# Really only useful for profiling read routes, which is all I want it for.
-
-use strict;
-use warnings;
-
-#Grab our custom routes
-use lib 'lib';
-use TCMS;
-
-my %env = (
-    REQUEST_METHOD => $ARGV[0],
-    PATH_INFO      => $ARGV[1],
-    QUERY_STRING   => $ARGV[2],
-);
-
-my $limit = $ARGV[3] || 1;
-our $app = \&TCMS::app;
-for ( 0 .. $limit ) {
-    my $out = $app->( \%env );
-    print $out->[2][0];
-}
-

config/default.cfg

@@ -1,7 +1,28 @@
 [general]
-    data_model=FlatFile
+    # FlatFile or SQLite.  See the Readme, and bin/migrate.pl
+    # for moving an existing FlatFile site across.  Until it has
+    # been moved, such a site keeps serving from FlatFile.
+    data_model=SQLite
+    # What the site calls itself in page titles and feeds.
     title=tCMS
+    # Which directory under www/themes to render with.
+    # Empty means the stock look.
+    theme=
+    # The name this site answers to.  Used wherever an absolute URL has to be
+    # built, and by the virtual machine data sources to tell which guest is
+    # this one.
+    hostname=
+[provisioner]
+    # Where trog-provisioner, which owns the VM provisioning lifecycle, is
+    # checked out.  Only needed by Trog::DataSource::ProvisionedVirt, which
+    # degrades to a plain guest listing without it.  The recipes it builds from
+    # are not here: they are in /etc/trog-provisioner, or wherever
+    # TROG_PROVISIONER_CONFIG says, because that is where the provisioner keeps
+    # them.
+    # Example: /home/you/Code/trog-provisioner
+    trog_provisioner=
 [security]
+    # Space separated list of hosts embeds (iframes, remote media) may come
+    # from.  Wildcards are allowed, e.g. *.vimeo.com.  Anything not listed here
+    # is refused by the Content-Security-Policy.
     allow_embeds_from=vimeo.com *.vimeo.com youtube.com *.youtube.com www.youtube-nocookie.com
-[nginx-unit]
-    socket=/var/run/control.unit.sock

design.md

@@ -0,0 +1,526 @@
+tCMS Design
+===========
+
+This document describes how tCMS is put together and, more importantly, *why* --
+so that you can tell at a glance where your change belongs.
+
+Read the [Readme](Readme.md) first for installation and the feature-by-feature
+tour. This is the architecture behind it.
+
+What tCMS is for
+================
+
+**Disintermediation from aggregators.**
+
+Publishing something today usually means publishing it on somebody else's
+property. The aggregator owns the URL, the audience, the ranking, the terms, and
+the right to change any of them without telling you. Your content is the product
+being sold, and you are renting access to people who already agreed to hear from
+you.
+
+tCMS exists so that the thing you publish lives at *your* domain, in *your*
+database, under *your* rules, and so that standing that up is a day's work rather
+than a project.
+
+The obstacle has never been "can I host a blog". It is that real sites are not
+blogs. A client wants invoices, or a photo gallery with EXIF, or a list of
+virtual machines with a start button, or a recipe index with cook times, or a
+paywalled newsletter, or all of those on one site. Every CMS handles the first
+one, and every CMS makes the second one a plugin project.
+
+So the design goal is narrower and more useful than "a CMS":
+
+> **Make a new content type cheap enough that building the client the thing they
+> actually asked for is faster than talking them out of it.**
+
+That is the bet the whole architecture is placed on. If you are a Perl contractor
+holding a statement of work, the question you should be able to answer in minutes
+is "what does a `Widget` post look like, and where does the Widget page come
+from" -- and the answer should be a template, a small JSON file, and nothing
+else.
+
+The one idea
+============
+
+**Everything is a post.**
+
+Not "everything is a post, plus pages, plus users, plus categories, plus
+settings". Everything:
+
+| The thing | Is a post |
+|---|---|
+| A blog entry | tagged with its series, `form` is `blog.tx` |
+| A page | a post whose `local_href` is where you want it |
+| A user profile | a post tagged `about`; the user *is* their profile page |
+| A category / section | a "series" post, which owns an ACL and names its children's type |
+| A virtual machine | a post, built on demand by a datasource, never stored |
+
+A post is a JSON object. It has a handful of fields every post has -- `id`,
+`title`, `data`, `tags`, `created`, `version`, `visibility`, `local_href`,
+`callback` -- and then whatever else its type says it has.
+
+Two consequences fall out of that, and most of the system is downstream of them.
+
+**The routing table is data, not code.** Every post carries a `local_href` and a
+`callback`. At startup, `_routes` in TCMS.pm asks the data model for every post and
+builds the routing table out of them, then merges the static routes from
+`Trog::Routes::HTML`, `Trog::Routes::JSON` and the active theme over the top.
+Publishing a post creates a URL because the URL *is* a field on the post. There
+is no separate router config to keep in sync, and no rewrite rules.
+
+A key of the table is a path, or an OpenAPI path template such as
+`/sitemap/{map}.xml` or `/lib/{module+}`. Each variable of a template reaches the
+callback under its name, without the `+`. `TCMS::build_routes` turns the table
+into the OpenAPI 3 document that tPSGI routes by. A route's `parameters` are
+OpenAPI parameter objects, so tPSGI validates the request before the callback
+runs. Its flags, such as `auth` and `totp_exempt`, reach the callback as
+`x-tcms-auth` and so on in `$query->{dispatcher}`. The path of a post cannot
+hold a `{` or a `}`, because OpenAPI has no way to escape them.
+
+**Adding a content type does not require touching Perl.** A post type is a
+template that says how to display and edit it, plus a JSON sidecar that says what
+fields it has. Both are files in a directory. See [Post types](#post-types).
+
+The request lifecycle
+=====================
+
+tCMS is a routing module, not a server. It is run by **tPSGI**, which owns the
+socket, the process model, the access log and the static file cache. tPSGI hands
+each request to the callback tCMS registered for that route, and hands the
+callback a `tpsgi` object for the things only the server can do -- redirect,
+forbid, invalidate cached renders, run work after the response is closed.
+
+```
+  tPSGI
+    │  route lookup against the table TCMS built at startup
+    ▼
+  TCMS::build_routes' wrapper          ← identity, ACLs, logging context
+    │
+    ▼
+  Trog::Routes::HTML::<callback>       ← e.g. series() → posts() → index()
+    │
+    ├──▶ Trog::Data->new(config)       ← the data model: get() the posts
+    │      └──▶ Trog::DataSource       ← unless this type's posts are built, not stored
+    │
+    ├──▶ enrich_post                   ← resolve declared relations, run enrich subs
+    │
+    ▼
+  Trog::Renderer->render(...)          ← picks a renderer by content type
+    │      └──▶ Text::Xslate           ← templates, with component() and render_it()
+    ▼
+  [ code, headers, body ]              ← a PSGI triplet
+    │
+    └──▶ tpsgi->save_render(...)       ← if this page is cacheable, write a static
+```
+
+The wrapper installed by `TCMS::build_routes` is where a request stops being
+anonymous bytes and becomes a request by somebody:
+
+1. Initialise logging into tPSGI's log directory.
+2. If `config/setup` does not exist, this is a fresh install -- everything goes
+   to the setup route.
+3. Pull the `tcmslogin` cookie, resolve it to a user, load that user's ACLs into
+   `$query->{user_acls}`.
+4. Strip an `admin` ACL from anything the *request* asked for unless the user
+   actually holds it.
+5. Refuse the request if the route requires auth and nobody is logged in.
+
+Everything downstream reads `$query->{user_acls}` and never asks who the user is
+again.
+
+The static render cache
+-----------------------
+
+`Trog::Renderer::render` hands finished pages back to tPSGI to save as static
+files, but only when caching one is safe. It skips when the render is a
+component, when the route says `nocache`, when there is no route to key on, when
+the request had a query string, **when a user is logged in**, when the status is
+not 200, or when running at debug level.
+
+That last-but-two is the important one: a logged-in reader sees `/secure/...`
+variants and editing chrome, and caching those would serve one user's view to
+another. Anonymous readers get files off disk; editors get live renders. Saving a
+post invalidates the cache.
+
+`nocache` is read off both the render options and the page data, so a route's
+`nocache` flag -- which `TCMS::build_routes` puts on the query -- reaches it
+whether or not the route thought to forward it. That is also how a datasource
+which cannot say when its posts go stale keeps its pages out of the cache.
+
+Post types
+==========
+
+This is the extension point that matters, so it gets the most detail.
+
+A post type is two files in `www/templates/html/components/forms/`:
+
+    blog.tx      the template: how a post of this type displays, and how it edits
+    blog.json    the sidecar: an OpenAPIv3 object schema for its fields
+
+`Trog::DataModule::schema_for` merges the sidecar with the base post schema and
+uses the result to validate every save. The base schema is merged **last**, on
+purpose: a sidecar can add fields but can never redefine a core one. A sidecar
+retyping `callback` as a plain string would defeat the check that the sub it
+names actually exists, which is a privilege problem rather than a cosmetic one.
+
+The sidecar carries the wizard's own UI metadata on `x-` extension keys, so there
+is one file to keep in sync rather than two:
+
+| Key | Means |
+|---|---|
+| `x-tcms-label`, `x-tcms-placeholder` | what the editor shows for this field |
+| `x-tcms-input` | which widget to render |
+| `x-tcms-private` | editors only -- the value is dropped before rendering, so no template mistake can leak it |
+| `x-tcms-indexed` | give this field its own indexed column, where the data model can |
+| `x-tcms-relation-form` | this field holds another post's UUID |
+| `x-tcms-relations` | what to resolve onto the post at render time |
+| `x-tcms-datasource` | these posts are built by a module, not stored |
+| `x-tcms-post-type` | the type's own name, description, and everything the wizard was told to build it |
+
+You do not have to write either file by hand. **The Post Type Wizard**
+(`/admin/wyzzerdd`) generates both from a form: name the fields, pick their
+types, tick whether each is required, editors-only, or indexed, and write the
+display snippet. It writes the template and the sidecar into whichever forms
+directory is in use -- the theme's if it has one, the stock one otherwise -- and
+the type is live on the next request. No restart: `themed_templates_in_dir`
+re-reads the directory every call and Xslate resolves includes lazily.
+
+The generated template is ordinary Kolon, so hand-editing it afterwards is
+expected and fine. Regenerating the type overwrites it, which is why the wizard
+says so at the top of what it writes.
+
+The wizard's "Start from" dropdown reopens a type that already exists: it fills
+the form back in from the sidecar, shows the type's description, and ticks
+Overwrite, so changing one thing about a type is a two-minute job rather than
+filling the form in again from memory. That works because `x-tcms-post-type`
+records everything the wizard was told -- the description, the display template,
+the checkboxes, the placeholder -- and `schema_for` strips that whole key before
+validation, so none of it can affect whether a post saves.
+
+Canned blocks
+-------------
+
+Most of an editor is not the type's own: `preview.tx`, `tags.tx`, `aliases.tx`,
+`visibility.tx`, `acls.tx` and `attachments.tx` are blocks every form splices in,
+and the wizard's "Canned Fields" checkboxes are which of them to include.
+
+Each has a sidecar of its own beside it, in the components dir rather than in
+`forms/`:
+
+    preview.tx     the block: the markup an editor splices in
+    preview.json   the sidecar: an OpenAPIv3 fragment for what it collects
+
+`Trog::DataModule::includes_for` reads a type's `: include` lines back out of its
+template -- the only account there is for a hand-written type -- and
+`include_schema_for` turns each one into the fields it collects. Two things
+follow from one declaration:
+
+- `schema_for` merges them in, so a generated type keeps the preview image its
+  own editor collected. `validate` drops every field the schema does not
+  describe, and nothing described those.
+- The wizard tells a canned field apart from one somebody typed in, so ticking
+  "Preview image upload" and listing `preview` as a custom text field are no
+  longer the same thing said twice.
+
+A block never overrules the type that borrows it, and the base schema still
+overrules both: the merge order is base, then the type's own sidecar, then the
+blocks it includes. A block with no sidecar collects nothing, which is right for
+`edit_head.tx` and the rest of the furniture.
+
+Series, and how content is organised
+------------------------------------
+
+A **series** is a post of type `series.tx` that does two jobs:
+
+- It **owns an ACL**. Its `aclname` is the tag its children carry, so "who may
+  read this section" is one field on one post.
+- It **names its children's type** via `child_form`. A series of `invoice.tx`
+  lists invoices; the same site's series of `blog.tx` lists blog entries.
+
+Tag a series `topbar` and it appears in the site navigation. That is the whole
+of "site structure" -- there is no menu editor, because the menu is a query.
+
+Visibility and ACLs
+-------------------
+
+`visibility` is one of `public`, `unlisted`, `private`. `Trog::DataModule::process`
+folds it into the post's `tags`, along with the post's ACLs when it is private,
+and then deletes the separate `acls` field. **Tags are the whole truth about who
+may see a post**, which is why `get()` answers the `acls` filter by looking at
+tags and nothing else.
+
+Know this before you touch anything that filters. A change that makes tags and
+ACLs diverge is a disclosure bug, not a refactor.
+
+Storage: data models
+====================
+
+A data model is where posts live. `Trog::Data` is a factory; the implementation
+is chosen by `general.data_model` in the config.
+
+`Trog::DataModule` is the base class and provides the query semantics -- `get()`,
+`filter()`, `paginate()`, version rollup, validation, and the derived-field
+plumbing in `process`. A subclass must implement `read`, `write`, `count`,
+`tags`, `lang` and `help`, and may override `get` if it can answer a query more
+directly than by filtering in Perl.
+
+| Model | What it is | Use it when |
+|---|---|---|
+| `DUMMY` | one JSON blob | never in production; it is not race-safe. It exists as the smallest possible worked example of the interface |
+| `FlatFile` | one file per post, SQLite alongside as a tag index | you want the posts to be greppable files on disk, and the site is small |
+| `SQLite` | posts in SQLite, blob and all | anything else |
+
+Posts are **versioned**. A save appends a version rather than overwriting, and
+`get()` hands back the newest one, carrying `version_max` plus the original
+`created` and `author` from the first version. Asking for a specific `version`
+gets that one.
+
+The SQLite model is worth understanding as a pattern, because it is the shape a
+new model should copy: it stores the same JSON blob the flat file model would
+have written and projects everything worth querying back out of it as
+`GENERATED ALWAYS ... VIRTUAL` columns. The blob stays the single source of
+truth, the projections cost no storage and cannot drift from it, and adding a
+queryable field is an `ALTER TABLE` plus a `CREATE INDEX` with no migration --
+because the data never moves. Tag membership needs one row per tag, so triggers
+unpack `json_each` into an index table; search is FTS5 with the trigram
+tokenizer, which is the one tokenizer that answers the substring queries the
+search box has always meant.
+
+Foreign authority: data sources
+===============================
+
+Sometimes the authoritative copy of something is not yours and never will be. A
+hypervisor knows what guests exist; a payment processor knows what was paid; an
+LDAP directory knows who works here. Copying that into the datastore means it is
+wrong the moment you copy it.
+
+A **datasource** lets a post type say "my posts are built, not stored". The
+series is still an ordinary post; only its children are synthesized, and they are
+rebuilt on every view.
+
+    "x-tcms-datasource": "Trog::DataSource::Virt"
+
+The module provides `posts($series, $query)` and may provide `filter`, `order`,
+`lang`, `help` and `EDITABLE`. `Trog::DataSource` documents the whole contract
+and supplies the defaults.  `Trog::DataSource::DirIndex` is the shortest complete
+example: a directory becomes a listing, with a hard constraint on which
+directories it will look at and an inotify watch so the cached page is thrown
+away when the directory changes.
+
+Two things about the contract are worth knowing before you write one, because
+both are places the obvious implementation is wrong:
+
+- **Your posts have never been near the datastore**, so nothing has filtered
+  them. The reader's search was answered against the datastore and thrown away
+  along with the posts it filtered. `filter()` is how the search reaches your
+  posts, and you should implement it if your posts carry anything worth
+  searching beyond a title.
+- **Nothing else will invalidate your page's static render.** A post being saved
+  does not invalidate it, because no post was saved -- the thing you depend on
+  changed instead. So you must answer one of two ways. Either you can name what
+  you depend on, in which case register a `$tpsgi->add_watch` for it with a
+  stable `key`, invalidate through the tPSGI object your callback is *handed*
+  rather than the one it closed over, and declare `CACHEABLE`
+  (`DirIndex::watch` is four lines of this). Or you cannot, in which case say
+  nothing and your pages are never cached -- which is the default, because a
+  page that is merely slow beats one that is wrong with no way of becoming
+  right.
+- **Your posts probably all share a timestamp**, because you stamped them with
+  the time you built them. Stored posts paginate by a `created` cursor, which on
+  such a page cannot move -- every cursor is the same instant. Datasource pages
+  therefore paginate by page number, which is why `order()` has to be total: page
+  2 of a shuffled list is a lottery.
+
+Rendering
+=========
+
+`Trog::Renderer->render(%options)` dispatches on content type to a renderer under
+`Trog::Renderer::`, all of which subclass `Trog::Renderer::Base`. The known types
+are in `Trog::Vars::%content_types`: text, html, json, blob, xml, xsl, css, rss,
+email.
+
+Base sets up the Xslate instance, resolves templates against the theme's
+directory and then the stock one, and injects two functions every template can
+call:
+
+- `render_it($string)` -- render a template string that came out of a post, which
+  is what lets a post body contain `<: embed(12345, 'embed') :>`.
+- `component('Name', {...})` -- render a `Trog::Component`.
+
+Components
+----------
+
+A component is a module in `Trog::Component` with a `render(%args)` returning a
+string. Templates ask for what they want by name rather than having a route
+render it and thread the string through:
+
+    <: component('EmojiPicker') :>
+    <: component('Gallery', { album => $post.id, cols => 3 }) :>
+
+The page furniture is built this way -- `Header`, `Footer`, `HtmlTitle`,
+`MidTitle`, `TopBar`, `LeftBar`, `RightBar`, `FootBar`, `CategoryBar` are what
+`index.tx` is made of. Each module owns the name of the template it renders, so
+adding a piece of furniture does not mean editing a route.
+
+One caution if you write one: Xslate catches an exception thrown out of a
+template function, warns, and renders on with an empty string where the call was.
+A component that merely dies would vanish from the page with a line on stderr to
+show for it, so `Trog::Component` also records the failure for `Renderer::Base`
+to turn into a 500.
+
+Themes
+------
+
+A theme is a directory under `www/themes/` mirroring the structure of `www/`.
+Templates resolve against the theme's directory first and the stock one second,
+so a theme overrides individual templates without forking the ones next to them.
+Stylesheets are the exception and are loaded both, theme last, so a theme can
+override a handful of rules without restating the sheet. A theme may ship a
+`routes.pm` to add routes of its own.
+
+A script resolves as a template does. A route names the scripts of its page in
+its definition: `scripts` for every reader, and `authenticated_scripts` for a
+reader who is logged in as well. A template does not write a `<script src>` tag
+of its own. The route of a post gets the scripts of a post page, from
+`%Trog::Routes::HTML::post_page_scripts`. `finish_render` links the lists as one
+bundle, which `Trog::Bundle` builds and `/bundle/{version}/{names}.js` serves.
+That route serves only a list that a route declares, so a request cannot make
+tCMS build a bundle. The version is a digest of the bundle,
+so a browser keeps the bundle until a script in it changes. A script whose name
+ends in `.min.js` goes into the bundle as it is, and the others are minified.
+tPSGI saves each bundle that a page links as a static, and it watches the
+script directories. When a script changes, it throws away the saved pages and
+bundles.
+
+Composition: relations and enrichment
+=====================================
+
+Types need to refer to each other -- an invoice has a payee and a payor, which
+are `entities` posts. A type declares that in its sidecar and
+`Trog::Routes::HTML::enrich_post` resolves it at render time:
+
+- an entry naming a `from` field resolves the UUID in that field into the post it
+  refers to;
+- an entry without one pulls in *every* post of the target type, which is what an
+  editor's picker or a "show me all of these" display wants.
+
+Resolution is memoised per request, or a page of twenty-five invoices rescans
+every entities post twenty-five times.
+
+When a type needs something computed rather than merely fetched, it gets an
+enrich sub -- see `Trog::Enrich::Invoice`, which sums a multi-page invoice's line
+items into a total.
+
+Identity, configuration, operations
+===================================
+
+**Auth** (`Trog::Auth`) is an SQLite database at `config/auth.db` holding hashed
+and salted passwords, ACLs and sessions. A session is the `tcmslogin` cookie.
+
+The webserver participates. `/authenticated` answers 200 for a request carrying a
+live session and 403 otherwise, and exists so that nginx can `auth_request`
+against it -- which is how private uploads under `www/assets/private` are gated
+without tCMS being in the path of the file itself. That protection is real and it
+is invisible from inside the application, so code that reasons about what is
+reachable should not assume it and should not try to replace it.
+TOTP two-factor is mandatory. A login without an enrolment gets a session and is
+sent to `/totp`, and the dispatcher refuses every other route behind a login
+until they have one -- that window exists at all because the QR *is* the shared
+secret, so a login is what you have to present to be shown it. There is no way to
+turn it back off; `bin/totp` reads a user their existing enrolment back out of
+band, which is what covers a lost authenticator. The first user to register
+becomes the administrator and registration then closes; further users are made by
+an admin through the `about` post type -- because a user *is* their profile page.
+
+**Secrets** (`Trog::Vault`) keeps the passwords that are not tCMS's -- the
+provisioner's KeePass passphrase to begin with -- in `user_secret`, sealed with
+AES-256-GCM under a key derived per row from the installation's master key. That
+key is not in the database and not in the checkout: it arrives as a systemd
+credential, through the environment, and is deleted from the environment at load
+because this process forks a provisioner it hands decrypted passwords to. A TOTP
+code is what authorizes opening one, and `Trog::Auth::spend_totp` walks a
+per-user counter forwards so a code buys one thing rather than everything inside
+its window. No key means no vault, and the things that would have used one ask
+for the password directly.
+
+**Config** (`Trog::Config`) is a thin wrapper over `Config::Simple` reading
+`config/main.cfg` and falling back to the shipped `config/default.cfg`. It is
+memoised, so a config change signals the workers to restart.
+
+**Logging** (`Trog::Log`) goes to a rotating file, to the screen at error level
+and above -- which is what reaches the webserver's log -- and to SQLite via
+`Trog::Log::DBI`, which is what `Trog::Log::Metrics` later reads time series out
+of. Log lines start with an ISO8601 date because fail2ban parses them; do not
+change that. UTM parameters are captured per request, so the analytics are yours
+too.
+
+**Deployment** is tPSGI behind nginx. See the Readme for development, and the
+`trog-provisioner` recipes (`tcms`, `tpsgi`, `nginxproxy`) for production --
+several features want the configuration encoded there.
+
+Where does my change go?
+========================
+
+The contractor's cheat-sheet.
+
+| I need... | Do this | Perl required |
+|---|---|---|
+| A new kind of content | Post Type Wizard, or write `foo.tx` + `foo.json` by hand | none |
+| A field on an existing type | edit its sidecar; the editor and validator follow | none |
+| That field to be searchable/filterable fast | tick "Index this field" in the wizard | none |
+| A field only editors may see | `x-tcms-private` in the sidecar | none |
+| One type to refer to another | `x-tcms-relations` in the sidecar | none |
+| A new section of the site | make a series post; tag it `topbar` for the nav | none |
+| To restrict a section | give the series an ACL; grant it to users | none |
+| A different look | a theme directory; override the templates you care about | none |
+| A reusable chunk of UI | `Trog::Component::Whatever` with `render(%args)` | a little |
+| A canned editor block forms can include | `foo.tx` in `components/`, plus `foo.json` saying what it collects; add it to `%wizard_includes` to get a checkbox | a little |
+| A page listing a directory of files | a series with a directory + a wizard type using `DirIndex` | none |
+| Content from an external system | `Trog::DataSource::Whatever` with `posts($series,$query)` | some |
+| To extend one that exists | subclass it; `can()` resolves through `@ISA`, so override only what differs (`ProvisionedVirt` does this to `Virt`) | some |
+| A computed field on a type | an enrich sub, as `Trog::Enrich::Invoice` does | some |
+| A route that is not a post | add to `%Trog::Routes::HTML::routes`, or a theme's `routes.pm` | some |
+| A different place to keep posts | subclass `Trog::DataModule` | most |
+| A new output format | a `Trog::Renderer::` subclass, registered in `Trog::Renderer` | most |
+
+Things that will bite you
+=========================
+
+Hard-won, and none of them obvious from reading the code that contains them.
+
+- **Tags carry visibility and ACLs.** `process` folds them in and deletes the
+  separate field. Anything that filters on tags is a security boundary.
+- **`get(id => ...)` deliberately skips the ACL filter.** `filter()` returns early
+  for an `id`, `title` or `aclname` query, because that is how `add()` asks
+  whether a post already exists. Do not "fix" it without reading every caller.
+- **Validation runs on what was submitted; `process` then builds what gets
+  stored.** Both are checked now (`validate` and `validate_built`), and they
+  check different objects. A field that only exists after `process` will not be
+  in the first one.
+- **The FlatFile model caches its tag list at load time** and filters each query's
+  tags against it *in place*. A tag created later is not merely unindexed, it is
+  deleted from the query. Production survives this because a save re-execs the
+  workers; anything long-lived doing its own reads has to refresh it by hand.
+- **Sidecar schemas are cached on the forms directory's mtime.** Writing a
+  sidecar and reading it back in the same process is fine; the resolution is
+  sub-second, but the cache is real.
+- **A component that fails must be recorded, not merely thrown.** See above.
+- **Never `use` `Trog::Renderer` from `Trog::Component`.** `Renderer::Base` uses
+  `Trog::Component`; the cycle is why components load lazily.
+
+Testing
+=======
+
+`prove -l t/`. The suite is `Test::More` with `Test::MockModule` and
+`Test::Fatal`.
+
+The one to know about is `t/Trog-Routes-HTML-series-lifecycle.t`, which stands up
+a genuinely fresh tCMS in a temp directory and walks what a user actually does:
+register an admin, invent a post type in the wizard, build a series of every
+content type, add children, and confirm each renders. It asserts the repository
+itself was not touched, which is the only real proof of isolation.
+
+It is parameterised by `TCMS_TEST_DATA_MODEL` and runs against every data model,
+because **a data model is only finished when the application cannot tell which
+one it is talking to.** If you add a model, that is the test that says whether
+you are done.

dns/10-disable-stub-resolver.conf

@@ -1,4 +0,0 @@
-[Resolve]
-DNS=8.8.8.8
-FallbackDNS=8.8.4.4
-DNSStubListener=no

dns/10-powerdns.conf

@@ -1 +0,0 @@
-local1.* /var/log/pdns.log

dns/configure_pdns

@@ -1,20 +0,0 @@
-#!/usr/bin/env perl
-
-use strict;
-use warnings;
-
-use File::Copy;
-use Config::Simple;
-
-# Fix broken out of the box systemd unit for pdns
-my $service_file = "/usr/lib/systemd/system/pdns.service";
-die "Can't find service file $service_file" unless -f $service_file;
-
-my $cfg = Config::Simple->new($service_file);
-
-#$cfg->param("Service.WorkingDirectory", "/var/spool/powerdns");
-my $invocation = "/usr/sbin/pdns_server --guardian=no --daemon=no --logging-facility=1 --log-timestamp=yes --write-pid=no --chroot";
-$cfg->param("Service.ExecStart", $invocation);
-
-File::Copy::copy($service_file, "$service_file.bak");
-$cfg->save();

dns/tcms.tmpl

@@ -1,3 +0,0 @@
-# tCMS powerdns configuration for __DOMAIN__
-launch=gsqlite3:__DOMAIN__
-gsqlite3-__DOMAIN__-database=__DOMAIN__/zones.db

docker-exfil.sh

@@ -1,11 +0,0 @@
-#!/bin/sh
-docker cp $1:/home/tcms/config $PWD
-docker cp $1:/home/tcms/data $PWD
-docker cp $1:/home/tcms/www/assets $PWD/www
-if [ $user ]
-then
-    chown -R $USER:$USER $PWD/config/
-    chown -R $USER:$USER $PWD/data/
-    chown -R $USER:$USER $PWD/www/assets/
-fi
-docker kill $1

dockerdeploy.sh

@@ -1,3 +0,0 @@
-#!/bin/sh
-docker build -t troglodyne/tcms .
-docker run --restart unless-stopped -dp 5000:5000 troglodyne/tcms:latest

etc/openssl.conf

@@ -1,6 +0,0 @@
-# Only here to make self-signed certs work right, see makefile
-[req]
-distinguished_name=dn
-[ dn ]
-[ ext ]
-basicConstraints=CA:TRUE,pathlen:0

fail2ban/tcms-filter.conf

@@ -1,4 +0,0 @@
-[Init]
-datepattern=%%Y-%%m-%%dT%%H:%%M:%%SZ
-[Definition]
-failregex=^ \[INFO\]: RequestId [\d\w-]+ From <HOST> \|nobody\| \w+ 4\d{2} http

fail2ban/tcms-jail.tmpl

@@ -1,8 +0,0 @@
-[__DOMAIN__]
-enabled = true
-port = http,https
-filter = __DOMAIN__
-logpath = __LOGDIR__/logs/tcms.log
-maxretry = 5
-findtime = 60
-bantime  = 600

fulldeploy.sh

@@ -1,3 +0,0 @@
-#!/bin/sh
-docker build -t troglodyne/base . -f Dockerfile.build
-./dockerdeploy.sh

git-hooks/post-commit

@@ -0,0 +1,33 @@
+#!/bin/sh
+
+# Bring the records of tests-covering up to the commit just made.
+#
+# git-hooks/pre-commit chooses tests by reading a diff against these records,
+# and a diff describes the files as they were before the change.  So after each
+# commit the records must describe that commit, or the next choice falls back
+# to every test that loaded a changed file, and grows coarser with each commit.
+#
+# In the background, because it runs each stale test under Devel::Cover, and a
+# full refresh takes much longer than a commit should.  Run it by hand to catch
+# up.  It runs the tests the way the pre-commit hook does, with lib/ on the
+# path and nothing else set, so that the records describe the same runs.
+#
+# Install it: cp git-hooks/pre-commit git-hooks/post-commit .git/hooks/
+
+command -v tests-covering >/dev/null 2>&1 || exit 0
+
+# Not while a rebase, or a cherry-pick or revert of several commits, applies
+# them.  git runs this hook for each commit that it applies, and each refresh
+# runs every stale test under Devel::Cover.  A refresh brings the records up to
+# the working tree, however many commits it missed, so the next commit after
+# the rebase catches them up.
+for state in rebase-merge rebase-apply sequencer; do
+    [ -d "$(git rev-parse --git-path "$state")" ] && exit 0
+done
+
+# Without the GIT_ variables that git sets for this hook, for the reason the
+# pre-commit hook gives: the refresh runs the tests, and a test that runs git
+# in a repository of its own would otherwise work in this one.
+unset $(env | sed -n 's/^\(GIT_[A-Za-z0-9_]*\)=.*/\1/p')
+
+tests-covering --refresh --jobs "$(nproc 2>/dev/null || echo 1)" >/dev/null 2>&1 &

git-hooks/pre-commit

@@ -1,14 +1,209 @@
 #!/bin/sh
 
-to_tidy=$(git diff --cached --name-only  | egrep ".p[m|l]$")
+# Tidy staged Perl, judge it against .perlcriticrc, then run the tests, before
+# any of it lands.
+#
+# There is a .perltidyrc, and a tree stays tidy to it only if something makes it.
+# Left to people, it does not: tidying a file you are changing three lines of
+# buries the change in a hundred lines of reformatting, so the reasonable thing
+# is to skip it, and the tree drifts until a mass tidy is the only way back.
+# One commit's worth at a time is small enough that nobody has to weigh it up.
+#
+# perlcritic is here for the other half of that.  Nothing else in tCMS runs the
+# profile, so this is where an objection is about the diff in front of you.
+#
+# There is one profile, .perlcriticrc, and which one that is was decided when
+# the floor was chosen: the packaging-perl skill asks which perl you
+# are targeting and copies the matching profile to that name. So the hook needs
+# no opinion about versions -- the file it reads is already the right one, and
+# changing your floor means replacing that file rather than editing this.
+#
+# Install it: cp git-hooks/pre-commit .git/hooks/
+#
+# A file qualifies three ways:
+#   - a .pm, .pl or .t extension
+#   - a .PL extension, which is how a Makefile.PL gets covered
+#   - executable with perl on its shebang line, which is how the extensionless
+#     scripts in bin/ get covered
+#
+# .t is in there because test files are often not executable, and the shebang
+# rule alone would then tidy whichever ones happen to be and let the rest drift.
+#
+# Both passes read the working tree rather than the index, so a file staged in
+# part is judged whole. That is deliberate: perltidy rewrites the file on disk
+# and the hook stages what it wrote, so the working copy is what lands anyway,
+# and two passes disagreeing about which bytes they looked at would be worse to
+# own than this.
+#
+# Both run from the top of the working tree, which is where git runs a hook and
+# the only place they work at all: the profile names .preferred_modules.ini and
+# .pod_stopwords by relative path.
 
 # Redirect output to stderr.
 exec 1>&2
 
-if [ $to_tidy  ]
+# ACMR so that a file deleted in this commit is not handed to perltidy, which
+# would fail on a path that is no longer there.
+staged=$(git diff --cached --name-only --diff-filter=ACMR)
+
+lib_files=''
+test_files=''
+for file in $staged
+do
+    test -f "$file" || continue
+
+    is_perl=''
+    case "$file" in
+        *.pm|*.pl|*.PL|*.t)
+            is_perl=1
+            ;;
+    esac
+
+    if [ -z "$is_perl" ] && test -x "$file" && head -n 1 "$file" | grep -Eq '^#!.*perl'
+    then
+        is_perl=1
+    fi
+
+    test -n "$is_perl" || continue
+
+    # Whether a file is perl at all, and then which list it goes in.  One case
+    # statement doing both would file t/00-load.t under whichever arm it reached
+    # first, and the .t rule is above the path rule.
+    case "$file" in
+        t/*) test_files="$test_files $file" ;;
+        *)   lib_files="$lib_files $file" ;;
+    esac
+done
+
+# For the tidy pass, which does not care which list a file came from.  The
+# emptiness tests below concatenate the two without a space instead: with one,
+# "no perl staged at all" would be a string holding a space, which is not empty.
+all_files="$lib_files $test_files"
+
+# Quoted here, because a bare [ $all_files ] is a syntax error the moment there
+# is more than one file -- which would stop the hook working in exactly the
+# commits that need it most.  Unquoted below, because there the word splitting is
+# what turns one string into an argument list.
+if [ -z "$lib_files$test_files" ]
+then
+    :
+elif command -v perltidy >/dev/null 2>&1
 then
     echo "Auto-tidying perl changes..."
-    perltidy -b $to_tidy
-    git add $to_tidy
+
+    # -bext='/' makes perltidy delete the backup it would otherwise leave
+    # sitting next to the file as <name>.bak.
+    perltidy -b -bext='/' $all_files || {
+        echo "pre-commit: perltidy failed, leaving the commit alone."
+        exit 1
+    }
+
+    git update-index --add $all_files
     echo "Done."
+else
+    echo "pre-commit: perltidy is not on PATH, skipping the tidy pass."
 fi
+
+# After the tidy pass and never before.  The tidy pass rewrites these files and
+# stages what it wrote, so what critic has to judge is the bytes that will land
+# rather than the ones you saved -- and if you ever turn [CodeLayout::
+# RequireTidyCode] back on, running it first would fail the commit over the one
+# thing the hook had already set out to fix by itself.
+#
+# Three branches rather than two conditions and one else.  Staging nothing the
+# profile judges -- a commit of documentation, say -- is not the same thing as
+# having no perlcritic to judge it with, and one else says the second whenever
+# the first is true.
+if [ -z "$lib_files$test_files" ]
+then
+    echo "Nothing staged that the profile judges."
+elif command -v perlcritic >/dev/null 2>&1
+then
+    echo "Running perlcritic..."
+
+    # Both passes run even when the first has already failed, so one commit
+    # shows every objection rather than one list's worth at a time.
+    critic_failed=''
+
+    if [ -n "$lib_files" ]
+    then
+        perlcritic --profile .perlcriticrc $lib_files || critic_failed=1
+    fi
+
+    # The same profile for t/, less three policies.  A test is not a module:
+    # nobody runs perldoc on it, so requiring POD of it asks for a page no
+    # reader will ever open.  And a test sets %ENV and %INC, and writes its
+    # fixtures, in a BEGIN block before the SUT loads, for the whole file: a
+    # local would end with the block, and no compiled binary is made of a test.
+    # Everything else in the profile still judges it, which is more than a
+    # release does -- all_critic_ok() reads lib/ and not t/, so this hook is the
+    # only thing that looks at a test file at all.
+    if [ -n "$test_files" ]
+    then
+        perlcritic --profile .perlcriticrc --exclude Documentation::RequirePod --exclude Variables::RequireLocalizedPunctuationVars --exclude CompileTime $test_files || critic_failed=1
+    fi
+
+    if [ -n "$critic_failed" ]
+    then
+        echo
+        echo "pre-commit: perlcritic refused the above.  Either fix them, or say"
+        echo "why with a '## no critic (Policy::Name)' and the reason beside it."
+        echo "To commit without these checks at all: git commit --no-verify"
+        exit 1
+    fi
+
+    echo "Done."
+else
+    # Skipped rather than fatal, for the same reason the tidy pass is: a machine
+    # without perlcritic can still commit.
+    echo "pre-commit: perlcritic is not on PATH, skipping the critic pass."
+fi
+
+# Last, because the tests read the files that the tidy pass wrote.  Whatever is
+# staged, and not only Perl: a change to a share/ file or a fixture breaks a
+# test as surely as a change to a module does.  -l for lib/.
+#
+# Without the GIT_ variables that git sets for this hook.  It sets
+# GIT_INDEX_FILE, and GIT_DIR too in a worktree, and git obeys them over -C.  So
+# a test that runs git in a repository of its own would add, commit and write
+# config in this one.  In a subshell, because the git commands of this hook need
+# them: under git commit -a, GIT_INDEX_FILE names the index being committed.
+run_tests() {
+    (
+        unset $(env | sed -n 's/^\(GIT_[A-Za-z0-9_]*\)=.*/\1/p')
+        prove -lm -j8 "$@"
+    ) || {
+        echo "pre-commit: the tests above failed.  To see why, run each failing file"
+        echo "on its own:  prove -lv t/<file>.t"
+        echo "To commit without these checks at all: git commit --no-verify"
+        exit 1
+    }
+}
+
+test -d t || exit 0
+
+# Without tests-covering, every test, because nothing here knows which tests a
+# change can reach.
+if ! command -v tests-covering >/dev/null 2>&1
+then
+    echo "Running every test, because tests-covering is not on PATH; install Perl::Tests::Covering..."
+    run_tests t/
+    exit 0
+fi
+
+# tests-covering chooses the tests that ran a line the diff changes, from the
+# records that git-hooks/post-commit keeps up to date.  It asks
+# .tests-covering-map.pl about each file that no test loads, and the map names
+# the files that no test reads, such as dist.ini.  --unexplained all runs every
+# test for a file that neither can place, such as a fixture.  --full-index,
+# because it matches each file to its records by the blob id on the index line
+# of the diff, and an abbreviated id matches nothing.
+tests=$(git diff --cached --full-index | tests-covering --diff --unexplained all) || exit 1
+if [ -z "$tests" ]
+then
+    echo "No test ran a line that this commit changes."
+    exit 0
+fi
+
+echo "Running the tests that ran what this commit changes..."
+run_tests $tests

images/README.md

@@ -1,17 +0,0 @@
-Containerization
-====
-
-Root is not required to build or run the image.
-
-
-Images can be built like this,
-
-```
-$ buildah unshare ./images/base.sh
-```
-
-Containers can be run like this,
-
-```
-$ podman run -p 0.0.0.0:5000:5000 localhost/tcms
-```

images/base.sh

@@ -1,38 +0,0 @@
-#!/bin/sh
-
-ctr=$(buildah from alpine:latest)
-mnt=$(buildah mount "$ctr")
-
-mkdir -p "$mnt/srv/tcms" "$mnt/tmp/tcms"
-cp -R bin/ config/ data/ www/ lib "$mnt/srv/tcms";
-cp Makefile.PL "$mnt/tmp/tcms/"
-make -C "$mnt/srv/tcms" --makefile "$PWD/Makefile" prereq-frontend reset-dummy-data
-
-buildah run -- $ctr sh <<EOF
-  apk update
-  apk add perl perl-xml-libxml perl-moose perl-datetime perl-dbi perl-dbd-sqlite perl-capture-tiny perl-date-format
-
-	# needed for install
-	apk add curl make musl-dev perl-dev gcc mlocate perl-app-cpanminus
-	cpanm -n --no-wget --curl --installdeps /tmp/tcms/
-	apk del curl make musl-dev perl-dev gcc mlocate perl-app-cpanminus
-EOF
-
-rm -rf \
-	"$mnt/tmp/tcms"       \
-	"$mnt/var/cache/*"    \
-	"$mnt/root/.cpanm"    \
-	"$mnt/usr/share/man/" \
-  "$mnt/usr/local/share/man"
-
-find "$mnt/usr/lib/perl5" -name '*.pod' -delete
-
-buildah config                              \
-  --workingdir "/srv/tcms/"                 \
-	--entrypoint '["/usr/local/bin/starman"]' \
-	--cmd "/srv/tcms/www/server.psgi"         \
-	--port 5000                               \
-	--label "Name=tCMS"                       \
-	--author "George Baugh"                   \
-	"$ctr"
-buildah commit --rm "$ctr" tcms

lib/TCMS.pm

@@ -1,30 +1,20 @@
 package TCMS;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-no warnings 'experimental';
-use feature qw{signatures state};
+use Carp  qw{confess};
+use Clone qw{clone};
 
-use Clone        qw{clone};
-use Date::Format qw{strftime};
-
-use Sys::Hostname();
-use HTTP::Body   ();
-use URL::Encode  ();
-use Text::Xslate ();
-use DateTime::Format::HTTP();
 use CGI::Cookie ();
-use File::Basename();
-use IO::Compress::Gzip();
-use Time::HiRes      qw{gettimeofday tv_interval};
-use HTTP::Parser::XS qw{HEADERS_AS_HASHREF};
-use List::Util;
+use List::Util  ();
+use Sub::Util   ();
 use URI();
-use Ref::Util qw{is_coderef is_hashref is_arrayref};
 
 #Grab our custom routes
 use FindBin::libs;
+
 use Trog::Routes::HTML;
 use Trog::Routes::JSON;
 
@@ -32,346 +22,270 @@ use Trog::Log qw{:all};
 use Trog::Log::DBI;
 
 use Trog::Auth;
-use Trog::Utils;
 use Trog::Config;
+
+# Loaded here rather than where it is used, so that the vault key comes out of
+# the environment once, in the parent, before there is a worker to fork -- see
+# Trog::Vault.
+use Trog::Vault;    ## no critic (ProhibitUnusedImports) -- loaded for what it does at load time, as above
 use Trog::Data;
-use Trog::Vars;
-use Trog::FileHandler;
+use Trog::Themes;
+use Trog::Bundle;
 
-# Troglodyne philosophy - simple as possible
+#XXX Return a clone of the routing table ref, because code modifies it later
+my sub _routes ( $data = {} ) {
+    state %routes;
+    return clone( \%routes ) if %routes;
+
+    my $conf = Trog::Config::get();
+    $data = Trog::Data->new($conf) unless $data;
+
+    # Routes in general are going to override earlier, more default ones.
+    # XXX this is probably bad in the case of the specific content-typed routes, they should be mutex
+    my %roots = $data->routes();
+
+    # OpenAPI has no escape for a brace, so such a path would be a template.
+    foreach my $href ( grep { m/[{}]/ } keys(%roots) ) {
+        WARN("Not routing $href: a path with a brace in it cannot be a route");
+        delete $roots{$href};
+    }
 
-# Wrap app to return *our* error handler instead of Plack::Util::run_app's
-my $cur_query = {};
+    # Setup the /secure/... versions for logged in users, except for already secured routes.
+    foreach my $route ( keys(%roots) ) {
+        next if index( $route, '/secure/' ) == 0;
+        $roots{"/secure$route"} = $roots{$route};
+    }
 
-sub app {
-    return eval { _app(@_) } || do {
-        my $env = shift;
-        $env->{'psgi.errors'}->print($@);
+    # It is the responsibility of theme authors to setup /secure routes (other than index)
+    my %themed = Trog::Themes::routes();
 
-        # Redact the stack trace past line 1, it usually has things which should not be shown
-        $cur_query->{message} = $@;
-        $cur_query->{message} =~ s/\n.*//g if $cur_query->{message};
+    %routes                                      = %Trog::Routes::HTML::routes;
+    @routes{ keys(%Trog::Routes::JSON::routes) } = values(%Trog::Routes::JSON::routes);
+    @routes{ keys(%roots) }                      = values(%roots);
+    @routes{ keys(%themed) }                     = values(%themed) if %themed;
+
+    # A page of posts gets the scripts of one, unless its route names its own.
+    foreach my $path ( keys(%routes) ) {
+        my $callback = $routes{$path}{callback} // '';
+        my $name     = ref $callback ? Sub::Util::subname($callback) : $callback;
+        next if exists $routes{$path}{scripts} || !List::Util::any { $_ eq $name } @Trog::Routes::HTML::post_page_callbacks;
+        $routes{$path} = { %Trog::Routes::HTML::post_page_scripts, %{ $routes{$path} } };
+    }
 
-        return _error($cur_query);
+    # Add in global routes, here because they *must* know about all other routes
+    # Also, nobody should ever override these.
+    $routes{'/robots.txt'} = {
+        method   => 'GET',
+        callback => \&robots,
+    };
+
+    # Special 'am I authenticated' route for nginx
+    $routes{'/authenticated'} = {
+        method   => 'GET',
+        nocache  => 1,
+        noindex  => 1,
+        callback => sub {
+            my ($query) = @_;
+            return $query->{tpsgi}->ok($query) if $query->{user};
+            return $query->{tpsgi}->forbidden($query);
+        },
     };
-}
 
-=head2 app()
+    # Heartbeat route
+    $routes{'/status'} = {
+        method   => 'GET',
+        nocache  => 1,
+        noindex  => 1,
+        callback => sub {
+            my ($query) = @_;
+            return $query->{tpsgi}->ok($query);
+        },
+    };
 
-Dispatches requests based on %routes built above.
+    # The Various aliases for directory indices
+    foreach my $index (qw{ / /index.html /index.htm}) {
+        $routes{$index}          = $routes{'/index'} unless exists $routes{$index};
+        $routes{"/secure$index"} = $routes{'/index'} unless exists $routes{"/secure$index"};
+    }
 
-The dispatcher here does *not* do anything with the authn/authz data.  It sets those in the 'user' and 'acls' parameters of the query object passed to routes.
+    return clone( \%routes );
+}
 
-If a path passed is not a defined route (or regex route), but exists as a file under www/, it will be served up immediately.
+# Troglodyne philosophy - simple as possible
 
-=cut
+=head2 build_routes() = HASH
 
-sub _app {
+The OpenAPI 3 document that tPSGI routes by, made from the routing table that
+_routes() returns.  Each route becomes the operation of its method, under its
+path.  The operation's x-tpsgi-callback is the route's callback, wrapped in what
+every tCMS request needs.  C<data> becomes x-tpsgi-data, and C<auth>,
+C<nocache>, C<noindex>, C<nomap>, C<robot_name> and C<totp_exempt> become
+x-tcms-auth and so on, which the callback finds in C<< $query->{dispatcher} >>.
+C<parameters> are OpenAPI parameter objects, and each variable of a template
+that they leave out is a required string.  A route with no method is a GET.
 
-    # Make sure all writes are with the proper permissions, none need know of our love
-    umask 0077;
+The C<default> route is not a path.  The wrapper calls it when there is no
+F<config/setup>.
 
-    INFO("TCMS starting up on PID $MASTER_PID, Worker PID $$");
-    # Start the server timing clock
-    my $start = [gettimeofday];
+=cut
 
-    # Build the routing table
-    state( $conf, $data, %aliases );
+my @tcms_keys = qw{auth nocache noindex nomap robot_name totp_exempt scripts authenticated_scripts};
 
-    $conf //= Trog::Config::get();
-    $data //= Trog::Data->new($conf);
+sub build_routes {
+    my $conf   = Trog::Config::get();
+    my $data   = Trog::Data->new($conf);
     my %routes = %{ _routes($data) };
-    %aliases = $data->aliases() unless %aliases;
-
-    # XXX this is built progressively across the forks, leading to inconsistent behavior.
-    # This should eventually be pre-filled from DB.
-    my %etags;
-
-    # Setup logging
-    log_init();
-    my $requestid = Trog::Utils::uuid();
-    Trog::Log::uuid($requestid);
-
-    # Actually start processing the request
-    my $env = shift;
-
-    # Discard the path used in the log, it's too long and enough 4xx error code = ban
-    return _toolong( { method => $env->{REQUEST_METHOD}, fullpath => '...' } ) if length( $env->{REQUEST_URI} ) > 2048;
-
-    # Various stuff important for logging requests
-    state $domain = $conf->param('general.hostname') || $env->{HTTP_X_FORWARDED_HOST} || $env->{HTTP_HOST} || eval { Sys::Hostname::hostname() };
-    my $path   = $env->{PATH_INFO};
-    my $port   = $env->{HTTP_X_FORWARDED_PORT} // $env->{HTTP_PORT};
-    my $pport  = defined $port ? ":$port" : "";
-    my $scheme = $env->{'psgi.url_scheme'} // 'http';
-    my $method = $env->{REQUEST_METHOD};
-
-    # It's important that we log what the user ACTUALLY requested rather than the rewritten path later on.
-    my $fullpath = "$scheme://$domain$pport$path";
-
-    # sigdie can now "do the right thing"
-    $cur_query = { route => $path, fullpath => $path, method => $method };
-
-    # Set the IP of the request so we can fail2ban
-    $Trog::Log::ip = $env->{HTTP_X_FORWARDED_FOR} || $env->{REMOTE_ADDR};
-
-    # Set the referer & ua to go into DB logs, but not logs in general.
-    # The referer/ua largely has no importance beyond being a proto bug report for log messages.
-    $Trog::Log::DBI::referer = $env->{HTTP_REFERER};
-    $Trog::Log::DBI::ua      = $env->{HTTP_UA};
-
-    # Check eTags.  If we don't know about it, just assume it's good and lazily fill the cache
-    # XXX yes, this allows cache poisoning...but only for logged in users!
-    if ( $env->{HTTP_IF_NONE_MATCH} ) {
-        INFO("$env->{REQUEST_METHOD} 304 $fullpath");
-        return [ 304, [], [''] ] if $env->{HTTP_IF_NONE_MATCH} eq ( $etags{ $env->{REQUEST_URI} } || '' );
-        $etags{ $env->{REQUEST_URI} } = $env->{HTTP_IF_NONE_MATCH} unless exists $etags{ $env->{REQUEST_URI} };
-    }
 
-    # TODO: Actually do something with the language passed to the renderer
-    my $lang = $env->{HTTP_ACCEPT_LANGUAGE};
+    my $default_route = $routes{default}{callback};
 
-    #TODO: Actually do something with the acceptable output formats in the renderer
-    my $accept = $env->{HTTP_ACCEPT};
+    my %paths;
+    foreach my $k ( sort grep { $_ ne 'default' } keys(%routes) ) {
+        my $v = $routes{$k};
 
-    # Figure out if we want compression or not
-    my $alist = $env->{HTTP_ACCEPT_ENCODING} || '';
-    $alist =~ s/\s//g;
-    my @accept_encodings;
-    @accept_encodings = split( /,/, $alist );
-    my $deflate = grep { 'gzip' eq $_ } @accept_encodings;
+        # The bundles that this route's page can link, for a reader and for a
+        # reader who is logged in.
+        my @scripts = @{ $v->{scripts} // [] };
+        Trog::Bundle::declare( \@scripts, [ @scripts, @{ $v->{authenticated_scripts} // [] } ] );
 
-    # NOTE These two parameters are entirely academic, as we don't use ad tracking cookies, but the UTM parameters.
-    # UTMs are actually fully sufficient to get you what you want -- e.g. keywords, audience groups, a/b testing, etc.
-    # and you need to put up cookie consent banners if you bother using tracking cookies, which are horrific UX.
-    #my $no_track = $env->{HTTP_DNT};
-    #my $no_sell_info = $env->{HTTP_SEC_GPC};
+        my $method = lc( $v->{method} // 'GET' );
 
-    # We generally prefer this to be handled at the reverse proxy level.
-    #my $prefer_ssl = $env->{HTTP_UPGRADE_INSECURE_REQUESTS};
+        # FlatFile and the tag index name the callback rather than hold it.
+        my $callback = $v->{callback};
+        next                      unless $callback;
+        $callback = \&{$callback} unless ref $callback;
 
-    my $last_fetch = 0;
-    if ( $env->{HTTP_IF_MODIFIED_SINCE} ) {
-        $last_fetch = DateTime::Format::HTTP->parse_datetime( $env->{HTTP_IF_MODIFIED_SINCE} )->epoch();
-    }
+        #XXX For now we will discard the tPSGI object.  We might want it later.
+        my $cb_wrap = sub {    ## no critic (ProhibitSingleUseLexicalSubs) -- 71 lines, which would overcomplicate build_routes()
+            my ( $tpsgi, $query ) = @_;
 
-    #XXX Don't use statics anything that has a search query
-    # On one hand, I don't want to DOS the disk, but I'd also like some like ?rss...
-    # Should probably turn those into aliases.
-    my $has_query = !!$env->{QUERY_STRING};
+            confess "Cannot determine directory for logs!" unless $tpsgi->{log_dir};
 
-    my $query = {};
-    $query = URL::Encode::url_params_mixed( $env->{QUERY_STRING} ) if $env->{QUERY_STRING};
+            # Make sure the tCMS logs live in the same dir as the tpsgi logs.
+            log_init( "$tpsgi->{log_dir}/tpsgi.log", $tpsgi->{verbose} ? 'debug' : 'info', $tpsgi->{loggers} );
 
-    #Actually parse the POSTDATA and dump it into the QUERY object if this is a POST
-    if ( $env->{REQUEST_METHOD} eq 'POST' ) {
+            # Let's open up our default route if needed before we bother thinking any harder
+            return $default_route->($query) unless -f "config/setup";    ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched
 
-        my $body = HTTP::Body->new( $env->{CONTENT_TYPE}, $env->{CONTENT_LENGTH} );
-        while ( $env->{'psgi.input'}->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
-            $body->add($buf);
-        }
+            # Set the urchin parameters if necessary.
+            %$Trog::Log::DBI::urchin = map { $_ => delete $query->{$_} } qw{utm_source utm_medium utm_campaign utm_term utm_content};
 
-        @$query{ keys( %{ $body->param } ) }  = values( %{ $body->param } );
-        @$query{ keys( %{ $body->upload } ) } = values( %{ $body->upload } );
-    }
+            # Set the IP of the request so we can fail2ban
+            $Trog::Log::ip = $query->{ip};
+
+            # Set the referer & ua to go into DB logs, but not logs in general.
+            # The referer/ua largely has no importance beyond being a proto bug report for log messages.
+            $Trog::Log::DBI::referer = $query->{referer};
+            $Trog::Log::DBI::ua      = $query->{ua};
+
+            # Figure out if we have a logged in user, so we can serve them user-specific files
+            my $cookies = {};
+            $cookies = CGI::Cookie->parse( $query->{cookies} ) if $query->{cookies};
 
-    # It's mod_rewrite!
-    $path = '/index' if $path eq '/';
-
-    #XXX this is hardcoded in browsers, so just rewrite the path
-    $path = '/img/icon/favicon.ico' if $path eq '/favicon.ico';
-
-    # Translate alias paths into their actual path
-    $path = $aliases{$path} if exists $aliases{$path};
-
-    # Collapse multiple slashes in the path
-    $path =~ s/[\/]+/\//g;
-
-    #Handle regex/capture routes
-    if ( !exists $routes{$path} ) {
-        my @captures;
-
-        # XXX maybe this should all just go into $query?
-        # TODO can optimize by having separate hashes for capture/non-capture routes
-        foreach my $pattern ( keys(%routes) ) {
-            @captures = $path =~ m/^$pattern$/;
-            if (@captures) {
-                $path = $pattern;
-                foreach my $field ( @{ $routes{$path}{captures} } ) {
-                    $routes{$path}{data} //= {};
-                    $routes{$path}{data}{$field} = shift @captures;
-                }
-                last;
+            my $active_user = '';
+            $Trog::Log::user = 'nobody';
+            if ( exists $cookies->{tcmslogin} ) {
+                $active_user     = Trog::Auth::session2user( $cookies->{tcmslogin}->value );
+                $Trog::Log::user = $active_user if $active_user;
             }
-        }
-    }
 
-    # Set the 'data' in the query that the route specifically overrides, which we are also using for the catpured data
-    # This also means you have to validate both of them via parameters if you set that up.
-    @{$query}{ keys( %{ $routes{$path}{'data'} } ) } = values( %{ $routes{$path}{'data'} } ) if ref $routes{$path}{'data'} eq 'HASH' && %{ $routes{$path}{'data'} };
-
-    # Ensure any short-circuit routes can log the request, and return the server-timing headers properly
-    $query->{method}   = $method;
-    $query->{route}    = $path;
-    $query->{fullpath} = $fullpath;
-    $query->{start}    = $start;
-
-    # Handle HTTP range/streaming requests
-    my $range = $env->{HTTP_RANGE} || "bytes=0-" if $env->{HTTP_RANGE} || $env->{HTTP_IF_RANGE};
-
-    my $streaming = $env->{'psgi.streaming'};
-    $query->{streaming} = $streaming;
-
-    my @ranges;
-    if ($range) {
-        $range =~ s/bytes=//g;
-        push(
-            @ranges,
-            map {
-                [ split( /-/, $_ ) ];
-
-                #$tuples[1] //= $tuples[0] + $Trog::Vars::CHUNK_SIZE;
-                #\@tuples
-            } split( /,/, $range )
-        );
-    }
+            # Make sure TPSGI can log the user
+            $tpsgi->{user} = $active_user;
 
-    # If it's a file, just serve it
-    return Trog::FileHandler::serve( $fullpath, "www/$path", $start, $streaming, \@ranges, $last_fetch, $deflate ) if -f "www/$path";
+            # Enrich the query with tcms specific foo
+            $query->{user_acls} = [];
+            $query->{user_acls} = Trog::Auth::acls4user($active_user) // [] if $active_user;
 
-    # Figure out if we have a logged in user, so we can serve them user-specific files
-    my $cookies = {};
-    if ( $env->{HTTP_COOKIE} ) {
-        $cookies = CGI::Cookie->parse( $env->{HTTP_COOKIE} );
-    }
+            # Grab the list of ACLs we want to add to a post, if any.
+            $query->{acls} = [ $query->{acls} ] if ( $query->{acls} && ref $query->{acls} ne 'ARRAY' );
 
-    my $active_user = '';
-    $Trog::Log::user = 'nobody';
-    if ( exists $cookies->{tcmslogin} ) {
-        $active_user     = Trog::Auth::session2user( $cookies->{tcmslogin}->value );
-        $Trog::Log::user = $active_user if $active_user;
-    }
+            # Filter out passed ACLs which are naughty
+            my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
+            @{ $query->{acls} } = grep { $_ ne 'admin' } @{ $query->{acls} } unless $is_admin;
 
-    return Trog::FileHandler::serve( $fullpath, "totp/$path", $start, $streaming, \@ranges, $last_fetch, $deflate ) if -f "totp/$path" && $active_user;
+            $query->{user}         = $active_user;
+            $query->{body}         = '';
+            $query->{social_meta}  = 1;
+            $query->{primary_post} = {};
+            $query->{nocache}      = $v->{nocache};
 
-    # Now that we have firmed up the actual routing, let's validate.
-    return _forbidden($query) if exists $routes{$path}{auth} && !$active_user;
-    return _notfound($query) unless exists $routes{$path} && ref $routes{$path} eq 'HASH' && keys( %{ $routes{$path} } );
-    return _badrequest($query) unless grep { $env->{REQUEST_METHOD} eq $_ } ( $routes{$path}{method} || '', 'HEAD' );
+            # Some routes may just need to do serve()
+            $query->{tpsgi} = $tpsgi;
 
-    # Disallow any paths that are naughty ( starman auto-removes .. up-traversal)
-    if ( index( $path, '/templates' ) == 0 || index( $path, '/statics' ) == 0 || $path =~ m/.*(\.psgi|\.pm)$/i ) {
-        return _forbidden($query);
-    }
+            # Redirecting somewhere naughty not allow
+            $query->{to} = URI->new( $query->{to} // '' )->path() || $query->{to} if $query->{to};
 
-    # Set the urchin parameters if necessary.
-    %$Trog::Log::DBI::urchin = map { $_ => delete $query->{$_} } qw{utm_source utm_medium utm_campaign utm_term utm_content};
+            # Now that we have firmed up the actual routing, let's validate.
+            return $tpsgi->forbidden($query) if exists $query->{dispatcher}{'x-tcms-auth'} && !$active_user;
 
-    # Now that we've parsed the query and know where we want to go, we should murder everything the route does not explicitly want, and validate what it does
-    my $parameters = $routes{$path}{parameters};
-    if ($parameters) {
-        die "invalid route definition for $path: bad parameters" unless is_hashref($parameters);
-        my @known_params = keys(%$parameters);
-        for my $param (@known_params) {
-            die "Invalid route definition for $path: parameter $param must correspond to a validation CODEREF." unless is_coderef( $parameters->{$param} );
+            if ( needs_enrolment( $active_user, $query->{dispatcher} ) ) {
+                INFO("$active_user has no TOTP enrolment; sending them to /totp");
+                return $tpsgi->see_also('/totp');
+            }
 
-            # A missing parameter is not necessarily a problem.
-            next unless $query->{$param};
+            return $callback->($query);
+        };
 
-            # But if we have it, and it's bad, nack it, so that scanners get fail2banned.
-            DEBUG("Rejected $fullpath for bad query param $param");
-            return _badrequest($query) unless $parameters->{$param}->( $query->{$param} );
+        my @parameters = @{ $v->{parameters} // [] };
+        foreach my $variable ( $k =~ m/\{([^{}]+)\}/g ) {
+            next if List::Util::any { $_->{in} eq 'path' && $_->{name} eq $variable } @parameters;
+            push( @parameters, { name => $variable, in => 'path', required => true, schema => { type => 'string' } } );
         }
 
-        # Smack down passing of unnecessary fields
-        foreach my $field ( keys(%$query) ) {
-            next if List::Util::any { $field eq $_ } @known_params;
-            next if List::Util::any { $field eq $_ } qw{start route streaming method fullpath};
-            DEBUG("Rejected $fullpath for query param $field");
-            return _badrequest($query);
-        }
+        $paths{$k}{$method} = {
+            'x-tpsgi-callback' => $cb_wrap,
+            ( $v->{data} ? ( 'x-tpsgi-data' => $v->{data} ) : () ),
+            ( map { ( "x-tcms-$_" => $v->{$_} ) } grep { exists $v->{$_} } @tcms_keys ),
+            ( @parameters ? ( parameters => \@parameters ) : () ),
+            responses => { default => { description => 'The page, or an error page' } },
+        };
     }
 
-    # Let's open up our default route before we bother thinking about routing any harder
-    return $routes{default}{callback}->($query) unless -f "config/setup";
+    return (
+        openapi => '3.0.3',
+        info    => { title => 'tCMS', version => '1' },
+        paths   => \%paths,
+    );
+}
 
-    $query->{user_acls} = [];
-    $query->{user_acls} = Trog::Auth::acls4user($active_user) // [] if $active_user;
+=head2 needs_enrolment($user, $dispatcher) = BOOL
 
-    # Grab the list of ACLs we want to add to a post, if any.
-    $query->{acls} = [ $query->{acls} ] if ( $query->{acls} && ref $query->{acls} ne 'ARRAY' );
+Whether this request should be turned around and sent to /totp.
 
-    # Filter out passed ACLs which are naughty
-    my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
-    @{ $query->{acls} } = grep { $_ ne 'admin' } @{ $query->{acls} } unless $is_admin;
+Two factors or nothing.  A login is what gets you to the enrollment page -- the QR
+is the shared secret, so it cannot be handed to whoever asks for it -- which
+leaves a window where somebody is logged in and has no second factor yet.  This
+is what makes that window one page wide: every route a login can reach, and no
+route a logged out visitor can, is refused until they have enrolled.
 
-    # If we have a static render, just use it instead (These will ALWAYS be correct, data saves invalidate this)
-    # TODO: make this key on admin INSTEAD of active user when we add non-admin users.
-    if ( !$active_user && !$has_query ) {
-        return _static( $fullpath, "$path.z", $start, $streaming ) if -f "www/statics/$path.z" && $deflate;
-        return _static( $fullpath, $path,     $start, $streaming ) if -f "www/statics/$path";
-    }
+The enrollment page and the QR on it say so themselves, with totp_exempt, because
+the exemption belongs next to the route rather than in a list over here that the
+routing table knows nothing about.  $dispatcher is the operation that
+build_routes() made, so it holds them as x-tcms-auth and x-tcms-totp_exempt.
 
-    $query->{deflate} = $deflate;
-    $query->{user}    = $active_user;
-
-    #Set various things we don't want overridden
-    $query->{body}         = '';
-    $query->{dnt}          = $env->{HTTP_DNT};
-    $query->{user}         = $active_user;
-    $query->{domain}       = $domain;
-    $query->{route}        = $path;
-    $query->{scheme}       = $scheme;
-    $query->{social_meta}  = 1;
-    $query->{primary_post} = {};
-    $query->{has_query}    = $has_query;
-    $query->{port}         = $port;
-    $query->{lang}         = $lang;
-    $query->{accept}       = $accept;
-
-    # Redirecting somewhere naughty not allow
-    $query->{to} = URI->new( $query->{to} // '' )->path() || $query->{to} if $query->{to};
-
-    DEBUG("DISPATCH $path to $routes{$path}{callback}");
-
-    #XXX there is a trick to now use strict refs, but I don't remember it right at the moment
-    {
-        no strict 'refs';
-        my $output = $routes{$path}{callback}->($query);
-        die "$path returned no data!" unless ref $output eq 'ARRAY' && @$output == 3;
-
-        my $pport = defined $query->{port} ? ":$query->{port}" : "";
-        INFO("$env->{REQUEST_METHOD} $output->[0] $fullpath");
-
-        # Append server-timing headers if they aren't present
-        my $tot = tv_interval($start) * 1000;
-        push( @{ $output->[1] }, 'Server-Timing' => "app;dur=$tot" ) unless List::Util::any { $_ eq 'Server-Timing' } @{ $output->[1] };
-        return $output;
-    }
-}
+=cut
 
-#XXX Return a clone of the routing table ref, because code modifies it later
-sub _routes ( $data = {} ) {
-    state %routes;
-    return clone( \%routes ) if %routes;
+sub needs_enrolment ( $user, $dispatcher ) {
+    return 0 unless $user;
+    return 0 if !$dispatcher || !$dispatcher->{'x-tcms-auth'} || $dispatcher->{'x-tcms-totp_exempt'};
+    return Trog::Auth::has_totp($user) ? 0 : 1;
+}
 
-    if ( !$data ) {
-        my $conf = Trog::Config::get();
-        $data = Trog::Data->new($conf);
-    }
-    my %roots = $data->routes();
-    %routes                                      = %Trog::Routes::HTML::routes;
-    @routes{ keys(%Trog::Routes::JSON::routes) } = values(%Trog::Routes::JSON::routes);
-    @routes{ keys(%roots) }                      = values(%roots);
+# Override the generic error handler to look spiffy
+sub generic_route ( $rname, $code, $title, $query ) {
+    $query->{code} = $code;
+    $query->{route} //= $rname;
+    $query->{title}    = $title;
+    $query->{template} = "$rname.tx";
+    return Trog::Routes::HTML::index($query);
+}
 
-    # Add in global routes, here because they *must* know about all other routes
-    # Also, nobody should ever override these.
-    $routes{'/robots.txt'} = {
-        method   => 'GET',
-        callback => \&robots,
-    };
+our %openapi = build_routes();
+our %aliases = aliases();
 
-    return clone( \%routes );
+sub aliases {
+    my $conf = Trog::Config::get();
+    my $data = Trog::Data->new($conf);
+    return $data->aliases();
 }
 
 =head2 robots
@@ -382,12 +296,17 @@ This is a "special" route as it needs to know about all the routes in order to d
 
 =cut
 
+# TODO anytime that the routing table changes, we need to invalidate the cache.
 sub robots ($query) {
     state $etag = "robots-" . time();
     my $routes = _routes();
 
-    # If there's a 'capture' route, we need to format it correctly.
-    state @banned = map { exists $routes->{$_}{robot_name} ? $routes->{$_}{robot_name} : $_ } grep { $routes->{$_}{noindex} } sort keys(%$routes);
+    # A template's variables can be anything, which robots.txt spells as *.
+    state @banned = map {
+        my $robot_name = $routes->{$_}{robot_name} // $_;
+        $robot_name =~ s/\{[^{}]*\}/*/g;
+        $robot_name
+    } grep { $routes->{$_}{noindex} } sort keys(%$routes);
 
     return Trog::Renderer->render(
         contenttype => 'text/plain',
@@ -401,95 +320,4 @@ sub robots ($query) {
     );
 }
 
-sub _generic ( $type, $query ) {
-    return _static( "$type.z", $query->{start}, $query->{streaming} ) if -f "www/statics/$type.z";
-    return _static( $type,     $query->{start}, $query->{streaming} ) if -f "www/statics/$type";
-    my %lookup = (
-        notfound   => \&Trog::Routes::HTML::notfound,
-        forbidden  => \&Trog::Routes::HTML::forbidden,
-        badrequest => \&Trog::Routes::HTML::badrequest,
-        toolong    => \&Trog::Routes::HTML::toolong,
-        error      => \&Trog::Routes::HTML::error,
-    );
-    return $lookup{$type}->($query);
-}
-
-sub _notfound ($query) {
-    INFO("$query->{method} 404 $query->{fullpath}");
-    return _generic( 'notfound', $query );
-}
-
-sub _forbidden ($query) {
-    INFO("$query->{method} 403 $query->{fullpath}");
-    return _generic( 'forbidden', $query );
-}
-
-sub _badrequest ($query) {
-    INFO("$query->{method} 400 $query->{fullpath}");
-    return _generic( 'badrequest', $query );
-}
-
-sub _toolong ($query) {
-    INFO("$query->{method} 419 $query->{fullpath}");
-    return _generic( 'toolong', {} );
-}
-
-sub _error ($query) {
-    $query->{method}   //= "UNKNOWN";
-    $query->{fullpath} //= $query->{route} // '/?';
-    INFO("$query->{method} 500 $query->{fullpath}");
-    return _generic( 'error', $query );
-}
-
-sub _static ( $fullpath, $path, $start, $streaming, $last_fetch = 0 ) {
-
-    DEBUG("Rendering static for $path");
-
-    # XXX because of psgi I can't just vomit the file directly
-    if ( open( my $fh, '<', "www/statics/$path" ) ) {
-        my $headers = '';
-
-        # NOTE: this is relying on while advancing the file pointer
-        while (<$fh>) {
-            last if $_ eq "\n";
-            $headers .= $_;
-        }
-        my ( undef, undef, $status, undef, $headers_parsed ) = HTTP::Parser::XS::parse_http_response( "$headers\n", HEADERS_AS_HASHREF );
-
-        #XXX need to put this into the file itself
-        my $mt         = ( stat($fh) )[9];
-        my @gm         = gmtime($mt);
-        my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm );
-        my $code       = $mt > $last_fetch ? $status : 304;
-        $headers_parsed->{"Last-Modified"} = $now_string;
-
-        # Append server-timing headers
-        my $tot = tv_interval($start) * 1000;
-        $headers_parsed->{'Server-Timing'} = "static;dur=$tot";
-
-        #XXX uwsgi just opens the file *again* when we already have a filehandle if it has a path.
-        # starman by comparison doesn't violate the principle of least astonishment here.
-        # This is probably a performance optimization, but makes the kind of micromanagement I need to do inconvenient.
-        # As such, we will just return a stream.
-        INFO("GET 200 $fullpath");
-
-        return sub {
-            my $responder = shift;
-
-            #push(@headers, 'Content-Length' => $sz);
-            my $writer = $responder->( [ $code, [%$headers_parsed] ] );
-            while ( $fh->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
-                $writer->write($buf);
-            }
-            close $fh;
-            $writer->close;
-          }
-          if $streaming;
-
-        return [ $code, [%$headers_parsed], $fh ];
-    }
-    INFO("GET 403 $fullpath");
-    return [ 403, [ 'Content-Type' => $Trog::Vars::content_types{text} ], ["STAY OUT YOU RED MENACE"] ];
-}
-
 1;

lib/Theme.pm

@@ -1,13 +1,55 @@
 package Theme;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-no warnings 'experimental';
-use feature qw{signatures};
+=head1 Theme
 
-# An example of the bare minimum your themes' routes.pm need.
-# Copy and alter things below as needed.
+An example of the bare minimum your themes' routes.pm need.
+Copy and alter things below as needed.
+
+Themes are loaded by Trog::Themes::routes(), which requires the active theme's
+routes.pm and expects it to have populated the package variables below, along
+with %Theme::routes if the theme wants routes of its own.
+
+Everything here is optional -- Trog::Routes::HTML falls back to generic tCMS
+defaults for anything a theme leaves unset -- but a site that sets none of it
+will identify itself as "Another tCMS Site" to search engines and social media.
+
+=head2 VARIABLES
+
+=over 4
+
+=item $default_title
+
+Fallback <title> for pages which have no post of their own to name them.
+
+=item $default_image
+
+The image handed to social media scrapers as the site's preview, relative to
+the theme directory.
+
+=item $display_name
+
+What the site calls itself, e.g. in the og:site_name meta tag.
+
+=item $description
+
+Fallback meta description, used when the page has no post body to summarize.
+
+=item $default_tags
+
+Comma separated keywords for the meta keywords tag.
+
+=item $twitter_account, $fb_app_id
+
+Set these if you want the relevant twitter: and fb: meta tags emitted.
+Left empty, HTML::SocialMeta is handed nothing to put in them.
+
+=back
+
+=cut
 
 our $default_title = 'tCMS';
 our $default_image = 'img/icon/favicon-48.png';

lib/Trog/Auth.pm

@@ -1,15 +1,14 @@
 package Trog::Auth;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use FindBin::libs;
 
 use Ref::Util qw{is_arrayref};
 use Digest::SHA 'sha256';
+use Crypt::Argon2 qw{argon2id_pass argon2id_verify argon2_needs_rehash};
 use Trog::TOTP;
 use Imager::QRCode;
 
@@ -19,6 +18,13 @@ use Trog::Config;
 use Trog::SQLite;
 use Trog::Data;
 
+# Ensure the db schema is OK, and give us a handle
+my sub dbh {
+    my $file   = 'schema/auth.schema';
+    my $dbname = "config/auth.db";
+    return Trog::SQLite::dbh( $file, $dbname );
+}
+
 =head1 Trog::Auth
 
 An SQLite3 authdb.
@@ -38,7 +44,7 @@ Returns empty string on no active session.
 =cut
 
 sub session2user ($sessid) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT name FROM sess_user WHERE session=?", { Slice => {} }, $sessid );
     return '' unless ref $rows eq 'ARRAY' && @$rows;
     return $rows->[0]->{name};
@@ -52,7 +58,7 @@ If the user has an active session, things like password reset requests should fa
 =cut
 
 sub user_has_session ($user) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT session FROM sess_user WHERE name=?", { Slice => {} }, $user );
     return 0 unless ref $rows eq 'ARRAY' && @$rows;
     return 1;
@@ -65,25 +71,12 @@ Return whether the user exists at all.
 =cut
 
 sub user_exists ($user) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT name FROM user WHERE name=?", { Slice => {} }, $user );
     return 0 unless ref $rows eq 'ARRAY' && @$rows;
     return 1;
 }
 
-=head2 primary_user
-
-Returns the oldest user with the admin ACL.
-
-=cut
-
-sub primary_user {
-    my $dbh  = _dbh();
-    my $rows = $dbh->selectall_arrayref( "SELECT username FROM user_acl WHERE acl='admin' LIMIT 1", { Slice => {} } );
-    return 0 unless ref $rows eq 'ARRAY' && @$rows;
-    return $rows->[0]{username};
-}
-
 =head2 get_existing_user_data
 
 Fetch existing settings for a user.
@@ -91,7 +84,7 @@ Fetch existing settings for a user.
 =cut
 
 sub get_existing_user_data ($user) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT hash, salt, totp_secret, display_name, contact_email FROM user WHERE name=?", { Slice => {} }, $user );
     return ( undef, undef, undef ) unless ref $rows eq 'ARRAY' && @$rows;
     return ( $rows->[0]{hash}, $rows->[0]{salt}, $rows->[0]{totp_secret}, $rows->[0]{display_name}, $rows->[0]{contact_email} );
@@ -104,21 +97,21 @@ Return the associated contact email for the user.
 =cut
 
 sub email4user ($user) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT contact_email FROM user WHERE name=?", { Slice => {} }, $user );
     return '' unless ref $rows eq 'ARRAY' && @$rows;
     return $rows->[0]{contact_email};
 }
 
 sub display2username ($display_name) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT name FROM user WHERE display_name=?", { Slice => {} }, $display_name );
     return '' unless ref $rows eq 'ARRAY' && @$rows;
     return $rows->[0]{name};
 }
 
 sub username2display ($name) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT display_name FROM user WHERE name=?", { Slice => {} }, $name );
     return '' unless ref $rows eq 'ARRAY' && @$rows;
     return $rows->[0]{display_name};
@@ -136,10 +129,10 @@ sub username2classname ($name) {
 
     # Users are always self-authored, you see
 
-    my $user_obj = List::Util::first { ( $_->{user} || '' ) eq $name } @userposts;
-    my $NNname   = $user_obj->{id} || '';
-    $NNname =~ tr/-/_/;
-    return "a_$NNname";
+    my $user_obj  = List::Util::first { ( $_->{user} || '' ) eq $name } @userposts;
+    my $classname = $user_obj->{id} || '';
+    $classname =~ tr/-/_/;
+    return "a_$classname";
 }
 
 =head2 acls4user(STRING username) = ARRAYREF
@@ -152,7 +145,7 @@ The 'admin' ACL is the only special one, as it allows for authoring posts, confi
 =cut
 
 sub acls4user ($username) {
-    my $dbh     = _dbh();
+    my $dbh     = dbh();
     my $records = $dbh->selectall_arrayref( "SELECT acl FROM user_acl WHERE username = ?", { Slice => {} }, $username );
 
     return () unless ref $records eq 'ARRAY' && @$records;
@@ -160,16 +153,40 @@ sub acls4user ($username) {
     return \@acls;
 }
 
+my sub _totp {
+    state $totp;
+    if ( !$totp ) {
+        $totp = Trog::TOTP->new();
+        die "Cannot instantiate TOTP client!" unless $totp;
+        $totp->{DEBUG} = 1 if is_debug();
+    }
+    return $totp;
+}
+
 =head2 totp(user, domain)
 
 Enable TOTP 2fa for the specified user, or if already enabled return the existing info.
 Returns a QR code and URI for pasting into authenticator apps.
 
+Refuses a user or domain that would not be safe as a filename, as the QR code
+is written to totp/<user>@<domain>.bmp.
+
 =cut
 
 sub totp ( $user, $domain ) {
+
+    # The QR is written to totp/$user@$domain.bmp, so both halves end up in a
+    # path.  Nothing constrains a username -- tcms-useradd will take whatever
+    # it is given -- so one containing a slash or .. would otherwise write
+    # outside totp/ entirely.  Same whitelist Trog::DataSource::Virt uses for
+    # guest names.
+    my ($safe_user)   = ( $user   // '' ) =~ m/^([\w.-]+)$/;
+    my ($safe_domain) = ( $domain // '' ) =~ m/^([\w.-]+)$/;
+    return ( undef, undef, 1, "Refusing to build a TOTP QR for unsafe username '" . ( $user // '' ) . "'." ) unless $safe_user;
+    return ( undef, undef, 1, "Refusing to build a TOTP QR for unsafe domain '" . ( $domain // '' ) . "'." ) unless $safe_domain;
+
     my $totp = _totp();
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
 
     my $failure = 0;
     my $message = "TOTP Secret generated successfully.";
@@ -200,52 +217,200 @@ sub totp ( $user, $domain ) {
         secret => $secret,
     );
 
-    my $qr = "$user\@$domain.bmp";
+    my $qr = "$safe_user\@$safe_domain.bmp";
     if ($secret_is_generated) {
 
-        # Liquidate the QR code if it's already there
-        unlink "totp/$qr" if -f "totp/$qr";
+        # Liquidate the QR code if it's already there.  Unconditional: unlink
+        # returns 0 for a file that was never there, it does not warn or die.
+        unlink "totp/$qr";
 
-        $dbh->do( "UPDATE user SET totp_secret=? WHERE name=?", undef, $secret, $user ) or return ( undef, undef, 1, "Failed to store TOTP secret." );
+        eval { $dbh->do( "UPDATE user SET totp_secret=? WHERE name=?", undef, $secret, $user ); 1 } or do {
+            WARN("Could not store the TOTP secret of $user: $@");
+            return ( undef, undef, 1, "Failed to store TOTP secret." );
+        };
     }
 
-    # This is subsequently served via authenticated _serve() in TCMS.pm
-    if ( !-f "totp/$qr" ) {
-        my $qrcode = Imager::QRCode->new(
-            size          => 4,
-            margin        => 3,
-            level         => 'L',
-            casesensitive => 1,
-            lightcolor    => Imager::Color->new( 255, 255, 255 ),
-            darkcolor     => Imager::Color->new( 0,   0,   0 ),
-        );
+    # This is subsequently served via authenticated _serve() in TCMS.pm.
+    # Plotted every time rather than only when the file is missing: the QR is a
+    # pure function of the secret, so rewriting it produces the same bytes, and
+    # the file was just unlinked above whenever the secret changed.
+    my $qrcode = Imager::QRCode->new(
+        size          => 4,
+        margin        => 3,
+        level         => 'L',
+        casesensitive => 1,
+        lightcolor    => Imager::Color->new( 255, 255, 255 ),
+        darkcolor     => Imager::Color->new( 0,   0,   0 ),
+    );
 
-        my $img = $qrcode->plot($uri);
-        $img->write( file => "totp/$qr", type => "bmp" ) or return ( undef, undef, 1, "Could not write totp/$qr: " . $img->errstr );
-    }
+    my $img = $qrcode->plot($uri);
+    $img->write( file => "totp/$qr", type => "bmp" ) or return ( undef, undef, 1, "Could not write totp/$qr: " . $img->errstr );
     return ( $uri, $qr, $failure, $message, $totp );
 }
 
-sub _totp {
-    state $totp;
-    if ( !$totp ) {
-        $totp = Trog::TOTP->new();
-        die "Cannot instantiate TOTP client!" unless $totp;
-        $totp->{DEBUG} = 1 if is_debug();
+=head2 has_totp(user) = BOOL
+
+Whether this user has enrolled in TOTP yet.
+
+Everybody has to, so this is the question the dispatcher asks on the way to
+every page a login can reach: a user who has not is sent to /totp and can go
+nowhere else until they have.
+
+There is no way to turn it back off.  Losing an authenticator is not a reason to
+stop having a second factor, and the answer to it is bin/totp, which re-reads a
+user their enrollment out of band -- the secret is still in the database, so it
+is the same enrollment rather than a new one.
+
+=cut
+
+sub has_totp ($user) {
+    my $dbh  = dbh();
+    my $rows = $dbh->selectall_arrayref( "SELECT totp_secret FROM user WHERE name=?", { Slice => {} }, $user );
+    return 0 unless ref $rows eq 'ARRAY' && @$rows;
+    return $rows->[0]{totp_secret} ? 1 : 0;
+}
+
+=head2 spend_totp(user, code) = ($ok, $why)
+
+Check a TOTP code and spend it.  A code that has been spent, or that is older
+than one this user has already spent, is refused however valid the arithmetic
+says it is.
+
+This is the difference between a second factor at the door and a second factor
+that authorizes a particular thing.  A code read over somebody's shoulder, or
+left in a proxy log, is good for the rest of its window otherwise -- and what it
+would be good for is releasing a stored password, which is not a window anybody
+should be relaxed about.
+
+The cost is that a code is worth one action.  Logging in and then immediately
+asking for a secret means waiting for the next one, which is thirty seconds and
+is the point.
+
+Tolerance is one step either way, for clocks that disagree a little.  It used to
+be three, which was ninety seconds of a code staying good, and there is no
+reason for that once a code cannot be used twice anyway.
+
+=cut
+
+our $totp_tolerance = 1;
+our $totp_period    = 30;
+our $totp_digits    = 6;
+
+sub spend_totp ( $user, $code ) {
+    return ( 0, 'no code given' ) unless defined $code && $code =~ m/^\d{$totp_digits}$/;
+
+    my $dbh    = dbh();
+    my $rows   = $dbh->selectall_arrayref( "SELECT totp_secret FROM user WHERE name=?", { Slice => {} }, $user );
+    my $secret = ref $rows eq 'ARRAY' && @$rows ? $rows->[0]{totp_secret} : undef;
+    return ( 0, 'this user has no second factor enrolled' ) unless $secret;
+
+    # Forced in rather than passed: expected_totp_code reads the object, and
+    # the object generates a secret of its own if it has not got one.
+    my $totp = _totp();
+    $totp->{secret} = $secret;
+    $totp->{period} = $totp_period;
+    $totp->{digits} = $totp_digits;
+
+    my $now = time();
+    my $matched;
+    foreach my $offset ( -$totp_tolerance .. $totp_tolerance ) {
+        my $when = $now + ( $offset * $totp_period );
+        next unless $totp->expected_totp_code($when) eq $code;
+        $matched = int( $when / $totp_period );
+        last;
     }
-    return $totp;
+
+    if ( !defined $matched ) {
+        log_event( 'totp_failure', $user );
+        return ( 0, 'that code is not right' );
+    }
+
+    my $spent = $dbh->selectall_arrayref( "SELECT step FROM totp_spent WHERE username=?", { Slice => {} }, $user );
+    my $last  = ref $spent eq 'ARRAY' && @$spent ? $spent->[0]{step} : 0;
+    if ( $matched <= $last ) {
+        log_event( 'totp_replay', $user );
+        return ( 0, 'that code has already been used; wait for the next one' );
+    }
+
+    eval { $dbh->do( "INSERT OR REPLACE INTO totp_spent (username, step) VALUES (?,?)", undef, $user, $matched ); 1 } or do {
+        WARN("Could not record the TOTP step of $user as spent: $@");
+        return ( 0, 'could not record the code as used, so it is refused' );
+    };
+
+    return ( 1, '' );
 }
 
-=head2 clear_totp
+=head2 check_password(user, pass) = BOOL
+
+Whether this is the user's password, upgrading how it is stored if it is.
 
-Clear the totp codes for provided user
+Passwords were kept as a single unstretched sha256 of the password and a salt,
+which is a hash built to be fast over a thing built to be guessed: a commodity
+GPU walks a list of them at billions a second.  They are Argon2id now, which is
+built to be slow and to want memory, so the same list costs real hardware and
+real time.
+
+Both live in the same column.  An Argon2 hash says what it is in its first few
+characters, so a row that does not is the old kind: it is checked the old way,
+and then, having just been handed a correct password in plaintext for the only
+moment anyone ever will be, rewritten as the new kind.  Nobody is logged out and
+nobody has to be told, and the old hashes leave as their owners come back.
+
+The same rewrite happens when the parameters here are raised, which is what
+makes raising them later a one-line change rather than a migration.
 
 =cut
 
-sub clear_totp ($user) {
-    my $dbh = _dbh();
-    my $res = $dbh->do( "UPDATE user SET totp_secret=null WHERE name=?", undef, $user ) or die "Could not clear user TOTP secrets";
-    return !!$res;
+# OWASP's minimum acceptable Argon2id configuration.  Deliberately not their
+# generous one: /auth takes a password from anybody who asks, so what is on the
+# other side of it is a memory allocation an unauthenticated request can ask
+# for, times however many workers are listening.
+our $argon2_time    = 2;
+our $argon2_memory  = '19456k';
+our $argon2_lanes   = 1;
+our $argon2_tag     = 32;
+our $argon2_saltlen = 16;
+
+# The hash and the salt that goes with it.  Argon2 carries the salt in its own
+# encoding as well; the column keeps it because the rows which have not been
+# upgraded yet are still using it for what it was for.
+my sub hash_password ($pass) {
+    my $salt = Trog::Utils::uuid();
+    $salt = substr( $salt, 0, $argon2_saltlen );
+    return ( argon2id_pass( $pass, $salt, $argon2_time, $argon2_memory, $argon2_lanes, $argon2_tag ), $salt );
+}
+
+my sub store_password ( $user, $pass ) {
+    my ( $hash, $salt ) = hash_password($pass);
+    my $dbh = dbh();
+    $dbh->do( "UPDATE user SET hash=?, salt=? WHERE name=?", undef, $hash, $salt, $user );
+    return 1;
+}
+
+sub check_password ( $user, $pass ) {
+    return 0 unless $pass;
+
+    my $dbh  = dbh();
+    my $rows = $dbh->selectall_arrayref( "SELECT hash, salt FROM user WHERE name = ?", { Slice => {} }, $user );
+    return 0 unless ref $rows eq 'ARRAY' && @$rows;
+
+    my ( $hash, $salt ) = ( $rows->[0]{hash}, $rows->[0]{salt} );
+    return 0 unless $hash;
+
+    if ( index( $hash, '$argon2' ) == 0 ) {
+        return 0 unless eval { argon2id_verify( $hash, $pass ) };
+
+        # Cheap, and it is the only time we hold the password, so it is the only
+        # time the cost of a stronger hash can be paid.
+        store_password( $user, $pass )
+          if argon2_needs_rehash( $hash, 'argon2id', $argon2_time, $argon2_memory, $argon2_lanes, $argon2_tag, $argon2_saltlen );
+        return 1;
+    }
+
+    return 0 unless sha256( $pass . ( $salt // '' ) ) eq $hash;
+    INFO("Upgrading the stored password for $user from sha256 to argon2id");
+    store_password( $user, $pass );
+    return 1;
 }
 
 =head2 mksession(user, pass, token) = STRING
@@ -256,38 +421,35 @@ Returns a session ID, or blank string in the event the user does not exist or in
 
 =cut
 
-sub mksession ( $user, $pass, $token ) {
-    my $dbh  = _dbh();
-    my $totp = _totp();
+sub mksession ( $user, $pass, $token, $ip_addr = '' ) {
+    my $dbh = dbh();
 
-    # Check the password
-    my $records = $dbh->selectall_arrayref( "SELECT salt FROM user WHERE name = ?", { Slice => {} }, $user );
-    return '' unless ref $records eq 'ARRAY' && @$records;
-    my $salt   = $records->[0]->{salt};
-    my $hash   = sha256( $pass . $salt );
-    my $worked = $dbh->selectall_arrayref( "SELECT name, totp_secret FROM user WHERE hash=? AND name = ?", { Slice => {} }, $hash, $user );
-    if ( !( ref $worked eq 'ARRAY' && @$worked ) ) {
+    my $records = $dbh->selectall_arrayref( "SELECT name, hash, salt, totp_secret FROM user WHERE name = ?", { Slice => {} }, $user );
+    if ( !( ref $records eq 'ARRAY' && @$records ) || !check_password( $user, $pass ) ) {
         INFO("Failed login for user $user");
+        log_event( 'login_failure', $user, $ip_addr );
         return '';
     }
-    my $uid    = $worked->[0]{name};
-    my $secret = $worked->[0]{totp_secret};
+    my $uid    = $records->[0]{name};
+    my $secret = $records->[0]{totp_secret};
 
-    # Validate the 2FA Token.  If we have no secret, allow login so they can see their QR code, and subsequently re-auth.
+    # No secret means they have not enrolled yet, and letting them in is how
+    # they get to -- the enrolment page is behind a login, since the QR on it is
+    # the secret.  TCMS::needs_enrolment is what stops that being a way to have
+    # an account with no second factor: it is the only page they can reach.
     if ($secret) {
-        return '' unless $token;
-        DEBUG( "TOTP Auth: Sent code $token, expect " . $totp->expected_totp_code(time) );
-
-        #XXX we have to force the secret into compliance, otherwise it generates one on the fly, oof
-        $totp->{secret} = $secret;
-        my $rc = $totp->validate_otp( otp => $token, secret => $secret, tolerance => 3, period => 30, digits => 6 );
-        INFO("TOTP Auth failed for user $user") unless $rc;
-        return ''                               unless $rc;
+        my ( $ok, $why ) = spend_totp( $user, $token );
+        if ( !$ok ) {
+            INFO("TOTP auth failed for user $user: $why");
+            log_event( 'totp_failure', $user, $ip_addr );
+            return '';
+        }
     }
 
     # Issue cookie
     my $uuid = Trog::Utils::uuid();
-    $dbh->do( "INSERT OR REPLACE INTO session (id,username) VALUES (?,?)", undef, $uuid, $uid ) or return '';
+    $dbh->do( "INSERT OR REPLACE INTO session (id,username) VALUES (?,?)", undef, $uuid, $uid );
+    log_event( 'login_success', $user, $ip_addr, $uuid );
     return $uuid;
 }
 
@@ -297,9 +459,10 @@ Delete the provided user's session from the auth db.
 
 =cut
 
-sub killsession ($user) {
-    my $dbh = _dbh();
+sub killsession ( $user, $ip_addr = '' ) {
+    my $dbh = dbh();
     $dbh->do( "DELETE FROM session WHERE username=?", undef, $user );
+    log_event( 'logout', $user, $ip_addr );
     return 1;
 }
 
@@ -308,7 +471,8 @@ sub killsession ($user) {
 Adds a user identified by the provided password into the auth DB.
 Also used to alter users.
 
-Returns True or False (likely false when user already exists).
+Returns true.  Dies if the user cannot be stored, as the rest of this module
+does when the auth database fails.
 
 =cut
 
@@ -326,29 +490,25 @@ sub useradd ( $user, $displayname, $pass, $acls, $contactemail ) {
     die "ACLs must be array"             unless is_arrayref($acls);
     die "No contact email set for user!" unless $contactemail;
 
-    my $dbh = _dbh();
-    if ($pass) {
-        $salt = Trog::Utils::uuid();
-        $hash = sha256( $pass . $salt );
-    }
-    my $res = $dbh->do( "INSERT OR REPLACE INTO user (name, display_name, salt, hash, contact_email, totp_secret) VALUES (?,?,?,?,?,?)", undef, $user, $displayname, $salt, $hash, $contactemail, $t_secret );
-    return unless $res && ref $acls eq 'ARRAY';
+    my $dbh = dbh();
+    ( $hash, $salt ) = hash_password($pass) if $pass;
+    $dbh->do( "INSERT OR REPLACE INTO user (name, display_name, salt, hash, contact_email, totp_secret) VALUES (?,?,?,?,?,?)", undef, $user, $displayname, $salt, $hash, $contactemail, $t_secret );
 
     #XXX this is clearly not normalized with an ACL mapping table, will be an issue with large number of users
     foreach my $acl (@$acls) {
-        return unless $dbh->do( "INSERT OR REPLACE INTO user_acl (username,acl) VALUES (?,?)", undef, $user, $acl );
+        $dbh->do( "INSERT OR REPLACE INTO user_acl (username,acl) VALUES (?,?)", undef, $user, $acl );
     }
     return 1;
 }
 
 sub add_change_request (%args) {
-    my $dbh = _dbh();
-    my $res = $dbh->do( "INSERT INTO change_request (username,token,type,secret) VALUES (?,?,?,?)", undef, $args{user}, $args{token}, $args{type}, $args{secret} );
-    return !!$res;
+    my $dbh = dbh();
+    $dbh->do( "INSERT INTO change_request (username,token,type,secret) VALUES (?,?,?,?)", undef, $args{user}, $args{token}, $args{type}, $args{secret} );
+    return 1;
 }
 
 sub process_change_request ($token) {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT username, display_name, type, secret, contact_email FROM change_request_full WHERE processed=0 AND token=?", { Slice => {} }, $token );
     return 0 unless ref $rows eq 'ARRAY' && @$rows;
 
@@ -358,40 +518,95 @@ sub process_change_request ($token) {
     my $secret       = $rows->[0]{secret};
     my $contactemail = $rows->[0]{contact_email};
 
-    state %dispatch = (
-        reset_pass => sub {
-            my ( $user, $pass ) = @_;
+    # my, not state: each closure reads this request's $display and $contactemail.
+    my %dispatch = (
+        reset_pass => sub ( $name, $pass ) {
 
             #XXX The fact that this is an INSERT OR REPLACE means all the entries in change_request for this user will get cascade wiped.  Which is good, as the secrets aren't salted.
             # This is also why we have to snag the user's ACLs or they will be wiped.
-            my @acls = acls4user($user);
-            useradd( $user, $display, $pass, \@acls, $contactemail ) or do {
-                return '';
-            };
-            killsession($user);
-            return "Password set to $pass for $user";
-        },
-        clear_totp => sub {
-            my ($user) = @_;
-            clear_totp($user) or do {
-                return '';
-            };
-            killsession($user);
-            return "TOTP auth turned off for $user";
+            my @acls = acls4user($name);
+            useradd( $name, $display, $pass, \@acls, $contactemail );
+            killsession($name);
+            return "Password set to $pass for $name";
         },
     );
     my $res = $dispatch{$type}->( $user, $secret );
-    $dbh->do( "UPDATE change_request SET processed=1 WHERE token=?", undef, $token ) or do {
-        FATAL("Could not set job with token $token to completed!");
+    eval { $dbh->do( "UPDATE change_request SET processed=1 WHERE token=?", undef, $token ); 1 } or do {
+        FATAL("Could not set job with token $token to completed: $@");
     };
     return $res;
 }
 
-# Ensure the db schema is OK, and give us a handle
-sub _dbh {
-    my $file   = 'schema/auth.schema';
-    my $dbname = "config/auth.db";
-    return Trog::SQLite::dbh( $file, $dbname );
+=head2 audit_log(%opts) = ARRAYREF
+
+Return recent authentication events.
+Supports filtering by C<username>, C<event_type>, and C<limit> (default 100).
+
+=cut
+
+sub audit_log (%opts) {
+    my $dbh   = dbh();
+    my $limit = int( $opts{limit} // 100 );
+    my @where;
+    my @bind;
+
+    if ( $opts{username} ) {
+        push @where, 'username = ?';
+        push @bind,  $opts{username};
+    }
+    if ( $opts{event_type} ) {
+        push @where, 'event_type = ?';
+        push @bind,  $opts{event_type};
+    }
+
+    my $where = @where ? 'WHERE ' . join( ' AND ', @where ) : '';
+    my $rows  = $dbh->selectall_arrayref(
+        ## no critic(ValuesAndExpressions::PreventSQLInjection)
+        "SELECT id, event_time, username, session_id, ip_addr, event_type FROM audit_log $where ORDER BY event_time DESC LIMIT ?",
+        { Slice => {} }, @bind, $limit
+    );
+    return [] unless ref $rows eq 'ARRAY';
+    return $rows;
+}
+
+=head2 log_event($event_type, $username, $ip_addr, $session_id)
+
+Write one row to the audit log.
+
+Public because the vault writes to it too: reading somebody's stored password is
+the same kind of event as logging in as them, and it belongs in the same list.
+
+Swallows its own errors.  A login that fails because the audit table is unhappy
+would be a worse outcome than a login nobody wrote down.
+
+=cut
+
+sub log_event ( $event_type, $username, $ip_addr = '', $session_id = undef ) {
+    eval {
+        my $dbh = dbh();
+        $dbh->do(
+            "INSERT INTO audit_log (event_time, username, session_id, ip_addr, event_type) VALUES (?,?,?,?,?)",
+            undef, time(), $username, $session_id, $ip_addr, $event_type
+        );
+        1;
+    } or WARN("audit_log insert failed: $@");
+    return;
+}
+
+=head2 users_with_emails() = ARRAYREF
+
+Return all users and their contact emails, for use in libravatar lookups.
+
+=cut
+
+#XXX it may be worth using the sqlite extension to do SHA hashing here to speed up lookups.
+sub users_with_emails {
+    my $dbh  = dbh();
+    my $rows = $dbh->selectall_arrayref(
+        "SELECT name, contact_email FROM user WHERE contact_email IS NOT NULL AND contact_email != ''",
+        { Slice => {} }
+    );
+    return ref $rows eq 'ARRAY' ? $rows : [];
 }
 
 1;

lib/Trog/Autoreload.pm

@@ -1,36 +0,0 @@
-package Trog::Autoreload;
-
-use strict;
-use warnings;
-
-use feature qw{signatures};
-
-use Linux::Perl::inotify;
-
-use Trog::Utils;
-
-sub watch_for_changes ( $dir, $interval=5 ) {
-    my $inf = Linux::Perl::inotify->new([qw{NONBLOCK}]);
- 
-    my @dirs = ($dir);
-    my @wds;
-    foreach my $directory (@dirs) {
-        # Recursive scan for directories and setting up inotifies
-        push(@dirs, _readdir( $directory ));
-        DEBUG("Watching $directory for changes");
-        push(@wds, $inf->add( path => $directory, events => [qw{CREATE MODIFY}] ));
-    }
-    while (!$inf->read()) {
-        sleep $interval;
-    }
-    INFO("Change in $dir detected");
-    Trog::Utils::restart_parent();
-    exit 0;
-}
-
-sub _readdir ( $dir ) {
-    opendir(my $dh, $dir);
-    my @dirs = grep { -d $_ && !m/^\.+$/ } readdir($dh);
-    closedir($dh);
-    return @dirs;
-}

lib/Trog/Bundle.pm

@@ -0,0 +1,163 @@
+package Trog::Bundle;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Digest::SHA              ();
+use File::Slurper            ();
+use JavaScript::Minifier::XS ();
+use List::Util               ();
+
+use Trog::Themes ();
+
+=head1 Trog::Bundle
+
+The scripts that a page names, served as one response.
+
+A route names the scripts of its page in its definition: C<scripts> for every
+reader, and C<authenticated_scripts> for a reader who is logged in as well.
+finish_render() in Trog::Routes::HTML links the bundle of them at the href that
+scripts() returns, and the route C</bundle/{version}/{names}.js> serves it.
+
+The lists are the routes', and never the request's.  The route serves no list
+that a route did not declare, so a URL cannot make tCMS build anything.
+
+=cut
+
+# The names of each bundle, as its href carries them, to the bundle.
+my %bundles;
+
+# The names of each list that a route declared, as its href carries them.
+our %declared;
+
+# The names as an href carries them.
+my sub key_of (@names) {
+    return join( '+', map { s/[.]js\z//r } @names );
+}
+
+=head2 declare(@lists)
+
+Declare each list, an ARRAY reference of names as scripts() takes them, so that
+the route serves its bundle.  TCMS::build_routes() declares the lists of every
+route at startup, so that a worker serves a bundle before it renders a page that
+links it.
+
+=cut
+
+sub declare (@lists) {
+    $declared{ key_of( List::Util::uniq(@$_) ) } = 1 for grep { @$_ } @lists;
+    return;
+}
+
+=head2 scripts(@names) = HASHREF or undef
+
+The bundle of the scripts that @names names.  Each name is a file name under
+F<www/scripts>, such as C<post.js>.  The theme's copy of a script is used in
+place of the stock one.  The order is the order of @names, and a name that is
+given twice is used once.
+
+Returns undef for an empty list, and dies if a name is not a script.  The list
+is declared, as declare() does, since only a route can have named it.
+
+The hash has these keys:
+
+    href     where the bundle is served, which changes when its body does
+    version  a digest of the body, which is in the href
+    body     the scripts, each one minified unless its name ends in .min.js
+
+A process builds each bundle once, and builds it again when a file in it
+changes.
+
+=cut
+
+sub scripts (@names) {
+    @names = List::Util::uniq(@names);
+    return undef unless @names;
+
+    my @files = map {
+        my $file = m/\A\w[\w.-]*[.]js\z/ ? Trog::Themes::themed_script($_) =~ s{\A/}{www/}r : undef;
+        $file && -f $file ? $file : undef;    ## no critic (ProhibitFiletest_f) -- a name that is not a file is not a script
+    } @names;
+    my @missing = map { $names[$_] } grep { !defined $files[$_] } 0 .. $#names;
+    die "There is no script to bundle named @missing\n" if @missing;
+
+    my $key       = key_of(@names);
+    my $signature = join( "\0", map { join( ':', $_, ( stat $_ )[ 7, 9 ] ) } @files );
+    $declared{$key} = 1;
+    return $bundles{$key} if $bundles{$key} && $bundles{$key}{signature} eq $signature;
+
+    # A newline before the semicolon, because a file can end in a line comment.
+    my $body = join(
+        "\n;\n",
+        map {
+            my $js = File::Slurper::read_binary($_);
+            m/[.]min[.]js\z/ ? $js : JavaScript::Minifier::XS::minify($js)
+        } @files
+    );
+    my $version = substr( Digest::SHA::sha256_hex($body), 0, 16 );
+    return $bundles{$key} = {
+        href      => "/bundle/$version/$key.js",
+        version   => $version,
+        body      => $body,
+        signature => $signature,
+    };
+}
+
+=head2 served(@names) = HASHREF or undef
+
+The bundle that the route serves for @names, as scripts() returns it, or undef
+if a route did not declare the list.
+
+=cut
+
+sub served (@names) {
+    @names = List::Util::uniq(@names);
+    return undef unless @names && $declared{ key_of(@names) };
+    return scripts(@names);
+}
+
+=head2 save($tpsgi, $bundle)
+
+Have tPSGI save $bundle as a static render after the response, so that the
+webserver serves it from then on.  A process saves a given bundle once.
+
+finish_render() calls this for the bundle that a page links.
+
+It also has tPSGI watch the directories of the scripts.  When a script changes,
+the saved pages and bundles are thrown away: the pages are rendered again and
+link the new bundle, and a page that still links an old one is redirected by
+the route.  The route also serves a bundle whose static is gone, so a worker
+that still counts it as saved is slower, not wrong.
+
+=cut
+
+# The hrefs of the bundles that this process saved.
+our %saved;
+
+sub save ( $tpsgi, $bundle ) {
+    return 0 if !$tpsgi || $saved{ $bundle->{href} };
+
+    if ( $tpsgi->can('add_watch') ) {
+        my $theme = Trog::Themes::get_dir();
+        foreach my $dir ( grep { -d } ( 'www/scripts', $theme ? "$theme/scripts" : () ) ) {
+            $tpsgi->add_watch(
+                $dir,
+                sub {
+                    my ( $watcher, $change ) = @_;
+                    $watcher->invalidate_renders($_) for qw{html js};
+                    return 1;
+                },
+                key => "Trog::Bundle:$dir",
+            );
+        }
+    }
+
+    $tpsgi->add_post_close_callback(
+        sub {
+            $tpsgi->save_render( $bundle->{href}, 'js', $bundle->{body} );
+            $saved{ $bundle->{href} } = 1;
+        }
+    );
+    return 1;
+}

lib/Trog/Component.pm

@@ -0,0 +1,161 @@
+package Trog::Component;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Text::Xslate ();
+
+=head1 Trog::Component
+
+Dispatcher for the UI components living under the Trog::Component namespace.
+
+Injected into the template processor as component() by Trog::Renderer::Base, so
+templates ask for what they want rather than having a route thread a rendered
+string into their data hash:
+
+    <: component('EmojiPicker') :>
+    <: component('Gallery', { album => $post.id, cols => 3 }) :>
+
+Deliberately depends on nothing but Text::Xslate.  Trog::Renderer::Base uses
+this module, and components use Trog::Renderer, so anything heavier here would
+close a compile-time load cycle.  Components are loaded lazily, at call time,
+for the same reason.
+
+=head1 Termination Conditions
+
+Dies if the component can't be named, found, loaded or rendered.  There is no
+sensible half-rendered page.
+
+Dying is necessary but not sufficient: Xslate catches exceptions thrown out of a
+function call, hands them to its warn handler, and carries on with an empty
+string where the call was -- so a broken component would otherwise vanish from
+the page with nothing but a line on stderr to say so.  The failure is therefore
+also recorded in $Trog::Component::error, which Trog::Renderer::Base::render()
+localizes and checks, turning it into the 500 it deserves.
+
+=head1 FUNCTIONS
+
+=cut
+
+# A component whose template asks for itself would otherwise recurse until the
+# stack gives out, which says nothing about which component did it.
+our $MAX_DEPTH = 10;
+our $depth     = 0;
+
+# The first component failure of the current render.  See above -- dying alone
+# does not stop an Xslate render.  Always read through a local() in the caller.
+our $error;
+
+# Resolved at call time rather than compile time, so that components are free to
+# use Trog::Renderer without cycling back through us.  require() memoizes in
+# %INC; %loaded only saves us the repeat eval and string munging.
+my sub load ($name) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 22 lines, which would overcomplicate _component()
+    state %loaded;
+
+    die "Component name must be given\n"   unless $name;
+    die "Invalid component name '$name'\n" unless $name =~ m/^[[:alpha:]]\w*$/;
+
+    my $module = "Trog::Component::$name";
+    return $module if $loaded{$module};
+
+    local $@;
+    eval {
+        require "Trog/Component/$name.pm";    ## no critic (RequireBarewordIncludes) -- $name is validated above
+        1;
+    } or do {
+        die "Could not load component '$name': $@";
+    };
+
+    die "Component '$name' has no render()\n" unless $module->can('render');
+
+    $loaded{$module} = 1;
+    return $module;
+}
+
+my sub _component ( $name, $args ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 25 lines, which would overcomplicate component()
+    my $module = load($name);
+
+    die "Component '$name' recursed more than $MAX_DEPTH deep\n" if $depth >= $MAX_DEPTH;
+    local $Trog::Component::depth = $depth + 1;
+
+    $args = {} unless ref $args eq 'HASH';
+
+    my $out;
+    local $@;
+    eval {
+        $out = $module->can('render')->(%$args);
+        1;
+    } or do {
+        die "Component '$name' failed to render: $@";
+    };
+
+    # Trog::Renderer::render() answers failure with a PSGI triplet from _yeet(),
+    # which is meaningless halfway through a template.  Catching it here is what
+    # saves every call site from the 'return $it if ref $it eq ARRAY' dance.
+    die "Component '$name' returned a " . ref($out) . " rather than a string\n" if ref $out;
+    die "Component '$name' rendered nothing\n"                                  if !defined $out;
+
+    return Text::Xslate::mark_raw($out);
+}
+
+=head2 component($name, $args) = STRING
+
+Render the named component, marked raw so that callers need no C<| mark_raw>.
+
+$name is one flat namespace level under Trog::Component -- word characters only.
+It becomes a path handed to require(), so this is what stops a template naming
+its way out of Trog/Component/.
+
+$args is an optional HASHREF, flattened into the component's render().  Nullary
+components simply ignore it.
+
+=cut
+
+sub component ( $name, $args = {} ) {
+    my ( $out, $err );
+    {
+        local $@;
+        $out = eval { _component( $name, $args ) };
+        $err = $@;
+    }
+    return $out if defined $out;
+
+    # Record as well as rethrow: the die on its own gets swallowed by Xslate.
+    # First failure wins, as the ones after it tend to be consequences of it.
+    # The throw uses our own error rather than $error, so a direct caller is
+    # told what *it* did even when something earlier left a record behind.
+    $err ||= "Component '$name' failed for no stated reason\n";
+    $error //= $err;
+    die $err;
+}
+
+=head2 render_template($template, $data) = STRING
+
+Render a component template and hand back the body, for the many components
+whose whole job is exactly that.
+
+Dies naming the template if the render fails, rather than answering with the
+PSGI triplet Trog::Renderer::render() produces on failure.
+
+=cut
+
+sub render_template ( $template, $data = {} ) {
+
+    # Required rather than used, for the same reason components are loaded
+    # lazily: Trog::Renderer::Base uses this module, so a compile-time use here
+    # would close the cycle.  By the time anyone calls this it is already loaded.
+    require Trog::Renderer;
+
+    my $out = Trog::Renderer->render(
+        contenttype => 'text/html',
+        component   => 1,
+        template    => $template,
+        data        => $data,
+    );
+
+    die "Could not render component template '$template'\n" if ref $out;
+    return $out;
+}
+
+1;

lib/Trog/Component/CategoryBar.pm

@@ -0,0 +1,29 @@
+package Trog::Component::CategoryBar;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::CategoryBar
+
+The list of series links in the top bar.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render categories.tx.
+
+Wants C<categories>, the series list the page was built with, and C<user>, which
+decides whether the links point at /secure.
+
+=cut
+
+sub render (%args) {
+    $args{categories} //= [];
+    return Trog::Component::render_template( 'categories.tx', \%args );
+}
+
+1;

lib/Trog/Component/EmojiPicker.pm

@@ -1,22 +1,53 @@
 package Trog::Component::EmojiPicker;
 
-use strict;
-use warnings;
-
-no warnings qw{experimental};
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
+use File::Slurper ();
+use JSON::MaybeXS;
 use Trog::Renderer;
 
-sub render () {
+=head1 Trog::Component::EmojiPicker
+
+The emoji picker component.
+
+=head1 Termination Conditions
+
+Dies if the emoji list isn't on disk, as there's no sensible picker to show
+without it.  It's a frontend dependency, so C<make prereq-frontend> is what
+puts it there.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render the picker as an HTML component.  Reached from templates as
+C<< <: component('EmojiPicker') :> >>; takes no arguments, and ignores any it
+is handed.
+
+The emoji list ships as a flat array, which is no use to a picker with tabs, so
+it gets bucketed by category on the first call and memoized thereafter -- the
+list can't change without a redeploy.
+
+Returns the rendered body, rather than a PSGI triplet, as components are meant
+to be composed into a page by their caller.
+
+=cut
+
+sub render {
     state %categorized;
 
     if ( !%categorized ) {
         my $file = 'www/scripts/list.min.json';
-        die "Run make prereq-frontend first" unless -f $file;
 
-        my $raw    = File::Slurper::read_binary($file);
-        my $emojis = Cpanel::JSON::XS::decode_json($raw);
+        # One operation rather than a test and then a read, which also catches
+        # the unreadable case the test missed.  Checked with defined() rather
+        # than truthiness so that an empty file falls through to the JSON
+        # parser, which will say what is actually wrong with it.
+        my $raw = eval { File::Slurper::read_binary($file) };
+        die "Could not read $file ($@) -- run make prereq-frontend first" unless defined $raw;
+        my $emojis = JSON::MaybeXS::decode_json($raw);
         foreach my $emoji ( @{ $emojis->{emojis} } ) {
             $categorized{ $emoji->{category} } //= [];
             push( @{ $categorized{ $emoji->{category} } }, $emoji->{emoji} );

lib/Trog/Component/FootBar.pm

@@ -0,0 +1,24 @@
+package Trog::Component::FootBar;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::FootBar
+
+The footer bar, below the content.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render footbar.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'footbar.tx', \%args ) }
+
+1;

lib/Trog/Component/Footer.pm

@@ -0,0 +1,24 @@
+package Trog::Component::Footer;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::Footer
+
+The tail of an HTML page -- the closing body and html tags.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render footer.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'footer.tx', \%args ) }
+
+1;

lib/Trog/Component/Header.pm

@@ -0,0 +1,55 @@
+package Trog::Component::Header;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+use Trog::Themes;
+
+=head1 Trog::Component::Header
+
+Everything from the doctype down to the opening body tag: the title, the social
+and icon metadata, and the stylesheet and script links.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render header.tx.
+
+Recognized arguments, all optional:
+
+    title / route / lang / author         the page itself
+    meta_desc / meta_tags / default_tags  social metadata, built by the route
+    stylesheets / print_styles / scripts  resolved paths, built by finish_render
+    embed                                 embedded view, which adds a base target
+    no_doctype                            leave the doctype off, for the RSS
+                                          stylesheet, which is XSL rather than HTML
+
+The list arguments default to empty rather than to the stock sheets, so that a
+caller which has none -- rss_style(), notably -- gets a header with none, as it
+did when the route rendered this itself.
+
+theme_dir is worked out here rather than passed, as it is the same for every
+page and the template only wants it to build asset paths.
+
+=cut
+
+sub render (%args) {
+    $args{lang}         //= 'en-US';
+    $args{title}        //= 'tCMS';
+    $args{stylesheets}  //= [];
+    $args{print_styles} //= [];
+    $args{scripts}      //= [];
+
+    # td() answers a rooted URL path, which for a themed site starts /www/ --
+    # the template builds hrefs with it, and /www is not in the URL space.
+    my $theme_dir = Trog::Themes::td();
+    $theme_dir =~ s|^/www/||;
+    $args{theme_dir} //= $theme_dir;
+
+    return Trog::Component::render_template( 'header.tx', \%args );
+}
+
+1;

lib/Trog/Component/HtmlTitle.pm

@@ -0,0 +1,24 @@
+package Trog::Component::HtmlTitle;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::HtmlTitle
+
+The site title, shown at the left of the top bar.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render title.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'title.tx', \%args ) }
+
+1;

lib/Trog/Component/LeftBar.pm

@@ -0,0 +1,24 @@
+package Trog::Component::LeftBar;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::LeftBar
+
+The left sidebar.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render leftbar.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'leftbar.tx', \%args ) }
+
+1;

lib/Trog/Component/MidTitle.pm

@@ -0,0 +1,24 @@
+package Trog::Component::MidTitle;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::MidTitle
+
+The middle slot of the top bar.  Empty by default.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render midtitle.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'midtitle.tx', \%args ) }
+
+1;

lib/Trog/Component/PostFooter.pm

@@ -0,0 +1,56 @@
+package Trog::Component::PostFooter;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use List::Util();
+
+use Trog::Component ();
+use Trog::Themes;
+
+=head1 Trog::Component::PostFooter
+
+The per-post footer a series can name in its metadata, drawn from the footers/
+directory of the stock templates or the theme's.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render footers/$args{name}.
+
+The name comes out of post data, so it is checked against the footers/ listing
+before it becomes a path -- see available().  Returns the empty string when no
+name is given, so that the caller can ask unconditionally.
+
+Beyond the name, the template gets the post it belongs to and the route it is
+being shown at, plus theme_dir for building asset paths.  That is narrower than
+the whole request hash these used to be rendered with; a theme whose footer
+wants something else should be handed it at the call site in posts.tx.
+
+=cut
+
+sub render (%args) {
+    my $name = delete $args{name};
+    return '' unless $name;
+
+    die "No such footer '$name'\n" unless List::Util::any { $_ eq $name } @{ available() };
+
+    $args{theme_dir} //= Trog::Themes::td();
+    return Trog::Component::render_template( "footers/$name", \%args );
+}
+
+=head2 available() = ARRAYREF
+
+The footers a post may name: every .tx in footers/, the theme's and the stock ones
+both.  This is the same list the series edit form offers, so anything the form
+can pick renders, and nothing else does.
+
+=cut
+
+sub available () {
+    return Trog::Themes::themed_templates_in_dir( 'footers', 'text/html', 1 );
+}
+
+1;

lib/Trog/Component/PostHeader.pm

@@ -0,0 +1,56 @@
+package Trog::Component::PostHeader;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use List::Util();
+
+use Trog::Component ();
+use Trog::Themes;
+
+=head1 Trog::Component::PostHeader
+
+The per-post header a series can name in its metadata, drawn from the headers/
+directory of the stock templates or the theme's.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render headers/$args{name}.
+
+The name comes out of post data, so it is checked against the headers/ listing
+before it becomes a path -- see available().  Returns the empty string when no
+name is given, so that the caller can ask unconditionally.
+
+Beyond the name, the template gets the post it belongs to and the route it is
+being shown at, plus theme_dir for building asset paths.  That is narrower than
+the whole request hash these used to be rendered with; a theme whose header
+wants something else should be handed it at the call site in posts.tx.
+
+=cut
+
+sub render (%args) {
+    my $name = delete $args{name};
+    return '' unless $name;
+
+    die "No such header '$name'\n" unless List::Util::any { $_ eq $name } @{ available() };
+
+    $args{theme_dir} //= Trog::Themes::td();
+    return Trog::Component::render_template( "headers/$name", \%args );
+}
+
+=head2 available() = ARRAYREF
+
+The headers a post may name: every .tx in headers/, the theme's and the stock ones
+both.  This is the same list the series edit form offers, so anything the form
+can pick renders, and nothing else does.
+
+=cut
+
+sub available () {
+    return Trog::Themes::themed_templates_in_dir( 'headers', 'text/html', 1 );
+}
+
+1;

lib/Trog/Component/RightBar.pm

@@ -0,0 +1,24 @@
+package Trog::Component::RightBar;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::RightBar
+
+The right sidebar.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render rightbar.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'rightbar.tx', \%args ) }
+
+1;

lib/Trog/Component/TopBar.pm

@@ -0,0 +1,24 @@
+package Trog::Component::TopBar;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::Component ();
+
+=head1 Trog::Component::TopBar
+
+The top bar's theme slot, beside the search box.  Empty by default.
+
+=head1 FUNCTIONS
+
+=head2 render(%args) = STRING
+
+Render topbar.tx.  Stock reads no variables; anything passed is handed to the
+template, so a theme's override is free to want some.
+
+=cut
+
+sub render (%args) { return Trog::Component::render_template( 'topbar.tx', \%args ) }
+
+1;

lib/Trog/Config.pm

@@ -1,10 +1,13 @@
 package Trog::Config;
 
-use strict;
-use warnings;
-use feature qw{state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin::libs;
 
 use Config::Simple;
+use File::Slurper();
 
 =head1 Trog::Config
 
@@ -15,17 +18,101 @@ A thin wrapper around Config::Simple which reads the configuration from the appr
 Returns a configuration object that will be used by server.psgi, the data model and Routing modules.
 Memoized, so you will need to HUP the children on config changes.
 
+Reads $home_cfg, falling back to $default when the instance has never saved a
+configuration of its own.  Both are full paths relative to the tCMS root, so
+that writers can use them too -- an earlier version had the 'config/' prefix
+hardcoded here and nowhere else, which meant everything that *wrote* the
+configuration put it somewhere get() would never look.
+
 =cut
 
+# Where an instance's own configuration lives, once it has saved one.
 our $home_cfg = "config/main.cfg";
 
+# Shipped defaults.  Tracked in git -- never write to this.
+our $default = "config/default.cfg";
+
 sub get {
     state $cf;
-    return $cf                           if $cf;
-    $cf = Config::Simple->new($home_cfg) if -f $home_cfg;
-    return $cf                           if $cf;
-    $cf = Config::Simple->new('config/default.cfg');
+    return $cf if $cf;
+    foreach my $cfg2try ( $home_cfg, $default ) {
+        next unless -f $cfg2try;    ## no critic (ProhibitFiletest_f) -- the instance config, else the shipped default
+        $cf = Config::Simple->new($cfg2try);
+        last;
+    }
+    die "Could not find config file!" unless $cf;
     return $cf;
 }
 
+=head2 Trog::Config::schema( STRING file = $default ) = ARRAYREF
+
+The shape of the configuration, as described by the file we ship.
+
+config/default.cfg is the only place which says what settings exist at all, so
+it is also what the /config editor is built out of -- add a key there and it
+becomes editable, leave one out and it isn't.  Sections and keys come back in
+file order:
+
+    [
+        {
+            section => 'general',
+            fields  => [
+                {
+                    key     => 'data_model',
+                    name    => 'general.data_model',
+                    default => 'SQLite',
+                    comment => 'FlatFile or SQLite. ...',
+                },
+            ],
+        },
+    ]
+
+Comment lines accumulate until a key claims them, so a comment block is the
+help text for whatever setting follows it.  Config::Simple throws both comments
+and ordering away when it reads a file, which is why this reads it again rather
+than asking the object we already have.
+
+Keys appearing before any section header are skipped -- Config::Simple has no
+name for them, so neither do we.
+
+=cut
+
+sub schema ( $file = $default ) {
+    my ( @sections, $section, @comments );
+    foreach my $line ( File::Slurper::read_lines($file) ) {
+        $line =~ s/^\s+//;
+        $line =~ s/\s+$//;
+        next unless $line;
+
+        if ( $line =~ m/^\[(\N+)\]$/ ) {
+            $section = { section => $1, fields => [] };
+            push( @sections, $section );
+            @comments = ();
+            next;
+        }
+
+        if ( $line =~ m/^[#;]\s?(\N*)$/ ) {
+            push( @comments, $1 );
+            next;
+        }
+
+        my ( $key, $value ) = $line =~ m/^([^=]+?)\s*=\s*(\N*)$/;
+        next unless defined $key;
+        next unless $section;
+
+        push(
+            @{ $section->{fields} },
+            {
+                key     => $key,
+                name    => "$section->{section}.$key",
+                default => $value,
+                comment => join( ' ', @comments ),
+            }
+        );
+        @comments = ();
+    }
+
+    return \@sections;
+}
+
 1;

lib/Trog/Data.pm

@@ -1,10 +1,13 @@
 package Trog::Data;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-no warnings 'experimental';
-use feature qw{signatures state};
+use Module::Runtime();
+use Path::Tiny();
+
+use Trog::Log qw{:all};
 
 #It's just a factory
 
@@ -16,18 +19,54 @@ This is a data model factory.
 
 Returns a new Trog::Data::* class appropriate to what is configured in the Trog::Config object passed.
 
+Memoized: every call after the first returns the first handle, whatever it is passed.
+
 =cut
 
-sub new ( $class, $config ) {
+sub new ( $, $config ) {
     state $datamodule;
     return $datamodule if $datamodule;
 
-    my $module = "Trog::Data::" . $config->param('general.data_model');
-    my $req    = $module;
-    $req =~ s/::/\//g;
-    require "$req.pm";
+    my $module = "Trog::Data::" . model($config);
+    Module::Runtime::require_module($module);
     $datamodule = $module->new($config);
     return $datamodule;
 }
 
+=head2 model(Trog::Config) = STRING
+
+The data model to serve from: general.data_model, except on a site which never
+moved its posts across with bin/migrate.pl.
+
+SQLite is the shipped default, so a FlatFile site which never saved a
+data_model of its own, or which saved the default back, is configured for a
+database that does not exist.  While data/posts.sqlite is missing and data/files
+holds posts, this answers FlatFile and warns, so the site keeps serving the
+posts it has.  Once the migration has written the database, the configuration
+applies as written.
+
+=cut
+
+# FlatFile's datastore, named here because loading that model creates its tag
+# index, and this has to look before choosing.  Trog::Data::FlatFile has its own.
+our $flatfile_store = 'data/files';
+
+sub model ($config) {
+    my $model = $config->param('general.data_model');
+    return $model unless $model eq 'SQLite';
+
+    # Which that model only creates on first use.
+    require Trog::Data::SQLite;
+    no warnings 'once';
+    my $sqlite_db = $Trog::Data::SQLite::dbname;
+    return $model if -e $sqlite_db;
+
+    my $posts = eval {
+        scalar grep { -f } Path::Tiny::path($flatfile_store)->children;    ## no critic (ProhibitFiletest_f) -- counting names, nothing is opened
+    } or return $model;
+
+    WARN("general.data_model is SQLite, but $sqlite_db does not exist and $flatfile_store holds $posts post(s).  Serving them from FlatFile.  Run bin/migrate.pl to move them across.");
+    return 'FlatFile';
+}
+
 1;

lib/Trog/Data/DUMMY.pm

@@ -1,17 +1,16 @@
 package Trog::Data::DUMMY;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use Carp qw{confess};
+use Errno();
+use Fcntl qw{O_WRONLY O_CREAT O_EXCL};
 use JSON::MaybeXS;
 use File::Slurper;
 use List::Util qw{uniq};
-use Path::Tiny();
-use parent qw{Trog::DataModule};
+use parent     qw{Trog::DataModule};
 
 =head1 WARNING
 
@@ -20,22 +19,30 @@ Do not use this as a production data model.  It is *not* safe to race conditions
 =cut
 
 our $datastore = 'data/DUMMY.json';
-sub lang { 'Perl Regex in Quotemeta' }
-sub help { 'https://perldoc.perl.org/functions/quotemeta.html' }
+sub lang { return 'Perl Regex in Quotemeta' }
+sub help { return 'https://perldoc.perl.org/functions/quotemeta.html' }
 
 our $posts;
 
-sub read ( $self, $query = {} ) {
-    if ( !-f $datastore ) {
-        open( my $fh, '>', $datastore );
-        print $fh '[]';
-        close $fh;
+sub read {
+
+    # Seed an empty datastore, as one operation rather than a test followed by
+    # a create.  O_EXCL means a file that appeared in between is left alone
+    # rather than truncated, and unlike the previous unchecked open, a failure
+    # that is not EEXIST is reported here instead of surfacing as a confusing
+    # 'print on closed filehandle' followed by a die inside read_text.
+    if ( sysopen( my $fh, $datastore, O_WRONLY | O_CREAT | O_EXCL ) ) {
+        print {$fh} '[]';
+        close($fh) or confess "Could not write $datastore: $!";
+    }
+    elsif ( $! != Errno::EEXIST ) {
+        confess "Could not create $datastore: $!";
     }
     my $slurped = File::Slurper::read_text($datastore);
     $posts = JSON::MaybeXS::decode_json($slurped);
 
     # Sort everything by date DESC
-    @$posts = sort { $b->{created} <=> $a->{created} } @$posts;
+    @$posts = reverse sort { $a->{created} <=> $b->{created} } @$posts;
 
     return $posts;
 }
@@ -55,8 +62,9 @@ sub write ( $self, $data, $overwrite = 0 ) {
         push( @$orig, @$data );
     }
     open( my $fh, '>', $datastore ) or confess;
-    print $fh JSON::MaybeXS::encode_json($orig);
-    close $fh;
+    print {$fh} JSON::MaybeXS::encode_json($orig);
+    close($fh) or confess "Could not write $datastore: $!";
+    return 1;
 }
 
 sub delete ( $self, @posts ) {
@@ -66,13 +74,10 @@ sub delete ( $self, @posts ) {
     }
     $self->write( $example_posts, 1 );
 
-    # Gorilla cache invalidation
-    Path::Tiny::path('www/statics')->remove_tree;
-
     return 0;
 }
 
-sub tags ($self) {
+sub tags {
     return ( uniq map { @{ $_->{tags} } } @$posts );
 }
 

lib/Trog/Data/FlatFile.pm

@@ -1,26 +1,27 @@
 package Trog::Data::FlatFile;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures};
-
-use Carp qw{confess};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Carp           qw{confess};
+use Fcntl          qw{LOCK_EX};
+use File::Basename ();
+use File::Path     ();
+use Path::Tiny     ();
 use JSON::MaybeXS;
 use File::Slurper;
-use File::Copy;
-use Path::Tiny();
+use File::Slurper::Temp();
 use Capture::Tiny qw{capture_merged};
 
-use lib 'lib';
+use Trog::Log qw{:all};
 use Trog::SQLite::TagIndex;
 
 use parent qw{Trog::DataModule};
 
 our $datastore = 'data/files';
-sub lang { 'Perl Regex in Quotemeta' }
-sub help { 'https://perldoc.perl.org/functions/quotemeta.html' }
+sub lang { return 'Perl Regex in Quotemeta' }
+sub help { return 'https://perldoc.perl.org/functions/quotemeta.html' }
 
 =head1 Trog::Data::FlatFile
 
@@ -36,13 +37,28 @@ our $parser = JSON::MaybeXS->new( utf8 => 1 );
 our @tags = Trog::SQLite::TagIndex::tags();
 our %posts_by_tag;
 
+my sub _index {
+    confess "Can't find datastore in $datastore !" unless -d $datastore;
+    my @index  = map { "$_" } grep { -f } Path::Tiny::path($datastore)->children;    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
+    my @sorted = reverse sort @index;
+    return @sorted;
+}
+
 sub read ( $self, $query = {} ) {
     $query->{limit} //= 25;
 
     #Optimize direct ID
     my @index;
     if ( $query->{id} ) {
-        @index = ("$datastore/$query->{id}");
+
+        # Only when it's actually there.  A miss here is the ordinary answer to
+        # "is there a post with this id", which is what add() asks before every
+        # single insert to decide between version 0 and a bump -- naming the
+        # file regardless meant every new post reported itself as a failed read.
+        # The other branch gets its paths from _index(), which greps -f, so this
+        # is the only way a path that isn't there can reach the loop below.
+        my $path = "$datastore/$query->{id}";
+        @index = ($path) if -f $path;    ## no critic (ProhibitFiletest_f) -- a missing post is a miss, not an error
     }
     else {
         # Remove tags which we don't care about and sort to keep memoized memory usage down
@@ -56,19 +72,22 @@ sub read ( $self, $query = {} ) {
         $posts_by_tag{$tagkey} //= [];
         @index = @{ $posts_by_tag{$tagkey} } if @{ $posts_by_tag{$tagkey} };
 
-        if ( !@index && -f 'data/posts.db' ) {
+        if ( !@index && -f 'data/posts.db' ) {    ## no critic (ProhibitFiletest_f) -- use the tag index, else fall back to _index()
             @index = map { "$datastore/$_" } Trog::SQLite::TagIndex::posts_for_tags( @{ $query->{tags} } );
             $posts_by_tag{$tagkey} = \@index;
         }
-        @index = $self->_index() unless @index;
+        @index = _index() unless @index;
     }
 
     my @items;
     foreach my $item (@index) {
-        next unless -f $item;
+
+        # Checked with defined() rather than truthiness so that an empty file
+        # falls through to the JSON parser, which will say what is actually
+        # wrong with it rather than blaming the read.
         my $slurped = eval { File::Slurper::read_text($item) };
-        if ( !$slurped ) {
-            print "Failed to Read $item:\n$@\n";
+        if ( !defined $slurped ) {
+            WARN("Could not read post '$item': $@");
             next;
         }
         my $parsed;
@@ -81,7 +100,7 @@ sub read ( $self, $query = {} ) {
             $slurped = eval { File::Slurper::read_binary($item) };
             $parsed  = eval { $parser->decode($slurped) };
             if ( !$parsed ) {
-                print "JSON Decode error on $item:\n$@\n";
+                WARN("Could not decode post '$item': $@");
                 next;
             }
         }
@@ -90,67 +109,94 @@ sub read ( $self, $query = {} ) {
         my @filtered = $query->{raw} ? @$parsed : $self->filter( $query, @$parsed );
 
         push( @items, @filtered ) if @filtered;
-        next                      if $query->{limit} == 0;                # 0 = unlimited
-        last                      if scalar(@items) == $query->{limit};
+        next                      if $query->{limit} == 0;    # 0 = unlimited
+
+        # Enough for the page that was asked for, not one page's worth.  get()
+        # paginates *after* this, so stopping at limit meant it had nothing left
+        # to slice for page two and every page but the first came back empty --
+        # offset pagination simply did not work on this model.
+        #
+        # >= rather than ==, because a file holds every version of its post and
+        # one of them can push @items past the mark in a single step, which the
+        # equality test would then never match.
+        my $needed = $query->{limit} * ( $query->{page} || 1 );
+        last if scalar(@items) >= $needed;
     }
 
     return \@items;
 }
 
-sub _index ($self) {
-    confess "Can't find datastore in $datastore !" unless -d $datastore;
-    opendir( my $dh, $datastore ) or confess;
-    my @index = grep { -f } map { "$datastore/$_" } readdir $dh;
-    closedir $dh;
-    return sort { $b cmp $a } @index;
-}
-
-sub routes ($self) {
+sub routes {
     return Trog::SQLite::TagIndex::routes();
 }
 
-sub aliases ($self) {
+sub aliases {
     return Trog::SQLite::TagIndex::aliases();
 }
 
 sub write ( $self, $data ) {
+
+    # The lock and the scratch file both live beside the datastore rather than
+    # in it: _index() scans $datastore with readdir, and would otherwise hand
+    # either of them to the JSON parser as though it were a post.
+    my $spool = File::Basename::dirname($datastore);
+
     foreach my $post (@$data) {
-        my $file   = "$datastore/$post->{id}";
-        my $update = [$post];
-        if ( -f $file ) {
-            my $slurped = File::Slurper::read_binary($file);
-            my $parsed  = $parser->decode($slurped);
 
-            $update = [ ( @$parsed, $post ) ];
-        }
+        # Or the write lands on the datastore directory itself: "$datastore/"
+        # is a directory, rename() onto it fails, and the error names File::
+        # Slurper rather than the post that had no id.  add() will not produce
+        # one, but nothing else guarantees a caller went through add().
+        confess "Cannot write a post with no id" unless $post->{id};
+
+        my $file = "$datastore/$post->{id}";
+
+        File::Path::make_path($datastore);
 
-        mkdir $datastore;
-        open( my $fh, '>', $file ) or confess "Could not open $file";
-        print $fh $parser->encode($update);
-        close $fh;
+        # Two separate races here, needing two separate answers.
+        #
+        # The lock is what stops a lost update.  Without it two workers saving
+        # the same post both read the existing N revisions and each write back
+        # N+1, so one save vanishes: at three workers by 25 saves, about 30 of
+        # 75 revisions survived.  With it, all 75.  It has to be taken on a
+        # path that never gets renamed, hence a lockfile rather than the post.
+        open( my $lock, '>>', "$spool/.write.lock" ) or confess "Could not open $spool/.write.lock: $!";    ## no critic (InputOutput::RequireBriefOpen) -- held until the write lands
+        flock( $lock, LOCK_EX )                      or confess "Could not lock $spool/.write.lock: $!";
+
+        my $slurped = eval { File::Slurper::read_binary($file) };
+        my $update  = $slurped ? [ ( @{ $parser->decode($slurped) }, $post ) ] : [$post];
+
+        # The rename is what stops a torn read.  Every reader here takes no
+        # lock, so writing in place lets one catch a half-written file: a few
+        # hundred unparseable reads per hundred thousand, against none once the
+        # write lands by rename.  PERMS because File::Temp would otherwise
+        # create a new post 0600, where a plain open honoured the umask.
+        local $File::Slurper::Temp::FILE_TEMP_DIR   = $spool;
+        local $File::Slurper::Temp::FILE_TEMP_PERMS = oct('666') & ~umask;
+        File::Slurper::Temp::write_binary( $file, $parser->encode($update) );
+
+        close($lock);    ## no critic (RequireCheckedSyscalls) -- a lock, with nothing buffered to lose
 
         Trog::SQLite::TagIndex::add_post( $post, $self );
     }
+    return 1;
 }
 
-sub count ($self) {
-    my @index = $self->_index();
+sub count {
+    my @index = _index();
     return scalar(@index);
 }
 
-sub delete ( $self, @posts ) {
+sub delete ( $, @posts ) {
     foreach my $update (@posts) {
         unlink "$datastore/$update->{id}" or confess;
         Trog::SQLite::TagIndex::remove_post($update);
     }
 
-    # Gorilla cache invalidation
-    Path::Tiny::path('www/statics')->remove_tree;
-
     return 0;
 }
 
-sub tags ($self) {
+sub tags {
     return Trog::SQLite::TagIndex::tags();
 }
 

lib/Trog/Data/SQLite.pm

@@ -0,0 +1,498 @@
+package Trog::Data::SQLite;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Carp qw{confess};
+use JSON::MaybeXS;
+use List::Util qw{any};
+
+use Trog::Log qw{:all};
+use Trog::SQLite;
+
+use parent qw{Trog::DataModule};
+
+our $schema = 'schema/sqlite.schema';
+our $dbname = 'data/posts.sqlite';
+
+our $parser = JSON::MaybeXS->new( utf8 => 1 );
+
+sub lang { return 'SQLite FTS5 substring match' }
+sub help { return 'https://sqlite.org/fts5.html' }
+
+=head1 Trog::Data::SQLite
+
+The posts themselves in SQLite, rather than a flat file per post with SQLite
+kept alongside as an index of it.
+
+Each row is one version of one post: the post's JSON exactly as the flat file
+model would have written it, in C<post_data>, and nothing else that isn't
+C<GENERATED ALWAYS ... VIRTUAL> out of that blob.  The blob stays the single
+source of truth, the projections cost no storage, and they cannot drift from
+what they were drawn from.
+
+What that buys is get(): the filtering Trog::DataModule::filter() does in Perl
+over every post on disk happens here in one indexed query.  See where() for
+the mapping, which is filter() clause for clause.
+
+Adding a queryable field is one ALTER TABLE and one CREATE INDEX, with no
+migration of the data, because the data itself never moves.  They go in the
+next update file beside the schema, such as
+schema/sqlite.schema.v1.update.sql, and not in schema/sqlite.schema itself.
+Trog::SQLite applies the schema on every new handle, and an ALTER TABLE fails
+the second time.  It runs each update file once per database, in order.
+
+=head1 Termination Conditions
+
+Dies if the database can't be opened or the schema can't be applied, both of
+which mean there is no data model to serve from.
+
+=cut
+
+sub dbh {
+    return Trog::SQLite::dbh( $schema, $dbname );
+}
+
+=head1 QUERYING
+
+=head2 get(%request)
+
+Trog::DataModule::get() without the filtering pass: the query does that.
+
+Everything filter() would have grepped for is a WHERE clause, and paginate()'s
+slice is LIMIT/OFFSET, so what comes back out of the database is already the
+answer.  fixup() still runs, as that fills in display fields rather than
+choosing rows.
+
+=cut
+
+sub get ( $self, %request ) {
+    my $posts = $self->read( \%request );
+    return @$posts if $request{raw};
+
+    return $self->fixup(@$posts);
+}
+
+# Whether the caller named a version.  Empty string counts as unasked, since
+# that is what a form posts for a field nobody filled in.
+my sub pinned ($query) {
+    return defined $query->{version} && $query->{version} ne '';
+}
+
+# A post is only visible to a caller holding one of its tags, since visibility
+# and acls are both stored as tags.  admin skips it, as it does in filter().
+# False when the caller can see nothing at all, so there is nothing to query.
+my sub acl_clause ( $query, $where, $bind ) {
+
+    # raw skips filter() altogether in the flat file model, acls included.
+    # Only bin/migrate.pl and an index rebuild ask for it.
+    return 1 if $query->{raw};
+
+    my $acls = ref $query->{acls} eq 'ARRAY' ? $query->{acls} : [];
+    return 0 unless @$acls;
+    return 1 if any { $_ eq 'admin' } @$acls;
+
+    my $binds = join( ',', map { '?' } @$acls );
+    push( @$where, "p.id IN (SELECT post_id FROM post_tags WHERE tag IN ($binds))" );
+    push( @$bind,  @$acls );
+    return 1;
+}
+
+=head2 like_clause($term)
+
+The 'like' filter: a case insensitive substring match over a post's title and
+its content.
+
+Answered by the FTS5 index, which is built with the trigram tokenizer precisely
+so that substring is a thing it can answer.  The term goes in as a quoted
+phrase, doubling any quote in it, so that a search for C<AND> or C<"> is a
+search for that text rather than FTS5 query syntax the user did not ask for.
+
+Trigram indexes nothing shorter than three characters, so shorter terms fall
+back to a LIKE scan.  That is the slow path, and it is the only one -- but a one
+or two character search matches most of the site anyway.
+
+=cut
+
+my sub like_clause ($term) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 12 lines, which would overcomplicate where()
+
+    if ( length($term) < 3 ) {
+        my $escaped = $term;
+        $escaped =~ s/([\\%_])/\\$1/g;
+        return ( "(p.title LIKE ? ESCAPE '\\' OR p.data LIKE ? ESCAPE '\\')", "%$escaped%", "%$escaped%" );
+    }
+
+    my $phrase = $term;
+    $phrase =~ s/"/""/g;
+    return ( 'p.id IN (SELECT rowid FROM posts_fts WHERE posts_fts MATCH ?)', qq{"$phrase"} );
+}
+
+# filter(), clause for clause.  Read the two side by side when changing either.
+# Returns nothing when no post can match, and then there is no query to run.
+my sub where ($query) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 77 lines, which would overcomplicate build_query()
+    my ( @where, @bind );
+
+    # Which versions are in play.  Everything else filters within that.
+    #
+    # raw is the exception: it means "the history, as stored", which is what a
+    # migration or an index rebuild reads, so it pins nothing.
+    if ( pinned($query) ) {
+        push( @where, 'p.version = ?' );
+        push( @bind,  int( $query->{version} ) );
+    }
+    elsif ( !$query->{raw} ) {
+        push( @where, 'p.id = v.latest_id' );
+    }
+
+    # An id, title or aclname query is answered on its own, with no tag or date
+    # filtering after it, but still only if the caller may see it -- exactly as
+    # filter() does for these three.
+    foreach my $key (qw{id title aclname}) {
+        next unless $query->{$key};
+        my $column = $key eq 'id' ? 'p.uuid' : "p.$key";
+        push( @where, "$column = ?" );
+        push( @bind,  $query->{$key} );
+        return unless acl_clause( $query, \@where, \@bind );
+        return ( \@where, \@bind );
+    }
+
+    # Against the first version's date, not this row's.  filter() applies these
+    # after dedup_versions() has already rewritten created to the oldest
+    # version's, so older/newer have always meant the post's birthday rather
+    # than the date of its most recent edit.
+    if ( $query->{older} ) {
+        ( my $older = $query->{older} ) =~ s/\D//g;
+        push( @where, 'v.first_created < ?' );
+        push( @bind,  $older );
+    }
+    if ( $query->{newer} ) {
+        ( my $newer = $query->{newer} ) =~ s/\D//g;
+        push( @where, 'v.first_created > ?' );
+        push( @bind,  $newer );
+    }
+
+    # Any one of these tags.  post_tags is one row per tag per post version, so
+    # membership is an indexed lookup rather than a scan of every post's array.
+    if ( ref $query->{tags} eq 'ARRAY' && @{ $query->{tags} } ) {
+        my $binds = join( ',', map { '?' } @{ $query->{tags} } );
+        push( @where, "p.id IN (SELECT post_id FROM post_tags WHERE tag IN ($binds))" );
+        push( @bind,  @{ $query->{tags} } );
+    }
+
+    # None of these.
+    if ( ref $query->{exclude_tags} eq 'ARRAY' && @{ $query->{exclude_tags} } ) {
+        my $binds = join( ',', map { '?' } @{ $query->{exclude_tags} } );
+        push( @where, "p.id NOT IN (SELECT post_id FROM post_tags WHERE tag IN ($binds))" );
+        push( @bind,  @{ $query->{exclude_tags} } );
+    }
+
+    return unless acl_clause( $query, \@where, \@bind );
+
+    if ( $query->{form} ) {
+        push( @where, 'COALESCE(p.form, ?) = ?' );
+        push( @bind, '', $query->{form} );
+    }
+
+    if ( $query->{author} ) {
+        push( @where, 'p.user = ?' );
+        push( @bind,  $query->{author} );
+    }
+
+    if ( ( $query->{like} // q{} ) ne q{} ) {
+        my ( $clause, @like_bind ) = like_clause( $query->{like} );
+        push( @where, $clause );
+        push( @bind,  @like_bind );
+    }
+
+    return ( \@where, \@bind );
+}
+
+my sub build_query ($query) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 41 lines, which would overcomplicate read()
+    my $select = q{SELECT p.post_data, p.uuid, p.version, v.version_max, v.first_created, f.author AS first_author};
+
+    my ( $where, $bind ) = where($query) or return;
+
+    # One version of one post per row, so "the current post" is a join against
+    # post_versions, which the schema's triggers keep pointing at the newest
+    # row for each uuid.  f is the oldest version, which is where
+    # dedup_versions() takes the post's own birthday and original author from.
+    my $from = q{
+        FROM posts p
+        JOIN post_versions v ON v.uuid = p.uuid
+        JOIN posts f ON f.id = v.first_id
+    };
+
+    # A raw read with no filters has no clauses at all, and "WHERE" on its own
+    # is a syntax error rather than "everything".
+    push( @$where, '1 = 1' ) unless @$where;
+
+    my $sql = "$select $from WHERE " . join( ' AND ', @$where );
+
+    # Newest first, by the same date the caller gets back as created -- the
+    # post's birthday.  The flat file model returned posts in readdir order,
+    # which is to say whatever order the filesystem felt like; every caller that
+    # cared went through the tag index, which ordered by created DESC.
+    $sql .= ' ORDER BY v.first_created DESC, p.uuid DESC';
+
+    # 0 means unlimited, as it does in the flat file model.
+    my @extra;
+    my $limit = defined $query->{limit} ? int( $query->{limit} ) : 25;
+    if ($limit) {
+        $sql .= ' LIMIT ?';
+        push( @extra, $limit );
+        if ( $query->{page} ) {
+            $sql .= ' OFFSET ?';
+            push( @extra, ( int( $query->{page} ) - 1 ) * $limit );
+        }
+    }
+
+    return ( $sql, @$bind, @extra );
+}
+
+=head2 read($query) = ARRAYREF $posts
+
+The rows a query selects, decoded back into posts.
+
+With C<raw>, every version of everything the query matches, untouched -- that is
+what an index build or a version history wants.  Otherwise one post per id: the
+newest version, carrying the version_max, created, modified and author fields
+that Trog::DataModule::dedup_versions() would have computed by hand.
+
+=cut
+
+sub read ( $, $query = {} ) {
+    my ( $sql, @bind ) = build_query($query) or return [];
+
+    my $rows = dbh()->selectall_arrayref( $sql, { Slice => {} }, @bind );
+    return [] unless ref $rows eq 'ARRAY';
+
+    my @posts;
+    foreach my $row (@$rows) {
+        my $post = eval { $parser->decode( $row->{post_data} ) };
+        if ( !$post ) {
+            WARN("Could not decode post '$row->{uuid}' version $row->{version}: $@");
+            next;
+        }
+        if ( !$query->{raw} ) {
+
+            # What dedup_versions() works out by sorting the versions in Perl.
+            # Deliberately the same shape, so a caller cannot tell which data
+            # model answered it.
+            $post->{version_max} = $row->{version_max};
+
+            # Only when we were not asked for one version in particular.
+            # dedup_versions() rewrites these from the version history, and a
+            # request for version 3 wants version 3's own dates, not the post's.
+            if ( !pinned($query) ) {
+                $post->{modified} = $post->{created};
+                $post->{created}  = $row->{first_created};
+                $post->{author}   = $row->{first_author};
+            }
+        }
+
+        push( @posts, $post );
+    }
+
+    return \@posts;
+}
+
+my sub insert ( $dbh, $data ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 21 lines, which would overcomplicate write()
+    my $insert = $dbh->prepare('INSERT INTO posts (post_data) VALUES (?)');
+
+    foreach my $post (@$data) {
+        confess "Cannot write a post with no id" unless $post->{id};
+
+        # Not stored: they are computed per query from the version history, and
+        # writing them would bake one query's answer into the post forever.
+        my %stored = %$post;
+        delete @stored{qw{version_max modified display_name user_class post_id}};
+        $stored{version} //= 0;
+
+        # Caught to name the post: a rejected write -- the unique index catching
+        # two workers on the same version, most of all -- otherwise dies with
+        # the message of DBI alone, which does not say which post it was.
+        eval { $insert->execute( $parser->encode( \%stored ) ); 1 }
+          or confess "Could not write post '$post->{id}' version $stored{version}: $@";
+    }
+
+    return 1;
+}
+
+=head1 WRITING
+
+=head2 write($posts)
+
+Insert each post as a new row.
+
+No read-modify-write, and so nothing to lose: the flat file model had to take a
+lock around rewriting the whole version history of a post, because the history
+was the file.  Here a version is a row, and the unique index on (uuid, version)
+is what rejects two workers writing the same version rather than one of them
+silently winning.
+
+Several posts go in as one transaction, so a batch either lands or it doesn't --
+add() hands us everything it was given at once, and half a save is not a state
+anybody asked for.  It is also the difference between a migration taking seconds
+and taking minutes, since SQLite otherwise commits once per row.
+
+=cut
+
+sub write ( $, $data ) {
+    my $dbh = dbh();
+
+    Trog::SQLite::transaction( $dbh, sub { insert( $dbh, $data ) } );
+    return 1;
+}
+
+=head2 versions_present() = HASHREF
+
+Every (uuid, version) already stored, as C<< { uuid => { version => 1 } } >>.
+
+For bulk importers, which would otherwise ask the database once per post
+whether it has seen it before.  See bin/migrate.pl.
+
+=cut
+
+sub versions_present {
+    my $rows = dbh()->selectall_arrayref( 'SELECT uuid, version FROM posts', { Slice => {} } ) // [];
+
+    my %present;
+    $present{ $_->{uuid} }{ $_->{version} } = 1 foreach @$rows;
+    return \%present;
+}
+
+=head2 delete(@posts)
+
+Remove every version of each post.  The triggers in the schema take the tag rows
+and the search index with them.
+
+=cut
+
+sub delete ( $, @posts ) {
+    my $dbh    = dbh();
+    my $delete = $dbh->prepare('DELETE FROM posts WHERE uuid = ?');
+
+    $delete->execute( $_->{id} ) foreach @posts;
+
+    return 0;
+}
+
+=head2 count() = INT
+
+How many posts there are, counting a post once however many versions it has.
+
+=cut
+
+sub count {
+    my ($count) = dbh()->selectrow_array('SELECT COUNT(DISTINCT uuid) FROM posts');
+    return $count // 0;
+}
+
+=head2 index_fields(@fields)
+
+Give each named custom field a virtual column and an index, and take the indexes
+back off the fields no longer named.
+
+This is what the Post Type Wizard's per-field "Index this field" checkbox does
+when the site is on this data model.  A virtual generated column costs no
+storage and ADD COLUMN on one rewrites nothing, so the expensive half is
+building the index, which is a one-off.
+
+Called with every indexed field across every post type, not just the type that
+was saved -- two types can declare the same field name, and reconciling against
+the whole picture is what stops saving one of them dropping the other's index.
+
+Only indexes this created are ever dropped, which is why they carry a prefix.
+The columns are left in place: they cost nothing, something may reference one,
+and re-ticking the box then only has to rebuild the index.
+
+Field names are re-validated here rather than trusted from the caller -- they
+reach SQLite as an identifier and a JSON path, neither of which can be bound as
+a parameter.
+
+=cut
+
+our $index_prefix = 'posts_custom_';
+
+# The columns schema/sqlite.schema defines for itself.  The wizard already
+# refuses a custom field named after anything in the post schema, which covers
+# most of these; this is the backstop for the ones that are not post fields at
+# all, and it is what stops "index this field" quietly indexing the blob.
+our %reserved = map { $_ => 1 } qw{id post_data uuid version created title user author form aclname visibility local_href data};
+
+sub index_fields ( $, @fields ) {
+    my $dbh = dbh();
+
+    my %want;
+    foreach my $field (@fields) {
+        my ($safe) = ( $field // '' ) =~ m/^([[:lower:]][[:lower:]\d_]{0,31})$/;
+        if ( !defined $safe ) {
+            WARN( "Refusing to index '" . ( $field // '' ) . "': not a field name" );
+            next;
+        }
+        if ( $reserved{$safe} ) {
+            WARN("Refusing to index '$safe': the schema owns that column, and already indexes the ones worth indexing");
+            next;
+        }
+        $want{$safe} = 1;
+    }
+
+    # Whatever is already there, base columns included.  A custom field can
+    # never be named after one of those -- the wizard refuses any name already
+    # in the post schema -- so anything found here is either ours or was added
+    # by hand, and either way there is nothing to add.
+    #
+    # xinfo rather than info: table_info omits generated columns, which is every
+    # column on this table bar the blob, so it would report an empty slate every
+    # time and ADD COLUMN would fail on the second call for the same field.
+    my %have = map { $_->{name} => 1 } @{ $dbh->selectall_arrayref( 'PRAGMA table_xinfo(posts)', { Slice => {} } ) // [] };
+
+    my $built = 0;
+    foreach my $field ( sort keys %want ) {
+        if ( !$have{$field} ) {
+            ## no critic(ValuesAndExpressions::PreventSQLInjection) -- $field is the anchored capture above
+            eval { $dbh->do("ALTER TABLE posts ADD COLUMN $field TEXT GENERATED ALWAYS AS (json_extract(post_data, '\$.$field')) VIRTUAL"); 1 }
+              or confess "Could not add a column for '$field': $@";
+        }
+
+        ## no critic(ValuesAndExpressions::PreventSQLInjection) -- as above
+        eval { $dbh->do("CREATE INDEX IF NOT EXISTS $index_prefix$field ON posts($field)"); 1 }
+          or confess "Could not index '$field': $@";
+        $built++;
+    }
+
+    # Anything we built before and were not asked for this time.
+    my $ours = $dbh->selectall_arrayref(
+        "SELECT name FROM sqlite_master WHERE type = 'index' AND tbl_name = 'posts' AND name LIKE ?",
+        { Slice => {} },
+        "$index_prefix%"
+    ) // [];
+
+    my $dropped = 0;
+    foreach my $index ( map { $_->{name} } @$ours ) {
+        my $field = substr( $index, length($index_prefix) );
+        next if $want{$field};
+
+        ## no critic(ValuesAndExpressions::PreventSQLInjection) -- $index came out of sqlite_master
+        eval { $dbh->do("DROP INDEX IF EXISTS $index"); 1 } or confess "Could not drop the index on '$field': $@";
+        $dropped++;
+    }
+
+    INFO("Indexed $built custom field(s), dropped $dropped") if $built || $dropped;
+    return $built;
+}
+
+=head2 tags() = @tags
+
+Every tag in use, from the index the schema's triggers maintain.
+
+=cut
+
+sub tags {
+    my $rows = dbh()->selectall_arrayref( 'SELECT DISTINCT tag FROM post_tags ORDER BY tag', { Slice => {} } );
+    return () unless ref $rows eq 'ARRAY';
+    return map { $_->{tag} } @$rows;
+}
+
+1;

lib/Trog/DataSource.pm

@@ -0,0 +1,261 @@
+package Trog::DataSource;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Trog::DataModule ();
+use Trog::Log        qw{:all};
+
+=head1 Trog::DataSource
+
+What a datasource is, and the default answers for the parts of it a given
+datasource doesn't care to implement.
+
+A post type can say its posts come from somewhere other than the datastore --
+see Trog::DataSource::Virt, which builds them out of libvirt guests.  The series
+is still an ordinary post; only its children are synthesized, and they are
+rebuilt on every view rather than stored.
+
+Datasources are plain packages under this namespace, called as functions rather
+than methods, and named by a post type's sidecar in x-tcms-datasource.
+
+=head1 THE CONTRACT
+
+    posts($series, $query) = @posts       required
+
+The children of $series, as post hashrefs.  Enough of a post to survive being
+rendered like one -- see Trog::DataSource::Virt::post_for for the shape.
+
+    EDITABLE                              optional method
+
+Whether the wizard should generate an editor for a type drawn from this source.
+A source which builds its posts from somewhere else has nothing to edit, so it
+returns false.  Saying nothing means yes.
+
+    CACHEABLE                             optional method
+
+Whether a page drawn from this source may be saved as a static render.  Saying
+nothing means no -- see cacheable() for why that is the safe way round.
+
+    filter($query, @posts) = @posts       optional
+
+Apply the viewer's search to the synthesized posts.  Defaulted below; implement
+it to search the fields your posts actually carry.
+
+    order($query, @posts) = @posts        optional
+
+The order they belong in.  Defaulted below; implement it if your posts have an
+order of their own that a date and a title don't capture.
+
+    lang() = STRING                       optional
+    help() = STRING                       optional
+
+What the search box is searching, and where to read about it, for a page drawn
+from this source.  Defaulted below.
+
+=head1 A NOTE ON WHAT A LISTING DISCLOSES
+
+A datasource turns something into a list, and a list of names is itself
+information.  Two things follow that are worth thinking about before you write
+one.
+
+The first is that the names may be more sensitive than the things.  A file whose
+contents the webserver will refuse to serve still has a name, and publishing that
+name publishes the fact of it.  Decide deliberately what your source is willing
+to enumerate, rather than enumerating whatever it can reach and relying on
+whatever gates the contents.
+
+The second is that the webserver is part of the security model and you cannot see
+it from here.  On a correctly provisioned site nginx auth_requests the
+/authenticated route -- which answers 200 for a request carrying a live session
+and 403 otherwise -- and gates www/assets/private on the result.  That protection
+is real, it is why that route exists, and it is also invisible to this code and
+absent on a site provisioned some other way.  Do not lean on it, and do not
+duplicate it either: your job is to decide what to put in the list.
+
+Trog::DataSource::DirIndex is the worked example, and documents where it drew
+that line and why.
+
+=head1 FUNCTIONS
+
+=head2 filter($query, @posts) = @posts
+
+The default search over synthesized posts: the query's C<like>, C<author>,
+C<older> and C<newer>, with the same meanings they have for stored posts.
+
+Deliberately not the tag, acl or version filtering Trog::DataModule::filter()
+also does.  Those are answers about the datastore, and they are already settled
+before a datasource is reached: the series carries the acls, the reader got to
+its page by holding them, and every synthesized post belongs to that series.
+Applying them again would at best be redundant, and at worst would blank the
+page for a source whose posts carry no tags -- which nothing requires them to.
+
+Nor does it paginate.  That is the route's job and is the same for every source
+-- see order(), which is the part a source does get a say in.
+
+A source with more to search than a title should say so by implementing filter()
+rather than by hoping this one covers it.
+
+=cut
+
+sub filter ( $query, @posts ) {
+    $query //= {};
+
+    if ( ( $query->{like} // q{} ) ne q{} ) {
+        my $like = $query->{like};
+        @posts = grep { searchable_match( $like, $_->{title}, $_->{data} ) } @posts;
+    }
+
+    @posts = grep { ( $_->{user} // '' ) eq $query->{author} } @posts if $query->{author};
+
+    # Coerced to a number the same way Trog::DataModule::filter() does it, since
+    # this arrives straight off a query string.
+    if ( $query->{older} ) {
+        ( my $older = $query->{older} ) =~ s/\D//g;
+        @posts = grep { ( $_->{created} // 0 ) < $older } @posts if $older;
+    }
+    if ( $query->{newer} ) {
+        ( my $newer = $query->{newer} ) =~ s/\D//g;
+        @posts = grep { ( $_->{created} // 0 ) > $newer } @posts if $newer;
+    }
+
+    return @posts;
+}
+
+=head2 searchable_match($like, @values) = BOOL
+
+Whether any of @values contains $like, case insensitively.
+
+The same case insensitive substring test Trog::DataModule::filter() applies to a
+stored post's title and body, factored out so that a datasource can hand it the
+fields its own posts actually carry without having to restate what a search
+means.  Quotemeta'd, so a search for '*' looks for an asterisk.
+
+Anything in @values which isn't a plain string is skipped, so an arrayref body
+or a nested structure is passed over rather than matched against its address.
+
+=cut
+
+sub searchable_match ( $like, @values ) {
+    return 0 if ( $like // q{} ) eq q{};
+
+    foreach my $value (@values) {
+        next     if !defined $value || ref $value;
+        return 1 if $value =~ m/\Q$like\E/i;
+    }
+    return 0;
+}
+
+=head2 order($query, @posts) = @posts
+
+The order synthesized posts belong in: newest first, then by title, then by id.
+
+Pagination hands out page 2 of an order, so there had better be one, and it had
+better be the same order next time somebody asks -- a list that comes back
+shuffled makes page 2 a lottery rather than the next page.  Sorting the ties out
+by title and then id is what makes this total rather than merely mostly decided.
+
+Newest-first matches how stored posts are listed.  The tiebreaks carry the
+weight in practice, because a source that builds its posts on the fly tends to
+stamp them all with the time it built them: every libvirt guest comes back with
+the same created, so what this really does for that page is sort it by name.
+
+=cut
+
+sub order ( $, @posts ) {
+    my @sorted = sort { ( $b->{created} // 0 ) <=> ( $a->{created} // 0 ) || ( $a->{title} // '' ) cmp ( $b->{title} // '' ) || ( $a->{id} // '' ) cmp ( $b->{id} // '' ) } @posts;    ## no critic (BuiltinFunctions::ProhibitReverseSortBlock) -- descending by the first key and ascending by the rest, which reverse cannot say
+    return @sorted;
+}
+
+=head2 lang() = STRING
+
+What the search box searches on a page drawn from a datasource which hasn't said.
+
+Not the data model's answer: the model's query language describes what it can do
+to the datastore, and a datasource page is not being served out of the datastore.
+
+=cut
+
+sub lang { return 'Case insensitive substring' }
+
+=head2 help() = STRING
+
+Where to read about it.
+
+=cut
+
+sub help { return 'https://en.wikipedia.org/wiki/Substring' }
+
+=head2 cacheable($source) = BOOL
+
+Whether pages drawn from $source may be cached as static renders.
+
+A datasource page is cached like any other unless something says not to, and
+nothing else ever invalidates it: saving a post does not, because no post was
+saved -- whatever the source draws on changed instead.  So a source has to
+answer one of two questions, and it has to answer deliberately.
+
+Either it knows what it depends on and can say when that changes, in which case
+it should register a watch (Trog::DataSource::DirIndex::watch is the worked
+example) and declare CACHEABLE.  Or it doesn't, in which case its pages must not
+be cached at all, because the cached copy has no way of ever becoming right
+again.
+
+Absent means not cacheable.  A source whose author has not thought about
+invalidation gets the answer that is merely slow rather than the one that is
+wrong.
+
+=cut
+
+sub cacheable ($source) {
+    return 0 unless $source && $source->can('CACHEABLE');
+    return $source->CACHEABLE ? 1 : 0;
+}
+
+=head2 for_type($form) = STRING or undef
+
+The datasource a post type names, or nothing when it names none.
+
+Checked against this namespace rather than requiring whatever we were told to:
+the name comes out of a sidecar, and a sidecar cannot be allowed to make us load
+an arbitrary module.  Returns the module name without loading it; see load().
+
+=cut
+
+sub for_type ( $form = '' ) {
+    return undef unless $form;
+
+    my $meta   = Trog::DataModule::type_meta_for($form);
+    my $source = $meta->{'x-tcms-datasource'};
+    return undef if !$source || ref $source;
+
+    if ( $source !~ m/^Trog::DataSource::\w+$/ ) {
+        WARN("Post type '$form' names a datasource '$source' which isn't one");
+        return undef;
+    }
+
+    return $source;
+}
+
+=head2 load($source) = BOOL
+
+Load a datasource named by for_type(), returning whether it worked.
+
+=cut
+
+sub load ($source) {
+    my $modpath = $source;
+    $modpath =~ s{::}{/}g;
+    $modpath .= '.pm';
+
+    local $@;
+    eval { require $modpath; 1 } or do {
+        WARN("Datasource '$source' will not load: $@");
+        return 0;
+    };
+
+    return 1;
+}
+
+1;

lib/Trog/DataSource/DirIndex.pm

@@ -0,0 +1,390 @@
+package Trog::DataSource::DirIndex;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Cwd         ();
+use Digest::SHA qw{sha256_hex};
+use Path::Tiny  ();
+use URI::Escape ();
+
+use Trog::DataSource ();
+use Trog::Utils      ();
+
+use Trog::Log qw{WARN DEBUG};
+
+=head1 Trog::DataSource::DirIndex
+
+Builds posts out of the contents of a directory.
+
+A series says which directory in its C<directory> field, and its children become
+one post per entry: a file listing, a download page, a gallery, whatever the post
+type's template makes of it.  Nothing is written to the datastore -- the
+directory is the source of truth, and the posts are rebuilt from it on every
+view.
+
+    "x-tcms-datasource": "Trog::DataSource::DirIndex"
+
+Build the child type in the Post Type Wizard and pick this as its datasource.
+The fields each entry carries are listed under posts() below; a template can use
+any of them.
+
+=head2 EDITABLE
+
+False.  An entry is built from the filesystem every time the page is drawn and
+has nothing behind it to save, so a post type backed by this wants no editor:
+a form posting to /post/save would write a real post to sit alongside, and
+collide with, the synthesized ones.  Put files in the directory instead.
+
+=cut
+
+sub EDITABLE { return 0 }
+
+=head2 CACHEABLE
+
+True, which is only defensible because of the watch watch() registers.  A
+listing is cheap to build but there is no reason to build it per request, and the
+one thing that would make a cached copy wrong -- the directory changing -- is
+exactly the thing inotify tells us about.
+
+Take that watch away and this has to become false, or the page is stale with no
+way of ever becoming right again.
+
+=cut
+
+sub CACHEABLE { return 1 }
+
+=head1 WHAT MAY BE INDEXED
+
+Only directories under C<www/>, and never C<www/assets/private>.
+
+That is not arbitrary caution.  Everything under www/ is already served to
+anybody who asks, so listing it discloses nothing that a guessed URL would not --
+whereas a listing of anywhere else hands out the names of files the webserver
+would refuse to serve, and names are frequently the interesting part.
+
+=head2 A NOTE ON www/assets/private
+
+The refusal is a guard rail against an operator mistake, and not the thing that
+makes private assets private.
+
+Private uploads live under www/assets/private, and on a correctly provisioned
+site nginx is what protects them: it auth_requests the /authenticated route,
+which answers 200 for a request carrying a live session and 403 for one that
+isn't, and serves the file or refuses it accordingly.  That is the entire reason
+that route exists.  So pointing a listing at that directory does not hand the
+files out -- a reader who follows one of the links still gets asked to log in.
+
+What it would hand out is the names, which the site owner probably did not mean
+to publish either, and which nothing else would stop.  Sharing that directory is
+operator error; refusing it here is cheap, and turns a mistake made in a text
+field into an error in the log rather than a disclosure nobody notices.  If you
+genuinely want to publish a listing of it, put the files somewhere public instead
+-- that is what the distinction between the two directories is for.
+
+None of this holds if the site is served without that nginx configuration.  See
+the nginxproxy recipe referenced in the Readme; several features besides this one
+assume it.
+
+=head2 SYMLINKS
+
+Resolved before the containment check, so entries pointing outside the tree are
+left out of the listing rather than shown with a link that will not work.
+
+=cut
+
+our $root    = 'www';
+our @refused = ('www/assets/private');
+
+# Path containment, done on the resolved paths rather than on the strings the
+# caller handed us: /www-backup is not inside /www, however it reads.
+my sub within ( $path, $within ) {
+    return 1 if $path eq $within;
+    return index( $path, "$within/" ) == 0;
+}
+
+# Everything this is allowed to look at, or nothing.  Returns the absolute path
+# and the path relative to the tCMS root, since the first is what we read and
+# the second is what we log and watch.
+my sub resolve ($directory) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 46 lines, which would overcomplicate posts()
+    return undef unless $directory;
+
+    # Before abs_path, which would happily resolve one for us.
+    if ( $directory =~ m{(?:^|/)\.\.(?:/|$)} ) {
+        WARN("Refusing to index '$directory': it walks upwards");
+        return undef;
+    }
+
+    my $base = Cwd::abs_path($root);
+    if ( !$base ) {
+        WARN("Refusing to index '$directory': there is no $root here to index under");
+        return undef;
+    }
+
+    # Relative to the tCMS root, and named with or without the www/ prefix --
+    # 'assets/pics' and 'www/assets/pics' are the same directory, and somebody
+    # writing it into a form will pick whichever occurs to them.
+    my $candidate = $directory;
+    $candidate = "$root/$candidate" unless $candidate =~ m{^\Q$root\E(?:/|$)};
+
+    my $absolute = Cwd::abs_path($candidate);
+    if ( !$absolute || !-d $absolute ) {
+        WARN("Refusing to index '$directory': it is not a directory here");
+        return undef;
+    }
+
+    if ( !within( $absolute, $base ) ) {
+        WARN("Refusing to index '$directory': it resolves outside $root");
+        return undef;
+    }
+
+    foreach my $refused (@refused) {
+        my $forbidden = Cwd::abs_path($refused);
+        next unless $forbidden;
+        next unless within( $absolute, $forbidden );
+
+        WARN("Refusing to index '$directory': $refused holds files the webserver gates, so its names are gated too");
+        return undef;
+    }
+
+    my $relative = $absolute;
+    $relative =~ s{^\Q$base\E/?}{};
+
+    return { absolute => $absolute, relative => $relative ne q{} ? "$root/$relative" : $root };
+}
+
+my sub human_size ($bytes) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 12 lines, which would overcomplicate post_for()
+    return '' unless defined $bytes;
+    return "$bytes B" if $bytes < 1024;
+
+    my @units = qw{KB MB GB TB PB};
+    my $size  = $bytes / 1024;
+    foreach my $unit (@units) {
+        return sprintf( '%.1f %s', $size, $unit ) if $size < 1024 || $unit eq $units[-1];
+        $size /= 1024;
+    }
+    return "$bytes B";
+}
+
+my sub post_for ( $name, $dir, $series ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 76 lines, which would overcomplicate posts()
+    my $absolute = "$dir->{absolute}/$name";
+
+    # Resolved, so a symlink pointing out of the tree is left out rather than
+    # listed with a link the webserver will not honour.
+    my $real = Cwd::abs_path($absolute);
+    if ( !$real || !within( $real, Cwd::abs_path($root) ) ) {
+        DEBUG("Skipping $name: it points outside $root");
+        return undef;
+    }
+
+    my @stat = stat($absolute);
+    return undef unless @stat;
+
+    my $is_dir = -d _    ? 1 : 0;
+    my $size   = $is_dir ? 0 : $stat[7];
+    my $mtime  = $stat[9];
+
+    # Relative to www/, which is also its URL.
+    my $path = "$dir->{relative}/$name";
+    $path =~ s{^\Q$root\E/?}{};
+
+    my ($extension) = $is_dir ? ('') : ( lc( $name =~ m/\.([^.]+)$/ ? $1 : '' ) );
+
+    my $content_type = $is_dir ? 'inode/directory' : ( Trog::Utils::mime_type($absolute) // 'application/octet-stream' );
+
+    # Escaped per segment: a filename may legally hold a space, a question mark
+    # or a hash, and none of those survive being dropped into an href as they
+    # are.  Per segment rather than wholesale, or the separators go too.
+    my $href = '/' . join( '/', map { URI::Escape::uri_escape($_) } split( m{/}, $path ) );
+
+    my $post = {
+
+        # Stable across renders, because pagination and page anchors need it to
+        # be, and opaque because a filename is not a thing to put in a URL.
+        id => 'dirindex-' . substr( sha256_hex($path), 0, 32 ),
+
+        title => $name,
+        name  => $name,
+        path  => $path,
+        data  => '',
+
+        # Which template renders it.  posts.tx dispatches on this, so without it
+        # the entries come out through the default form rather than the type the
+        # series named, and the page looks empty.
+        form => $series->{child_form},
+
+        is_dir     => $is_dir,
+        size       => $size,
+        size_human => human_size($size),
+        mtime      => $mtime,
+        extension  => $extension,
+
+        content_type => $content_type,
+        is_image     => ( $content_type =~ m{^image/} ? 1 : 0 ),
+        is_video     => ( $content_type =~ m{^video/} ? 1 : 0 ),
+        is_audio     => ( $content_type =~ m{^audio/} ? 1 : 0 ),
+
+        # Where the thing actually is.  The title links to the file and so does
+        # the permalink, because for a listing they are the same thing.
+        local_href => $href,
+        href       => $href,
+
+        # Enough of a post to survive being rendered like one.  The tags and
+        # visibility come from the series, as they do for every datasource:
+        # the reader reached this page by holding the series' acls.
+        tags       => $series->{tags}       // [],
+        visibility => $series->{visibility} // 'private',
+        created    => $mtime,
+        version    => 0,
+        user       => $series->{user},
+        method     => 'GET',
+    };
+
+    return $post;
+}
+
+=head1 FUNCTIONS
+
+=head2 posts($series, $query) = @posts
+
+One post per entry in the series' directory.
+
+Each carries, beyond what every post has:
+
+    name        the entry's own name, as on disk
+    path        its path relative to www/
+    is_dir      whether it is a directory
+    size        bytes, 0 for a directory
+    size_human  the same, as a human reads it
+    mtime       last modification, which is also the post's created
+    extension   lowercased, without the dot, empty for a directory
+    is_image / is_video / is_audio    from the content type, as a stored post gets
+
+Registers an inotify watch on the directory the first time it is asked, so that
+the static render of this page is thrown away when the directory changes.  See
+watch().
+
+=cut
+
+sub posts ( $series, $query ) {
+    my $dir = resolve( $series->{directory} );
+    return () unless $dir;
+
+    watch( $query, $dir->{relative} );
+
+    my @entries;
+    eval {
+        @entries = map { $_->basename } Path::Tiny::path( $dir->{absolute} )->children(qr/\A[^.]/);
+        1;
+    } or do {
+        WARN("Could not read $dir->{relative}: $@");
+        return ();
+    };
+
+    my @out;
+    foreach my $entry ( sort @entries ) {
+        my $post = post_for( $entry, $dir, $series );
+        push( @out, $post ) if $post;
+    }
+
+    return @out;
+}
+
+=head2 filter($query, @posts) = @posts
+
+Apply the reader's search to the listing.
+
+A listing's posts have no body, so the default -- which searches a post's title
+and body -- would only ever match the name.  Search the path and the extension
+as well, so that 'pdf' finds the PDFs and a subdirectory's name finds what is
+under it.
+
+=cut
+
+sub filter ( $query, @posts ) {
+    $query //= {};
+
+    if ( ( $query->{like} // q{} ) ne q{} ) {
+        my $like = $query->{like};
+        @posts = grep { Trog::DataSource::searchable_match( $like, $_->{name}, $_->{path}, $_->{extension} ) } @posts;
+    }
+
+    return Trog::DataSource::filter( { %$query, like => undef }, @posts );
+}
+
+=head2 order($query, @posts) = @posts
+
+Directories first, then by name.
+
+Not the default newest-first: this is a directory index, and the convention a
+reader expects from one is the convention every file browser has -- which also
+means page two holds what page one alphabetically ran out of, rather than
+whatever happened to be touched least recently.
+
+=cut
+
+sub order ( $, @posts ) {
+    my @sorted = sort { ( $b->{is_dir} // 0 ) <=> ( $a->{is_dir} // 0 ) || lc( $a->{name} // '' ) cmp lc( $b->{name} // '' ) || ( $a->{name} // '' ) cmp ( $b->{name} // '' ) } @posts;    ## no critic (BuiltinFunctions::ProhibitReverseSortBlock) -- descending by the first key and ascending by the rest, which reverse cannot say
+    return @sorted;
+}
+
+=head2 lang() = STRING
+
+What the search box searches on a directory listing.
+
+=head2 help() = STRING
+
+Where to read about it.
+
+=cut
+
+sub lang { return 'Case insensitive substring of a file name, path or extension' }
+sub help { return 'https://en.wikipedia.org/wiki/Substring' }
+
+=head2 watch($query, $directory)
+
+Ask tPSGI to tell us when the directory changes, and throw the static renders
+away when it does.
+
+These pages are cached exactly like any other: the render goes through
+Trog::Renderer, which hands anonymous, unparameterized, successful renders to
+tPSGI to save.  That is the whole point -- a directory listing is cheap to build
+but there is no reason to build it per request -- but a cached listing of a
+directory that has since changed is simply wrong, and nothing else would ever
+invalidate it.  A post being saved does not invalidate this page, because no post
+was saved: somebody dropped a file in a directory.
+
+Registered under an explicit key rather than the callback's address.  posts()
+runs per request and this closure is built fresh each time, so the default key
+would stack a new copy of the same callback on every single view.
+
+The callback uses the tPSGI object it is handed rather than the one from the
+request that registered it: watches are shared between workers, so whichever
+worker notices the change is the one that must do the invalidating.
+
+=cut
+
+sub watch ( $query, $directory ) {
+    my $tpsgi = $query->{tpsgi};
+    return 0 unless $tpsgi;
+
+    # tCMS runs under whatever tPSGI is installed, and watches arrived in it
+    # later than the rest of this.  Without them the listing is still correct,
+    # it just goes stale until something else invalidates the renders.
+    return 0 unless $tpsgi->can('add_watch');
+
+    $tpsgi->add_watch(
+        $directory,
+        sub {
+            my ( $watcher, $change ) = @_;
+            $watcher->invalidate_renders('html');
+            return 1;
+        },
+        key => "Trog::DataSource::DirIndex:$directory",
+    );
+
+    return 1;
+}
+
+1;

lib/Trog/DataSource/ProvisionedVirt.pm

@@ -0,0 +1,636 @@
+package Trog::DataSource::ProvisionedVirt;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use parent qw{Trog::DataSource::Virt};
+
+use Cwd                 ();
+use File::Path          ();
+use File::Slurper       ();
+use File::Slurper::Temp ();
+use POSIX               ();
+
+use Trog::Config     ();
+use Trog::DataSource ();
+use Trog::DataSource::Virt();
+use Trog::Auth  ();
+use Trog::Vault ();
+
+use Trog::Log qw{WARN INFO};
+
+=head1 Trog::DataSource::ProvisionedVirt
+
+Trog::DataSource::Virt, plus the recipe each guest was built from and a button to
+build it again.
+
+Everything about listing guests is inherited unchanged -- this is the same
+libvirt connection, the same posts, the same search and the same refusal to be
+cached.  What it adds is the other half of the story: a guest on a Troglodyne
+hypervisor was provisioned from a recipe, and the recipe is on disk next to the
+hypervisor rather than anywhere libvirt can tell you about.
+
+One repository owns that lifecycle.  trog-provisioner's bin/provision generates
+a guest's configuration from its recipe and then builds the machine out of it.
+The generator used to be a second repository and a second run; the two had to
+become one program once which hypervisor a guest lands on became a choice rather
+than whichever machine you happened to be sat at.
+
+Say where that checkout is and this becomes useful; leave it out and it degrades
+to plain Virt, which is what it is.
+
+    [provisioner]
+        trog_provisioner = /home/you/Code/trog-provisioner
+
+The recipes are not in the checkout.  They describe an installation rather than
+the software, so trog-provisioner keeps them in /etc/trog-provisioner, or
+wherever TROG_PROVISIONER_CONFIG says instead.  We find them by that same rule,
+which is one fewer thing to tell tCMS and one fewer thing to disagree about.
+
+=head1 A NOTE ON SAFETY
+
+Reprovisioning is not a recoverable operation.  It destroys the guest and builds
+it again from its recipe, and whatever was on it that the recipe does not
+describe does not come back.
+
+The discipline is the same as its parent's, and for the same reasons.  It is
+POST only and admin only; it refuses outright for the guest tCMS is itself
+running on, whatever the template chose to draw; and nothing it runs goes near a
+shell, so a guest name is an argument and can never be a command.
+
+=cut
+
+our $recipe_dir = 'recipes.d';
+our $log_dir    = 'logs/reprovision';
+
+# What the provisioner's two passwords are called in a user's vault.  One name
+# per person rather than one per guest: the passphrase is to their own secrets
+# database, and the sudo password is theirs on the hypervisor rather than
+# anything to do with a particular guest.
+our $secret_name = 'provisioner';
+our $sudo_name   = 'provisioner_sudo';
+
+# Where an installation's own files live, which is trog-provisioner's rule
+# rather than ours -- see its Trog::Config.
+our $provisioner_config = '/etc/trog-provisioner';
+
+# What a reprovision can be, in the order it can be it.
+our %states = (
+    running     => 'reprovisioning',
+    ok          => 'provisioned',
+    failed      => 'reprovision failed',
+    interrupted => 'reprovision interrupted',
+);
+
+# A guest name reaches the filesystem here, so it is a hostname or it is nothing.
+my sub safe_domain ($domain) {
+    return undef if !$domain || length $domain >= 254;
+    return undef if $domain =~ m/(?:^|\.)\.\.?(?:\.|$)/;
+
+    my ($safe) = $domain =~ m/^([[:alnum:]][\w.-]*)$/;
+    return $safe;
+}
+
+# An installation's recipes are where they are whether tCMS knows about the
+# provisioner or not, but reading them is the feature, so it is off with it.
+my sub _recipe_path ( $config, $domain ) {
+    return undef unless $config->{trog_provisioner};
+
+    my $safe = safe_domain($domain);
+    return undef unless $safe;
+
+    my $path = "$config->{recipes}/$safe.yaml";
+    return -f $path ? $path : undef;    ## no critic (ProhibitFiletest_f) -- is there a recipe for this guest
+}
+
+my sub with_recipe ( $post, $config ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 49 lines, which would overcomplicate posts()
+    return $post if $post->{unreachable};
+
+    my $domain = $post->{domain} // '';
+    my $path   = _recipe_path( $config, $domain );
+
+    if ($path) {
+        my $recipe = eval { File::Slurper::read_text($path) };
+        if ( defined $recipe ) {
+            $post->{recipe}      = $recipe;
+            $post->{recipe_path} = $path;
+            $post->{has_recipe}  = 1;
+        }
+        else {
+            WARN("Could not read the recipe for '$domain' at $path: $@");
+        }
+    }
+
+    # There has to be something to run it with, and we will not rebuild the
+    # machine we are answering the request from -- see act() in the parent,
+    # which refuses to power that one off for the same reason.
+    $post->{can_reprovision} =
+      ( $post->{has_recipe} && $config->{trog_provisioner} && !$post->{is_self} ) ? 1 : 0;
+
+    # Which of the things the button has to ask for.
+    $post->{passphrase_remembered} = $config->{remembered};
+    $post->{sudo_remembered}       = $config->{sudo_remembered};
+    $post->{can_remember}          = $config->{can_remember};
+
+    my $status = status($domain);
+    if ($status) {
+        $post->{reprovision_state}    = $status->{state};
+        $post->{reprovision_status}   = $states{ $status->{state} } // $status->{state};
+        $post->{reprovision_started}  = $status->{started};
+        $post->{reprovision_finished} = $status->{finished};
+        $post->{reprovision_exit}     = $status->{exit};
+        $post->{reprovision_by}       = $status->{user};
+        $post->{is_reprovisioning}    = $status->{state} eq 'running' ? 1 : 0;
+    }
+
+    # One at a time.  Two provisions of the same machine at once is not a thing
+    # anybody wants to have started by double clicking.
+    $post->{can_reprovision} = 0 if $post->{is_reprovisioning};
+
+    $post->{reprovision_log}      = log_tail($domain);
+    $post->{reprovision_log_href} = $post->{reprovision_log} ? "/guest/reprovision/log/$domain" : undef;
+
+    return $post;
+}
+
+=head2 config() = HASHREF
+
+Where the provisioner is checked out, from the tCMS configuration, and where the
+recipes it reads are, from trog-provisioner's own rule for that.
+
+    trog_provisioner    the checkout, or undef
+    recipes             the directory the guests' recipes are in
+
+Undef for the checkout means the feature is off rather than broken: a site which
+has not configured it gets a plain guest listing, which is what it asked for.
+
+=cut
+
+my sub config {
+    my $conf = Trog::Config::get();
+
+    # Nothing to configure here: the provisioner reads this env var or that
+    # directory, so a recipe we showed from anywhere else would be a recipe it
+    # is not going to build from.
+    my %config = ( recipes => ( $ENV{TROG_PROVISIONER_CONFIG} // $provisioner_config ) . "/$recipe_dir" );
+
+    my $dir = $conf->param('provisioner.trog_provisioner');
+    return \%config if !$dir || ref $dir;
+
+    # Resolved, and checked to be there.  A path in a config file which does not
+    # exist is a typo, and finding that out here beats finding it out halfway
+    # through a reprovision.
+    my $absolute = Cwd::abs_path($dir);
+    if ( !$absolute || !-d $absolute ) {
+        WARN("provisioner.trog_provisioner is set to '$dir', which is not a directory here");
+        return \%config;
+    }
+
+    $config{trog_provisioner} = $absolute;
+    return \%config;
+}
+
+=head1 FUNCTIONS
+
+=head2 posts($series, $query) = @posts
+
+The guests Trog::DataSource::Virt would have listed, each carrying what we know
+about how it was built:
+
+    recipe                the recipe's YAML, as text, for the page to show
+    recipe_path           where that came from
+    has_recipe            whether there was one at all
+    can_reprovision       whether the button should be drawn
+    reprovision_state     running, ok, failed, interrupted, or absent
+    reprovision_status    that, in words a person reads
+    reprovision_started   when the last run began
+    reprovision_finished  when it ended, if it has
+    reprovision_exit      what it exited with, if it has
+    reprovision_by        who asked for it
+    is_reprovisioning     whether one is going on right now
+    reprovision_log       the tail of the last run
+    reprovision_log_href  where to read all of it
+
+A guest with no recipe is still listed.  Plenty of guests on a hypervisor were
+not built by this, and saying nothing about them is better than hiding them.
+
+=cut
+
+sub posts ( $series, $query ) {
+    my @guests = Trog::DataSource::Virt::posts( $series, $query );
+    my $config = config();
+
+    # Asked once for the page rather than once per guest, and asked rather than
+    # opened: what the form needs to know is which box to draw.
+    my $user = $query->{user} // '';
+    $config->{can_remember}    = ( $user                   && Trog::Vault::has_key() )                  ? 1 : 0;
+    $config->{remembered}      = ( $config->{can_remember} && Trog::Vault::has( $user, $secret_name ) ) ? 1 : 0;
+    $config->{sudo_remembered} = ( $config->{can_remember} && Trog::Vault::has( $user, $sudo_name ) )   ? 1 : 0;
+
+    return map { with_recipe( $_, $config ) } @guests;
+}
+
+=head2 status($domain) = HASHREF or undef
+
+What the last reprovision of this guest is doing, or did.
+
+    state     running, ok, failed or interrupted
+    pid       the process doing it, while one is
+    started   / finished / exit / user
+
+Nothing waits on the process which does the work -- it is deliberately orphaned,
+so that it outlives the worker that started it -- which means its exit status is
+not reported to anybody.  This file is how it says what happened, and the last
+thing the run does is write it.
+
+A run whose status still says 'running' but whose process is gone therefore
+crashed, was killed, or took the machine down with it, and reads as interrupted.
+That is a guess from the one piece of evidence there is, and it is the honest
+one: the alternative is a page that says a provision is in progress forever.
+
+=cut
+
+sub status ($domain) {
+    my $safe = safe_domain($domain);
+    return undef unless $safe;
+
+    my $path = "$log_dir/$safe.status";
+    return undef unless -f $path;    ## no critic (ProhibitFiletest_f) -- has this ever run
+
+    my $raw = eval { File::Slurper::read_text($path) };
+    return undef unless defined $raw;
+
+    my %status;
+    foreach my $line ( split( /\n/, $raw ) ) {
+        my ( $key, $value ) = $line =~ m/^(\w+)=(\N*)$/;
+        $status{$key} = $value if defined $key;
+    }
+    return undef unless $status{state};
+
+    # kill 0 rather than trusting the file: the process is orphaned, so nothing
+    # else would ever correct a 'running' that stopped being true.  Same uid, so
+    # this is a real answer.  A recycled pid could fool it, which would show a
+    # finished run as still going rather than the other way about.
+    if ( $status{state} eq 'running' ) {
+        my $alive = $status{pid} && kill( 0, $status{pid} );
+        $status{state} = 'interrupted' unless $alive;
+    }
+
+    return \%status;
+}
+
+# Written by the run itself, at the two moments worth recording.  By rename, so
+# that a page drawn while the run is writing sees the old status or the new one
+# and never half of either -- the reader would ignore a torn file, but ignoring
+# it means the page says nothing was ever run.
+my sub write_status ( $domain, %fields ) {
+    my $path = "$log_dir/$domain.status";
+    my $out  = join( '', map { "$_=" . ( $fields{$_} // '' ) . "\n" } sort keys %fields );
+
+    local $@;
+    eval {
+        # Beside the file it replaces, or the rename is a copy across
+        # filesystems and stops being atomic.
+        local $File::Slurper::Temp::FILE_TEMP_DIR   = $log_dir;
+        local $File::Slurper::Temp::FILE_TEMP_PERMS = oct('644');
+        File::Slurper::Temp::write_text( $path, $out );
+        1;
+    } or WARN("Could not record the reprovision status for '$domain': $@");
+
+    return;
+}
+
+=head2 log_tail($domain) = STRING
+
+The last of whatever the previous reprovision said, or nothing.
+
+The run happens in a detached process which nobody is waiting on, so this file
+is the only account of it there is.
+
+=cut
+
+our $log_tail_bytes = 4096;
+
+sub log_tail ($domain) {
+    my $safe = safe_domain($domain);
+    return undef unless $safe;
+
+    my $path = "$log_dir/$safe.log";
+    return undef unless -f $path;    ## no critic (ProhibitFiletest_f) -- has this ever run
+
+    my $text = eval { File::Slurper::read_text($path) };
+    return undef unless defined $text;
+
+    return length($text) > $log_tail_bytes ? substr( $text, -$log_tail_bytes ) : $text;
+}
+
+=head2 log_for($domain) = STRING or undef
+
+The whole reprovision log for a guest, for the route which serves it.
+
+Undef when there has never been a run, or when the name is not a guest name --
+this reaches the filesystem, so it is checked here rather than trusted from the
+route that called it.
+
+=cut
+
+our $log_max_bytes = 1_048_576;    # 1 MiB
+
+sub log_for ($domain) {
+    my $safe = safe_domain($domain);
+    return undef unless $safe;
+
+    my $path = "$log_dir/$safe.log";
+    return undef unless -f $path;    ## no critic (ProhibitFiletest_f) -- has this ever run
+
+    my $text = eval { File::Slurper::read_text($path) };
+    return undef unless defined $text;
+
+    # A provisioner can be chatty and this goes out in one response.
+    return length($text) > $log_max_bytes
+      ? "[ truncated: showing the last " . int( $log_max_bytes / 1024 ) . "KB ]\n" . substr( $text, -$log_max_bytes )
+      : $text;
+}
+
+=head2 credentials(%args) = ($credentials, $why)
+
+What to hand the provisioner, out of whatever the form sent: a hashref of the
+names Trog::Credentials knows, or undef and a reason.
+
+A code is only ever exchanged for passwords that are already stored -- it is
+proof of presence, not a password, and there is nothing to derive from six
+digits.  Typed passwords are used as they are, and stored on the way past if
+they asked for that, so the next run is a code.
+
+The two are independent.  A sudo password typed into the form wins over a stored
+one, because somebody typing it has a reason to; and a hypervisor with
+passwordless sudo simply never has one, in the form or the vault, which is the
+ordinary case and not a missing answer.
+
+The reason, when there is one, is what the person reads -- so it has to tell
+'that code is stale' apart from 'there is nothing stored to unlock'.
+
+=cut
+
+my sub credentials (%args) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 58 lines, which would overcomplicate reprovision()
+    my $user = $args{user} // '';
+
+    my %credentials;
+
+    # What they typed, as opposed to what came back out of the vault.  Only the
+    # typed ones are worth filing away, and only they can be: a value fetched
+    # from the vault is already in it.
+    my %typed;
+    $typed{sudo} = $args{sudo} if $args{sudo};
+
+    if ( $args{totp} ) {
+        return ( undef, 'a code identifies somebody, and nobody is logged in' ) unless $user;
+
+        # Asked before the code is spent, and the reason is that a code is
+        # spent whether or not the thing it authorized worked.  Somebody whose
+        # key has gone would otherwise burn a code to be told there is nothing
+        # to unlock, then wait thirty seconds to be told it again.  has() opens
+        # the row to answer, so this is the same answer get() is about to give.
+        return (
+            undef,
+            "there is no provisioning passphrase this installation can open for $user." . "  Store it again under /secrets, or reprovision with the passphrase itself."
+        ) unless Trog::Vault::has( $user, $secret_name );
+
+        my ( $ok, $why ) = Trog::Auth::spend_totp( $user, $args{totp} );
+        return ( undef, $why ) unless $ok;
+
+        my $stored = Trog::Vault::get( $user, $secret_name );
+        return ( undef, "the stored provisioning passphrase for $user could not be read" ) unless $stored;
+        $credentials{keepass} = $stored;
+    }
+    else {
+        return ( undef, 'a passphrase is required, as the provisioner asks for one' ) unless $args{passphrase};
+        $credentials{keepass} = $args{passphrase};
+        $typed{keepass}       = $args{passphrase};
+    }
+
+    # A typed sudo password beats a stored one -- somebody typing it has a
+    # reason to -- and no sudo password at all is the ordinary answer, for a
+    # hypervisor whose login has passwordless sudo.
+    my $sudo = $typed{sudo} // ( $user ? Trog::Vault::get( $user, $sudo_name ) : undef );
+    $credentials{sudo} = $sudo if $sudo;
+
+    # File away what they typed, so the next run is a code.
+    #
+    # Said rather than refused when it does not work: they asked for a
+    # reprovision and gave us what it needs, and failing to keep a copy is not a
+    # reason to not do the thing they asked for.
+    if ( $args{remember} && $user && %typed ) {
+        my %vault_name = ( keepass => $secret_name, sudo => $sudo_name );
+        foreach my $name ( sort keys %typed ) {
+            my ( $ok, $why ) = Trog::Vault::set( $user, $vault_name{$name}, $typed{$name} );
+            WARN("Could not remember the provisioner's $name for $user: $why") unless $ok;
+        }
+    }
+
+    return ( \%credentials, '' );
+}
+
+=head2 reprovision(%args) = ($ok, $message)
+
+Run bin/provision for one guest, which generates its configuration from its
+recipe and then builds the machine.
+
+    domain      which guest.  Required, and validated as a hostname.
+    user        who asked.  For the log, and whose vault to look in.
+    passphrase  the KeePass passphrase the recipe's secrets need.
+    sudo        their sudo password on the hypervisor, if it wants one.
+    totp        a code, instead of those, when they have been stored.
+    remember    store what they just typed, so that next time is a code.
+
+Returns immediately.  Provisioning a machine takes minutes and an HTTP worker
+does not have minutes, so the work is handed to a detached process and the
+caller is told it started rather than told it finished.  What happened is in
+logs/reprovision/$domain.log, which is what log_tail reads back onto the page.
+
+=head3 WHY IT ASKS FOR ANYTHING AT ALL
+
+Two passwords, for two different reasons.
+
+Every recipe inherits secret: values from _base, so the provisioner opens a
+KeePass database on its way past and wants the passphrase to it.  The
+alternative to asking is keeping the master password for every secret an
+operator holds in a file the webserver can read, which is worse than asking.
+
+And almost everything it does on the hypervisor needs root.  Where the login
+there has passwordless sudo -- which is how ours are set up, and what we would
+recommend -- there is nothing to ask for.  Where it does not, sudo over ssh has
+no terminal to ask at, and a run that finds that out dies several minutes in on
+a prompt nobody will ever see.  So it is asked for here instead, and left empty
+by anybody who does not need it.
+
+Asking every time has its own cost, though: a passphrase somebody has to have to
+hand is a passphrase that gets written down, and then it is in a text file
+instead of a config file, which is not an improvement.  So it can be stored --
+see Trog::Vault, where it is sealed under a key the database does not contain --
+and then what this asks for is a TOTP code, which proves the person is here
+without their having to be holding anything.
+
+The code is spent either way, so it authorizes this one reprovision rather than
+every reprovision inside its window.
+
+However they arrive, they go down the child's stdin as a credentials block --
+see Trog::Credentials in trog-provisioner -- and are written nowhere: not the
+log, not the process table, not the configuration.
+
+=cut
+
+sub reprovision (%args) {
+    my $safe = safe_domain( $args{domain} );
+    return ( 0, 'bad guest name' ) unless $safe;
+
+    # The template does not draw the button for this guest.  This is what
+    # actually stops it: /guest/reprovision is a POST anybody holding the admin
+    # acl can craft by hand, and there would be nothing left to report to.
+    if ( Trog::DataSource::Virt::is_self($safe) ) {
+        WARN("Refused to reprovision '$safe': that is this server");
+        return ( 0, "'$safe' is this server -- refusing to reprovision it" );
+    }
+
+    my $config = config();
+    return ( 0, 'provisioner.trog_provisioner is not configured' ) unless $config->{trog_provisioner};
+
+    my $recipe = _recipe_path( $config, $safe );
+    return ( 0, "there is no recipe for '$safe' in $config->{recipes}" ) unless $recipe;
+
+    my ( $credentials, $why ) = credentials(%args);
+    return ( 0, $why ) unless $credentials;
+
+    # One 'name: value' per line is the format, so a value with a newline in it
+    # is two lines -- and the second one could name a credential nobody asked us
+    # to send.  Refused rather than escaped or trimmed: no password anybody meant
+    # to type has a newline in the middle of it, and quietly changing what
+    # somebody typed into their own password field is worse than saying no.
+    foreach my $name ( sort keys %$credentials ) {
+        return ( 0, "the $name has a line break in it, which is not something this can send" ) if $credentials->{$name} =~ m/[\r\n]/;
+    }
+
+    # One at a time.  Two provisions of one machine racing each other is not
+    # something anybody should be able to start by double clicking.
+    my $running = status($safe);
+    return ( 0, 'a reprovision of this guest is already running' ) if $running && $running->{state} eq 'running';
+
+    # --credentials, because nothing in there reads stdin unless it is told to.
+    my @command = ( "$config->{trog_provisioner}/bin/provision", '--credentials', $safe );
+    return ( 0, "$command[0] is not there to run" ) unless -x $command[0];    ## no critic (ProhibitFiletest_rwxRWX) -- refusing early beats finding out mid-provision
+
+    INFO( "Reprovision of '$safe' requested by " . ( $args{user} // 'somebody' ) );
+
+    my ( $ok, $failed ) = spawn( $safe, $credentials, $config->{trog_provisioner}, \@command, $args{user} );
+    return ( 0, $failed ) unless $ok;
+
+    return ( 1, "reprovision started; watch $log_dir/$safe.log" );
+}
+
+=head2 spawn($domain, $credentials, $dir, $command, $user)
+
+Fork the provisioner off where nothing is waiting for it.
+
+Double forked and setsid'd on purpose: a save signals the parent to reload the
+routing table, and a provision which died because a worker was recycled halfway
+through would leave a half-built machine.  This has to outlive the request, the
+worker, and a restart.
+
+It runs through open() with a list, so there is no shell between us and the
+program, and the guest name is an argument rather than a thing that could be
+read as one.
+
+The passwords go down its stdin as a credentials block, which is
+Trog::Credentials' format over there: one C<name: value> per line, and a blank
+line to say that is all of them.  A value with a newline in it would be two
+lines, and the second could name a credential we were not asked to send, so one
+is refused rather than escaped -- there is no password anybody meant to type
+that has a newline in the middle of it.
+
+=cut
+
+sub spawn ( $domain, $credentials, $dir, $command, $user ) {
+    my $log = "$log_dir/$domain.log";
+
+    local $@;
+    eval { File::Path::make_path($log_dir); 1 } or return ( 0, "could not make $log_dir: $@" );
+
+    my $pid = fork();
+    return ( 0, "could not fork: $!" ) unless defined $pid;
+    return ( 1, 'started' ) if $pid;
+
+    # First child: detach, fork again, and let the middle process go so that
+    # nothing is left for the worker to reap or be blocked by.
+    POSIX::setsid();
+    my $grandchild = fork();
+    POSIX::_exit(0) if !defined $grandchild || $grandchild;
+
+    # From here on we are nobody's child and nothing reads our exit status, so
+    # the log is the only way to say anything.
+    open( my $fh, '>>', $log ) or POSIX::_exit(1);    ## no critic (InputOutput::RequireBriefOpen) -- the child's STDOUT and STDERR from here on
+    $fh->autoflush(1);
+
+    my $started = time();
+    print {$fh} "\n=== reprovision of $domain by " . ( $user // 'somebody' ) . ' at ' . localtime($started) . " ===\n";
+
+    # $$ is this process, which is the one that will still be here in ten
+    # minutes -- the two before it have already gone.  status() checks it is
+    # alive, so it has to be the pid of whatever is actually doing the work.
+    write_status( $domain, state => 'running', pid => $$, started => $started, user => ( $user // '' ) );
+
+    print {$fh} "\n--- $command->[0] $command->[1] (in $dir)\n";
+
+    # In the checkout, so that anything the provisioner writes relative to where
+    # it was run lands there rather than in the middle of the website.
+    if ( !chdir($dir) ) {
+        print {$fh} "could not chdir to $dir: $!\n";
+        POSIX::_exit(1);
+    }
+
+    # The child's own stdout and stderr are the log, so whatever the program
+    # says lands there without a shell redirect to get wrong.
+    open( STDOUT, '>&', $fh ) or POSIX::_exit(1);
+    open( STDERR, '>&', $fh ) or POSIX::_exit(1);
+
+    # List form on purpose, and the reason the whole thing is shaped this way: a
+    # piped open with a list never involves a shell, so the guest name is an
+    # argument and cannot be read as a command.  The single argument form of
+    # this would be the bug.
+    my $ok = open( my $stdin, '|-', @$command );    ## no critic (ProhibitPipeOpen) -- list form, so no shell
+    if ( !$ok ) {
+        print {$fh} "could not run $command->[0]: $!\n";
+        POSIX::_exit(1);
+    }
+
+    # What the provisioner would otherwise have nobody to ask for.  Closed
+    # afterwards, so the read on the far side ends rather than waiting on us.
+    my $unsent = ( print {$stdin} join( '', map { "$_: $credentials->{$_}\n" } sort keys %$credentials ) . "\n" ) ? undef : "$!";
+    my $closed = close($stdin);
+
+    # A write to a provisioner that has gone fails, rather than kills us,
+    # because the server ignores SIGPIPE and we inherit that.  The print or the
+    # close() that flushes it can be the write that fails.  close() also waits
+    # for the provisioner, and is false when it exited non-zero, with $! 0.
+    $unsent //= "$!" if !$closed && $!;
+    if ( $unsent || $? ) {
+        my $status = $unsent ? 1 : $? >> 8;
+        print {$fh} $unsent ? "\n--- could not write to $command->[0]: $unsent\n" : "\n--- $command->[0] exited $status\n";
+        write_status(
+            $domain,
+            state    => 'failed',
+            started  => $started,
+            finished => time(),
+            exit     => $status,
+            failed   => $command->[0],
+            user     => ( $user // '' ),
+        );
+        POSIX::_exit($status);
+    }
+
+    print {$fh} "\n=== finished ===\n";
+    write_status( $domain, state => 'ok', started => $started, finished => time(), exit => 0, user => ( $user // '' ) );
+    POSIX::_exit(0);
+}
+
+1;

lib/Trog/DataSource/Virt.pm

@@ -0,0 +1,422 @@
+package Trog::DataSource::Virt;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use List::Util();
+use File::Path();
+use Sys::Hostname::FQDN();
+use Sys::Virt();
+
+use Trog::Config();
+use Trog::DataSource();
+
+use Trog::Log qw{WARN INFO};
+
+=head1 Trog::DataSource::Virt
+
+Builds posts out of libvirt guests rather than out of the datastore.
+
+A post type says it wants this by naming it in its sidecar:
+
+    "x-tcms-datasource": "Trog::DataSource::Virt"
+
+A series of that type then lists the guests of whichever hypervisor posts its
+relations pulled in, instead of listing posts somebody wrote.  Nothing here is
+ever written to the datastore -- the guests are the source of truth, and the
+posts are rebuilt from them on every view.
+
+=head2 EDITABLE
+
+False.  A guest is built from libvirt every time the page is drawn and has
+nothing behind it to save, so a post type backed by this wants no editor: a
+form posting to /post/save would write a real post into the datastore which
+would then sit alongside, and collide with, the synthesized ones.
+
+=cut
+
+sub EDITABLE { return 0 }
+
+=head2 CACHEABLE
+
+False.  A guest's state is the whole point of the page: whether it is running,
+how much memory it has, what its console looks like right now.  A static render
+of that is a photograph of a machine, and the reader wants the machine.
+
+There is also nothing that could invalidate it.  A guest starting or stopping is
+not a post being saved, and libvirt is not going to tell us about it -- so a
+cached listing would not merely be stale, it would have no way of ever becoming
+right again.
+
+=cut
+
+sub CACHEABLE { return 0 }
+
+=head2 A NOTE ON SAFETY
+
+libvirt forbids virDomainScreenshot on a read-only connection, so the read path
+cannot protect itself by connecting read-only -- it holds a connection which is
+perfectly capable of destroying a guest.
+
+The discipline is therefore in the code: posts() and screenshot() call nothing
+but accessors, and every operation that changes a guest lives in act(), which
+is reached only from an explicit admin-gated POST.  Keep it that way.
+
+=cut
+
+# How long a cached screenshot is considered fresh.  These are console
+# captures, so they change slowly and are cheap to refetch.
+our $screenshot_ttl = 30;
+
+# Under www/assets like every other asset, in its own subtree because these are
+# not uploads somebody made -- they are cached datasource output, and anything
+# in here can be deleted at any time and will simply be refetched.
+#
+# Under private/ specifically because a console capture can show a login
+# prompt, a hostname, whatever the last command printed.  That is the same
+# reasoning _handle_upload uses to put a private post's assets there, and the
+# screenshot route serves these to admins itself rather than relying on
+# anything about how www/assets is exposed.
+our $screenshot_dir = 'www/assets/private/datasource/virt';
+
+# Reconnecting per guest would be absurd -- one ssh handshake per hypervisor
+# per process is enough.  Not a state var: a connection that has gone away
+# should be retried rather than remembered.
+my sub _connect ( $uri, $cache = {} ) {
+    return $cache->{$uri} if $cache->{$uri};
+
+    local $@;
+    my $conn = eval { Sys::Virt->new( uri => $uri ) };
+    if ( !$conn ) {
+        my $why = "$@";
+        $why =~ s/\n.*//s;
+        WARN("Could not connect to hypervisor '$uri': $why");
+        return ( undef, $why );
+    }
+
+    $cache->{$uri} = $conn;
+    return $conn;
+}
+
+# libvirt's numeric domain states, in the order the constants define them.
+my @states = (
+    'no state', qw{running blocked paused},
+    'shutting down', 'shut off', 'crashed', 'suspended',
+);
+
+# What this machine calls itself.  Not a state var so that a test can pretend
+# to be a different host without having to lie to Sys::Hostname.
+our $hostname;
+
+my sub hostname {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate is_self()
+    return $hostname if defined $hostname;
+
+    local $@;
+
+    # Sys::Hostname croaks rather than returning undef when it cannot tell, and
+    # the configured hostname is the next best thing we know about ourselves.
+    $hostname =
+         eval { Sys::Hostname::FQDN::fqdn() }
+      || eval { Trog::Config->get()->param('general.hostname') }
+      || '';
+
+    return $hostname;
+}
+
+=head2 is_self($name)
+
+Whether a guest by this name is the machine we are running on.
+
+Such a guest is acting as dom0: it is serving the page the guest list appears
+on, so powering it off or destroying it takes the site down along with whatever
+asked for that.
+
+Returns true if the guest name is the same as the fqdn of this machine.
+Returns false otherwise.
+
+=cut
+
+sub is_self ($name) {
+    my $me = lc( hostname() );
+    $name = lc( $name // '' );
+
+    return 1 if $name eq $me;
+    return 0;
+}
+
+my sub unreachable_post ( $hypervisor, $series, $form, $why ) {
+    return {
+        id               => "unreachable-$hypervisor->{id}",
+        title            => $hypervisor->{title} // 'hypervisor',
+        form             => $form,
+        data             => '',
+        state            => "unreachable: $why",
+        is_active        => 0,
+        unreachable      => 1,
+        hypervisor       => $hypervisor->{id},
+        hypervisor_title => $hypervisor->{title},
+        preview          => '',
+        local_href       => '',
+        href             => '',
+        tags             => $series->{tags}       // [],
+        visibility       => $series->{visibility} // 'private',
+        created          => time(),
+        version          => 0,
+        user             => $series->{user},
+        method           => 'GET',
+    };
+}
+
+=head2 posts($series, $query) = @posts
+
+One post per guest, across every hypervisor the series' relations pulled in.
+
+A hypervisor we cannot reach becomes a single post saying so, rather than
+vanishing -- a page that silently omits half your infrastructure is worse than
+one that tells you the connection is broken.
+
+=cut
+
+sub posts ( $series, $ ) {
+    my $hypervisors = $series->{ $series->{'x-tcms-datasource-relation'} // 'hypervisors' };
+    return () unless ref $hypervisors eq 'ARRAY';
+
+    my $form = $series->{child_form} // '';
+    my %cache;
+    my @out;
+
+    foreach my $hypervisor (@$hypervisors) {
+        my $uri = $hypervisor->{conn_uri};
+        next unless $uri;
+
+        my ( $conn, $why ) = _connect( $uri, \%cache );
+        if ( !$conn ) {
+            push( @out, unreachable_post( $hypervisor, $series, $form, $why ) );
+            next;
+        }
+
+        local $@;
+        my @domains = eval { $conn->list_all_domains() };
+        if ($@) {
+            my $err = "$@";
+            $err =~ s/\n.*//s;
+            push( @out, unreachable_post( $hypervisor, $series, $form, $err ) );
+            next;
+        }
+
+        push( @out, map { post_for( $_, $hypervisor, $series, $form ) } @domains );
+    }
+
+    return @out;
+}
+
+=head2 filter($query, @posts) = @posts
+
+Apply the reader's search to the guest list.
+
+A guest post's body is empty -- everything about it is in named fields -- so the
+default, which searches a post's title and body, would only ever match the guest
+name.  Search what the page actually shows instead: the guest name, its state,
+and the hypervisor it is on.  Searching 'shut' for the stopped guests, or a
+hypervisor's title for everything on it, is the thing somebody typing in that
+box on this page is trying to do.
+
+Everything else about the query means what it does elsewhere, so it is left to
+Trog::DataSource::filter.
+
+=cut
+
+sub filter ( $query, @posts ) {
+    $query //= {};
+
+    if ( ( $query->{like} // q{} ) ne q{} ) {
+        my $like = $query->{like};
+        @posts = grep {
+            Trog::DataSource::searchable_match(
+                $like,
+                $_->{title}, $_->{domain}, $_->{state}, $_->{hypervisor_title}, $_->{hypervisor},
+            )
+        } @posts;
+    }
+
+    # Without like, since that one is answered above.
+    return Trog::DataSource::filter( { %$query, like => undef }, @posts );
+}
+
+=head2 lang() = STRING
+
+What the search box searches on a page of guests.
+
+=head2 help() = STRING
+
+Where to read about it.
+
+=cut
+
+sub lang { return 'Case insensitive substring of a guest name, state or hypervisor' }
+sub help { return 'https://en.wikipedia.org/wiki/Substring' }
+
+=head2 post_for($domain, $hypervisor, $series, $form) = HASHREF
+
+The post that stands for the guest $domain, a Sys::Virt::Domain, on
+$hypervisor, in the listing of $series, rendered with $form.
+
+=cut
+
+sub post_for ( $domain, $hypervisor, $series, $form ) {
+    my $name = $domain->get_name();
+    my $info = $domain->get_info();
+
+    return {
+        # The guest's own UUID: stable across renders, and what the control
+        # routes look it back up by.
+        id    => $domain->get_uuid_string(),
+        title => $name,
+        form  => $form,
+        data  => '',
+
+        domain           => $name,
+        state            => $states[ $info->{state} ] // 'unknown',
+        is_active        => $domain->is_active() ? 1 : 0,
+        is_self          => is_self($name),
+        memory           => $info->{memory},
+        vcpus            => $info->{nrVirtCpu},
+        hypervisor       => $hypervisor->{id},
+        hypervisor_title => $hypervisor->{title},
+
+        # Fetched by the browser rather than inline, so ten guests don't mean
+        # ten screenshots taken serially before the page can render.
+        preview => "/guest/screenshot/$hypervisor->{id}/$name",
+
+        # Enough of a post to survive being rendered like one.
+        local_href => "/guest/$hypervisor->{id}/$name",
+        href       => '',
+        tags       => $series->{tags}       // [],
+        visibility => $series->{visibility} // 'private',
+        created    => time(),
+        version    => 0,
+        user       => $series->{user},
+        method     => 'GET',
+    };
+}
+
+=head2 screenshot($hypervisor, $guest_name) = ($path, $error)
+
+Path to a reasonably fresh PNG of the guest's console.
+
+Cached on disk, because a page of guests means one of these per guest and they
+are only interesting to about the nearest half minute.  libvirt hands back the
+mimetype; qemu gives us PNG already, so there is nothing to convert.
+
+Keyed by hypervisor as well as by guest -- guest names are only unique within
+one hypervisor, and two of them called 'staging' would otherwise show each
+other's console.
+
+=cut
+
+sub screenshot ( $hypervisor, $guest_name ) {
+    my ($safe) = ( $guest_name // '' ) =~ m/^([\w.-]+)$/;
+    return ( undef, 'bad guest name' ) unless $safe;
+
+    my ($host) = ( $hypervisor->{id} // '' ) =~ m/^([\w.-]+)$/;
+    return ( undef, 'bad hypervisor id' ) unless $host;
+
+    my $conn_uri = $hypervisor->{conn_uri};
+    return ( undef, 'hypervisor has no connection uri' ) unless $conn_uri;
+
+    my $dir  = "$screenshot_dir/$host";
+    my $path = "$dir/$safe.png";
+
+    # One stat rather than -f and then a second stat for the mtime.  A missing
+    # file gives the empty list, so $mtime is undef and we fall through to a
+    # fresh capture.
+    my $mtime = ( stat($path) )[9];
+    return ( $path, undef ) if $mtime && ( time() - $mtime ) < $screenshot_ttl;
+
+    my ( $conn, $why ) = _connect($conn_uri);
+    return ( undef, $why ) unless $conn;
+
+    local $@;
+    my $data = eval {
+        my ($domain) = grep { $_->get_name() eq $safe } $conn->list_all_domains();
+        die "no such guest\n" unless $domain;
+
+        my $stream = $conn->new_stream();
+        $domain->screenshot( $stream, 0, 0 );
+
+        my $buffer = '';
+        $stream->recv_all( sub { my ( undef, $chunk ) = @_; $buffer .= $chunk; return length($chunk) } );
+        $stream->finish();
+        $buffer;
+    };
+    if ( !$data ) {
+        my $err = "$@";
+        $err =~ s/\n.*//s;
+        return ( undef, $err );
+    }
+
+    File::Path::make_path($dir);
+    open( my $fh, '>', $path ) or return ( undef, "could not cache the screenshot: $!" );
+    binmode $fh;
+    print {$fh} $data;
+    close($fh) or return ( undef, "could not cache the screenshot: $!" );
+
+    return ( $path, undef );
+}
+
+=head2 act($action, $conn_uri, $domain_name, $user) = ($ok, $message)
+
+The operations which change a guest.
+
+Deliberately the only sub here that does, and deliberately not reachable from
+the render path -- see the safety note at the top.  Everything it does is
+logged with the user who asked for it.
+
+=cut
+
+sub act ( $action, $conn_uri, $domain_name, $user ) {
+    my ($safe) = $domain_name =~ m/^([\w.-]+)$/;
+    return ( 0, 'bad guest name' ) unless $safe;
+
+    # The template draws neither of these buttons for this guest; this is what
+    # actually stops it happening.  /guest/act is a POST anybody holding the
+    # admin acl can craft by hand, and if it went through there would be
+    # nothing left running to report the mistake.
+    if ( is_self($safe) && List::Util::any { $_ eq ( $action // '' ) } qw{poweroff destroy} ) {
+        WARN("Refused guest action '$action' on '$safe': that is this server");
+        return ( 0, "'$safe' is this server -- refusing to $action it" );
+    }
+
+    my ( $conn, $why ) = _connect($conn_uri);
+    return ( 0, "could not reach the hypervisor: $why" ) unless $conn;
+
+    local $@;
+    my ($domain) = eval {
+        grep { $_->get_name() eq $safe } $conn->list_all_domains();
+    };
+    return ( 0, "no guest called '$safe' on that hypervisor" ) unless $domain;
+
+    INFO("Guest action '$action' on '$safe' requested by $user");
+
+    my %actions = (
+        poweron  => sub { $_[0]->create() },
+        poweroff => sub { $_[0]->shutdown() },
+        snapshot => sub { $_[0]->create_snapshot() },
+        destroy  => sub { $_[0]->destroy() },
+    );
+
+    my $doit = $actions{ $action // '' };
+    return ( 0, "'$action' is not something we do to a guest" ) unless $doit;
+
+    eval { $doit->($domain); 1 } or do {
+        my $err = "$@";
+        $err =~ s/\n.*//s;
+        WARN("Guest action '$action' on '$safe' failed: $err");
+        return ( 0, $err );
+    };
+
+    return ( 1, "$action: ok" );
+}
+
+1;

lib/Trog/Email.pm

@@ -1,10 +1,8 @@
 package Trog::Email;
 
-use strict;
-use warnings;
-
-no warnings qw{experimental};
-use feature qw{signatures};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use Email::MIME;
 use Email::Sender::Simple;
@@ -13,6 +11,31 @@ use Trog::Auth;
 use Trog::Log qw{:all};
 use Trog::Renderer;
 
+=head1 Trog::Email
+
+Sending mail out of tCMS.
+
+=head1 Termination Conditions
+
+Dies when asked to mail a user who has no contact email set on their profile.
+Failure to actually send is logged as FATAL rather than thrown, as by then the
+message has already been built and there's nothing the caller can do about it.
+
+=head1 FUNCTIONS
+
+=head2 contact(STRING user, STRING from, STRING subject, HASHREF data) = BOOL
+
+Send a templated message to a user's contact email.
+
+$data must have a 'template' key naming the template to render; everything else
+in it is passed through to that template as its data.  The template is rendered
+twice, once as text and once as HTML, and both are attached to a multipart
+message so that the recipient's client can pick whichever it prefers.
+
+Returns 1.
+
+=cut
+
 sub contact ( $user, $from, $subject, $data ) {
     my $email = Trog::Auth::email4user($user);
     die "No contact email set for user $user!" unless $email;

lib/Trog/Enrich/Invoice.pm

@@ -0,0 +1,39 @@
+package Trog::Enrich::Invoice;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use List::Util();
+
+=head1 Trog::Enrich::Invoice
+
+The part of an invoice which has to be computed rather than merely fetched.
+
+Its payee and payor are ordinary relations, declared in invoice.json and
+resolved by Trog::Routes::HTML::enrich_post like any other type's.  The
+running total is not -- it is read out of the line items themselves.
+
+=head2 enrich($post, $query) = %extra
+
+Sum the line items into a total.  Each page of a multi-page invoice post is one
+line item, and a line beginning 'Price:' is what carries its cost; the
+denomination is taken from the first one that has any.
+
+=cut
+
+sub enrich ( $post, $ ) {
+    return () unless ref $post->{data} eq 'ARRAY';
+
+    my $denomination;
+    my @prices = map {
+        my $price = 0;
+        ( $denomination, $price ) = m/^Price:\s*(\D)(\d+)/mix;
+        $price;
+    } @{ $post->{data} };
+
+    $denomination //= '$';
+    return ( total => $denomination . ( List::Util::sum(@prices) // 0 ) );
+}
+
+1;

lib/Trog/FileHandler.pm

@@ -1,149 +0,0 @@
-package Trog::FileHandler;
-
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures};
-
-use POSIX qw{strftime};
-use IO::Compress::Gzip;
-use Time::HiRes qw{tv_interval};
-
-use Trog::Log qw{:all};
-use Trog::Vars;
-use Trog::Utils;
-
-=head2 serve
-
-Serve a file, with options to stream and cache the output.
-
-=cut
-
-sub serve ( $fullpath, $path, $start, $streaming, $ranges, $last_fetch = 0, $deflate = 0 ) {
-    my $ft = Trog::Utils::mime_type($path);
-    $ft ||= $Trog::Vars::content_types{text};
-
-    my $ct      = 'Content-type';
-    my @headers = ( $ct => $ft );
-    DEBUG("$ct : $ft");
-
-    #TODO use static Cache-Control for everything but JS/CSS?
-    push( @headers, 'Cache-control' => $Trog::Vars::cache_control{revalidate} );
-
-    push( @headers, 'Accept-Ranges' => 'bytes' );
-
-    my $mt         = ( stat($path) )[9];
-    my $sz         = ( stat(_) )[7];
-    my @gm         = gmtime($mt);
-    my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm );
-    my $code       = $mt > $last_fetch ? 200 : 304;
-
-    push( @headers, "Last-Modified" => $now_string );
-    push( @headers, 'Vary'          => 'Accept-Encoding' );
-
-    if ( open( my $fh, '<', $path ) ) {
-        return _range( $fullpath, $fh, $ranges, $sz, @headers ) if @$ranges && $streaming;
-
-        # Transfer-encoding: chunked
-        return sub {
-            my $responder = shift;
-            push( @headers, 'Content-Length' => $sz );
-            my $writer = $responder->( [ $code, \@headers ] );
-            while ( $fh->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
-                $writer->write($buf);
-            }
-            close $fh;
-            $writer->close;
-          }
-          if $streaming && $sz > $Trog::Vars::CHUNK_SIZE;
-
-        #Return data in the event the caller does not support deflate
-        if ( !$deflate ) {
-            push( @headers, "Content-Length" => $sz );
-
-            # Append server-timing headers
-            my $tot = tv_interval($start) * 1000;
-            push( @headers, 'Server-Timing' => "file;dur=$tot" );
-
-            return [ $code, \@headers, $fh ];
-        }
-
-        #Compress everything less than 1MB
-        push( @headers, "Content-Encoding" => "gzip" );
-        my $dfh;
-        IO::Compress::Gzip::gzip( $fh => \$dfh );
-        print $IO::Compress::Gzip::GzipError if $IO::Compress::Gzip::GzipError;
-        push( @headers, "Content-Length" => length($dfh) );
-
-        INFO("GET 200 $fullpath");
-
-        # Append server-timing headers
-        my $tot = tv_interval($start) * 1000;
-        push( @headers, 'Server-Timing' => "file;dur=$tot" );
-
-        return [ $code, \@headers, [$dfh] ];
-    }
-
-    INFO("GET 403 $fullpath");
-    return [ 403, [ $ct => $Trog::Vars::content_types{text} ], ["STAY OUT YOU RED MENACE"] ];
-}
-
-sub _range ( $fullpath, $fh, $ranges, $sz, %headers ) {
-
-    # Set mode
-    my $primary_ct   = "Content-Type: $headers{'Content-type'}";
-    my $is_multipart = scalar(@$ranges) > 1;
-    if ($is_multipart) {
-        $headers{'Content-type'} = "multipart/byteranges; boundary=$Trog::Vars::CHUNK_SEP";
-    }
-    my $code = 206;
-
-    my $fc = '';
-
-    # Calculate the content-length up-front.  We have to fix unspecified lengths first, and reject bad requests.
-    foreach my $range (@$ranges) {
-        $range->[1] //= $sz - 1;
-        INFO("GET 416 $fullpath");
-        return [ 416, [%headers], ["Requested range not satisfiable"] ] if $range->[0] > $sz || $range->[0] < 0 || $range->[1] < 0 || $range->[0] > $range->[1];
-    }
-    $headers{'Content-Length'} = List::Util::sum( map { my $arr = $_; $arr->[1] + 1, -$arr->[0] } @$ranges );
-
-    #XXX Add the entity header lengths to the value - should hash-ify this to DRY
-    if ($is_multipart) {
-        foreach my $range (@$ranges) {
-            $headers{'Content-Length'} += length("$fc--$Trog::Vars::CHUNK_SEP\n$primary_ct\nContent-Range: bytes $range->[0]-$range->[1]/$sz\n\n");
-            $fc = "\n";
-        }
-        $headers{'Content-Length'} += length("\n--$Trog::Vars::CHUNK_SEP\--\n");
-        $fc = '';
-    }
-
-    return sub {
-        my $responder = shift;
-        my $writer;
-
-        foreach my $range (@$ranges) {
-            $headers{'Content-Range'} = "bytes $range->[0]-$range->[1]/$sz" unless $is_multipart;
-            $writer //= $responder->( [ $code, [%headers] ] );
-            $writer->write("$fc--$Trog::Vars::CHUNK_SEP\n$primary_ct\nContent-Range: bytes $range->[0]-$range->[1]/$sz\n\n") if $is_multipart;
-            $fc = "\n";
-
-            my $len = List::Util::min( $sz, $range->[1] + 1 ) - $range->[0];
-
-            $fh->seek( $range->[0], 0 );
-            while ($len) {
-                $fh->read( my $buf, List::Util::min( $len, $Trog::Vars::CHUNK_SIZE ) );
-                $writer->write($buf);
-
-                # Adjust for amount written
-                $len = List::Util::max( $len - $Trog::Vars::CHUNK_SIZE, 0 );
-            }
-        }
-        $fh->close();
-        $writer->write("\n--$Trog::Vars::CHUNK_SEP\--\n") if $is_multipart;
-        $writer->close;
-    };
-}
-
-1;

lib/Trog/Log.pm

@@ -1,13 +1,15 @@
 package Trog::Log;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use POSIX qw{strftime};
+use Module::Runtime();
 use Log::Dispatch;
-use Log::Dispatch::DBI;
 use Log::Dispatch::Screen;
 use Log::Dispatch::FileRotate;
+use File::Basename qw{dirname};
 
 use Trog::SQLite;
 use Trog::Log::DBI;
@@ -16,16 +18,74 @@ use Exporter 'import';
 our @EXPORT_OK   = qw{log_init is_debug INFO DEBUG WARN FATAL};
 our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
 
-my $LOGNAME = 'logs/tcms.log';
-$LOGNAME = $ENV{CUSTOM_LOG} if $ENV{CUSTOM_LOG};
-
-my $LEVEL = $ENV{WWW_VERBOSE} ? 'debug' : 'info';
-
+my ( $LEVEL, $LOGDIR );
 our ( $log, $user );
+
 $Trog::Log::user = 'nobody';
 $Trog::Log::ip   = '0.0.0.0';
 
+=head1 Trog::Log
+
+Logging for tCMS.
+
+Everything goes through one Log::Dispatch object with three outputs: a rotating
+file for the operator, the screen for anything at error level or above (which
+is what ends up in the webserver's own log), and Trog::Log::DBI, which is what
+Trog::Log::Metrics later reads its time series out of.
+
+Import the level subroutines you need, or C<:all>:
+
+    use Trog::Log qw{:all};
+    INFO("something happened");
+
+=head1 Termination Conditions
+
+log_init() dies if it isn't told where to log and at what level.  FATAL() dies
+by design, that being the point of it.  Note that the level subroutines will
+themselves die on an undefined $log, so log_init() has to have run first --
+which the server does per-worker, and CLI tools have to do for themselves.
+
+=head1 VARIABLES
+
+=over 4
+
+=item $Trog::Log::user
+
+Who the current request belongs to.  Interpolated into every log line, so that
+the request log can be grepped by user.  Defaults to 'nobody'.
+
+=item $Trog::Log::ip
+
+Where the current request came from, same deal.  Defaults to '0.0.0.0'.
+
+=back
+
+=head1 FUNCTIONS
+
+=head2 log_init(STRING logname, STRING level, [ARRAYREF loggers]) = BOOL
+
+Build the logger.  Must be called before anything tries to log.
+
+$logname is the path to the log file; its directory is also where the metrics
+database gets put.  $level is a Log::Dispatch level, generally 'info' or
+'debug'.
+
+$loggers names more Log::Dispatch outputs to add, by class, and each gets
+C<min_level> and C<log_dir> as tPSGI gives them.  The server passes the
+C<loggers> of tpsgi.ini, so that one setting sends the lines of tPSGI and of
+tCMS to the same places.  See Trog::Log::Syslog.
+
+Returns 1.
+
+=cut
+
 sub log_init {
+    my ( $LOGNAME, $level, $loggers ) = @_;
+
+    die "Cannot initialize logs without log name and log level" unless $LOGNAME && $level;
+
+    $LEVEL  = $level;
+    $LOGDIR = dirname($LOGNAME);
 
     # By default only log requests & warnings.
     # Otherwise emit debug messages.
@@ -34,7 +94,7 @@ sub log_init {
         filename  => $LOGNAME,
         min_level => $LEVEL,
         'mode'    => 'append',
-        size      => 10 * 1024 * 1024,
+        size      => 10_485_760,    # 10 MiB
         max       => 6,
     );
 
@@ -48,7 +108,7 @@ sub log_init {
     my $dblog = Trog::Log::DBI->new(
         name      => 'dbi',
         min_level => $LEVEL,
-        dbh       => _dbh(),
+        dbh       => dbh(),
     );
 
     $log = Log::Dispatch->new();
@@ -56,6 +116,10 @@ sub log_init {
     $log->add($screen);
     $log->add($dblog);
 
+    foreach my $logger ( @{ $loggers // [] } ) {
+        $log->add( Module::Runtime::use_module($logger)->new( min_level => $LEVEL, log_dir => $LOGDIR ) );
+    }
+
     uuid("INIT");
     return 1;
 }
@@ -63,54 +127,100 @@ sub log_init {
 #memoize
 my $rq;
 
-sub _dbh {
-    return Trog::SQLite::dbh( 'schema/log.schema', "logs/log.db" );
+=head2 dbh() = DBI::db
+
+The handle to the log database, under the log directory, with its schema
+applied.  Trog::SQLite caches it, so every call gets the same one.
+
+=cut
+
+sub dbh {
+    return Trog::SQLite::dbh( 'schema/log.schema', "$LOGDIR/log.db" );
 }
 
+=head2 is_debug() = BOOL
+
+Whether we were initialized at debug level.  Useful for skipping the
+construction of an expensive message which would only be thrown away.
+
+=cut
+
 sub is_debug {
+    $LEVEL //= 'info';
     return $LEVEL eq 'debug';
 }
 
+=head2 uuid([STRING requestid]) = STRING
+
+Get, or set, the request ID stamped onto every log line.
+
+The server sets this once per request so that the lines belonging to it can be
+picked back out of an interleaved log, and so that Trog::Log::DBI can group a
+request's messages under the request itself.
+
+=cut
+
 sub uuid {
     my $requestid = shift;
     $rq = $requestid if $requestid;
-    $requestid //= return $rq;
+    return $requestid // $rq;
 }
 
-sub _log {
+my sub _log {
     my ( $msg, $level ) = @_;
 
     $msg //= "No message passed.  This is almost certainly a bug. ";
 
     #XXX Log lines must start as an ISO8601 date, anything else breaks fail2ban's beautiful mind
     my $tstamp = strftime "%Y-%m-%dT%H:%M:%SZ", gmtime;
-    my $uuid   = uuid();
+
+    # Undef until the server stamps one, or log_init() sets INIT.  Anything
+    # logged before that still deserves a line rather than an uninitialized
+    # value warning glued into the middle of it.
+    my $uuid = uuid() // 'NONE';
 
     return "$tstamp [$level]: RequestId $uuid From $Trog::Log::ip |$Trog::Log::user| $msg\n";
 }
 
-sub DEBUG {
-    _check_init();
-    $log->debug( _log( shift, 'DEBUG' ) );
-}
+=head2 DEBUG(STRING msg), INFO(STRING msg), WARN(STRING msg), FATAL(STRING msg)
 
-sub INFO {
-    _check_init();
-    $log->info( _log( shift, 'INFO' ) );
-}
+Log a message at the named level.
+
+Lines are formatted as an ISO8601 timestamp, the level, the request ID, the
+originating IP and the user, followed by the message.  Don't change the leading
+timestamp -- fail2ban parses these.
+
+FATAL logs and then dies, so it never returns.
+
+All four work before log_init() has run, falling back to stderr.  Logging is
+the thing you reach for when something has already gone wrong, so a logger that
+dies because it wasn't set up first turns a diagnostic into an outage -- and
+plenty of callers legitimately run uninitialized, such as the scripts in bin/
+and the test suite.
+
+=cut
 
-sub WARN {
-    _check_init();
-    $log->warning( _log( shift, 'WARN' ) );
+# One path for every level so the uninitialized fallback only exists once.
+my sub emit ( $level, $method, $msg ) {
+    my $line = _log( $msg, $level );
+    return $log->$method($line) if $log;
+
+    warn $line;
+    return 1;
 }
 
+sub DEBUG { return emit( 'DEBUG', 'debug', shift ) }
+
+sub INFO { return emit( 'INFO', 'info', shift ) }
+
+sub WARN { return emit( 'WARN', 'warning', shift ) }
+
 sub FATAL {
-    _check_init();
-    $log->log_and_die( level => 'error', message => _log( shift, 'FATAL' ) );
-}
+    my $line = _log( shift, 'FATAL' );
+    $log->log_and_die( level => 'error', message => $line ) if $log;
 
-sub _check_init {
-    die "You must run log_init() before using other Trog::Log methods" unless $log;
+    # Still fatal with no logger, or the caller's error handling vanishes.
+    die $line;
 }
 
 1;

lib/Trog/Log/DBI.pm

@@ -1,18 +1,55 @@
 package Trog::Log::DBI;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use parent qw{Log::Dispatch::DBI};
 
-use Ref::Util     qw{is_arrayref};
-use Capture::Tiny qw{capture_merged};
+use Ref::Util qw{is_arrayref};
 
 use POSIX           qw{mktime};
 use POSIX::strptime qw{strptime};
 
 our ( $referer, $ua, $urchin );
 
+=head1 Trog::Log::DBI
+
+A Log::Dispatch::DBI subclass which files tCMS's request log into SQLite, so
+that Trog::Log::Metrics has something to compute time series out of.
+
+Rather than storing log lines verbatim, log_message() picks apart the format
+Trog::Log emits and stores the pieces in columns.  Lines which don't match the
+request format are treated as free text belonging to whichever request was in
+flight, and are buffered until that request's own line shows up to hang them
+off of.
+
+Anything too mangled to identify a request is dropped -- a metrics database is
+not the place to go looking for them, the log file has them either way.
+
+=head1 VARIABLES
+
+=over 4
+
+=item $referer, $ua, $urchin
+
+Per-request context which isn't in the log line itself.  The routes set these
+before responding; they only exist for metrics, which is why they aren't in the
+text logs.  $urchin is a hashref of utm_* parameters, and is only recorded when
+it has a utm_source.
+
+=back
+
+=head1 METHODS
+
+=head2 create_statement() = DBI::st
+
+Called by Log::Dispatch::DBI at construction.  Prepares, and returns, the
+statement for the requests view, and prepares the two extra statements
+log_message() needs for messages and urchin data.
+
+=cut
+
 sub create_statement {
     my $self = shift;
 
@@ -30,26 +67,42 @@ sub create_statement {
 
 my %buffer;
 
+# A line as Trog::Log formats it: the time, the level, who asked, and what
+# happened.
+my $STAMP   = qr/[\w:-]+/;
+my $REQUEST = qr/[\w-]+/;
+my $ADDRESS = qr/[\w.:]+/;
+my $WHO     = qr/RequestId[ ]($REQUEST)[ ]From[ ]($ADDRESS)[ ]\|(\w+)\|/;
+my $LINE    = qr/\A($STAMP)[ ]\[(\w+)\]:[ ]$WHO[ ](\N+)/;
+
+# What happened, when that is a request that was served: the method, the
+# code, the bytes, and the route.
+my $SERVED = qr/\A(\w+)[ ](\d+)[ ](\d+)[ ](\N+)/;
+
+=head2 log_message(HASH params) = MIXED
+
+Record one log line.
+
+Returns the request insert's result for a request line, 1 for a message that
+got buffered, and undef for a line we couldn't make sense of or could not write.
+A write that fails is a warning on stderr, and never dies.
+
+=cut
+
 sub log_message {
     my ( $self, %params ) = @_;
 
-    # Rip apart the message.  If it's got any extended info, lets grab that too.
-    my $msg = $params{message};
-    my $message;
-    my ( $date, $uuid, $ip, $user, $method, $code, $route ) = $msg =~ m!^([\w|\-|:]+) \[INFO\]: RequestId ([\w|\-]+) From ([\w|\.|:]+) \|(\w+)\| (\w+) (\d+) (.+)!;
+    my ( $date, $level, $uuid, $ip, $user, $message ) = $params{message} =~ $LINE;
+    return unless $uuid;
 
-    # Otherwise, let's mark it down in the "messages" table.  This will be deferred until the final write.
-    if ( !$date ) {
-        ( $date, $uuid, $ip, $user, $message ) = $msg =~ m!^([\w|\-|:]+) \[\w+\]: RequestId ([\w|\-]+) From ([\w|\.|:]+) \|(\w+)\| (.+)!;
+    my ( $method, $code, undef, $route ) = $level eq 'INFO' ? $message =~ $SERVED : ();
 
-        $buffer{$uuid} //= [];
+    # Anything else goes in the "messages" table, once its request is written.
+    if ( !defined $method ) {
         push( @{ $buffer{$uuid} }, $message );
         return 1;
     }
 
-    # If this is a mangled log, forget it.
-    return unless $date && $uuid;
-
     # 2024-01-20T22:37:41Z
     # Transform the date into an epoch so we can do math on it
     my $fmt     = "%Y-%m-%dT%H:%M:%SZ";
@@ -65,21 +118,29 @@ sub log_message {
     $ua      //= 'none';
     $urchin  //= {};
 
-    my $res = $self->{sth}->execute( $uuid, $epoch, $ip, $user, $method, $route, $referer, $ua, $code );
-
-    # Dump in the accumulated messages
-    if ( is_arrayref( $buffer{$uuid} ) && @{ $buffer{$uuid} } ) {
-        $self->{sth2}->bind_param_array( 1, $uuid );
-        $self->{sth2}->bind_param_array( 2, $buffer{$uuid} );
-        $self->{sth2}->execute_array( {} );
-        delete $buffer{$uuid};
-
-    }
-
-    # Record urchin data if there is any.
-    if ( %$urchin && $urchin->{utm_source} ) {
-        $self->{sth3}->execute( $uuid, $urchin->{utm_source}, $urchin->{utm_medium}, $urchin->{utm_campaign}, $urchin->{utm_term}, $urchin->{utm_content} );
-    }
+    # The handle raises, and this runs inside every log call, so a failed write warns rather than dies.
+    my $messages = delete $buffer{$uuid};
+    my $res;
+    eval {
+        # TODO track bytes in the DB
+        $res = $self->{sth}->execute( $uuid, $epoch, $ip, $user, $method, $route, $referer, $ua, $code );
+
+        # Dump in the accumulated messages
+        if ( is_arrayref($messages) && @$messages ) {
+            $self->{sth2}->bind_param_array( 1, $uuid );
+            $self->{sth2}->bind_param_array( 2, $messages );
+            $self->{sth2}->execute_array( {} );
+        }
+
+        # Record urchin data if there is any.
+        if ( %$urchin && $urchin->{utm_source} ) {
+            $self->{sth3}->execute( $uuid, $urchin->{utm_source}, $urchin->{utm_medium}, $urchin->{utm_campaign}, $urchin->{utm_term}, $urchin->{utm_content} );
+        }
+        1;
+    } or do {
+        warn "Could not record request $uuid in the metrics database: $@";
+        return;
+    };
 
     return $res;
 }

lib/Trog/Log/Metrics.pm

@@ -1,12 +1,10 @@
 package Trog::Log::Metrics;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-no warnings 'experimental';
-use feature qw{signatures state};
-
-use Trog::SQLite;
+use Trog::Log;
 
 =head1 Trog::Log::Metrics
 
@@ -15,10 +13,6 @@ and for reasoning about the various things that it's Urchin-compatible data can
 
 =cut
 
-sub _dbh {
-    return Trog::SQLite::dbh( 'schema/log.schema', "logs/log.db" );
-}
-
 =head2 requests_per(ENUM period{second,minute,hour,day,month,year}, INTEGER num_periods, [TIME_T before], INTEGER[] @codes)
 
 Returns a data structure of the following form
@@ -62,9 +56,10 @@ sub requests_per ( $period, $num_periods, $before, @codes ) {
     }
     push( @input, $interval, $before, $num_periods );
 
+    ## no critic(ValuesAndExpressions::PreventSQLInjection)
     my $query = "SELECT count(*) FROM all_requests $whereclause GROUP BY date / ? HAVING date < ? LIMIT ?";
 
-    my @results = map { $_->[0] } @{ _dbh()->selectall_arrayref( $query, undef, @input ) };
+    my @results = map { $_->[0] } @{ Trog::Log::dbh()->selectall_arrayref( $query, undef, @input ) };
     my $np      = @results < $num_periods ? @results : $num_periods;
     my @labels  = reverse map { "$_ $period(s) ago" } ( 1 .. $np );
 

lib/Trog/Log/Syslog.pm

@@ -0,0 +1,88 @@
+package Trog::Log::Syslog;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use parent qw{Log::Dispatch::Output};
+
+use Log::Syslog::Fast qw{:protos :formats};
+
+=head1 Trog::Log::Syslog
+
+A Log::Dispatch output which hands each line to the syslog of the machine, over
+its unix socket.  From there journald and rsyslog have it, and whatever they
+forward it to.
+
+Name it in the C<loggers> of tpsgi.ini:
+
+    loggers = Trog::Log::Syslog
+
+tPSGI then adds it to its own logger, and TCMS passes the same list to
+log_init(), so both write here as well as to the rotated file.
+
+Lines go out as C<daemon>, tagged C<tcms>, at the severity of their level.
+Each keeps the timestamp that Trog::Log puts at its front, so a line on a log
+collector reads the same as the line in the file.
+
+=head1 Termination Conditions
+
+new() dies when it cannot connect to the socket.  A line that cannot be sent
+later is dropped without a word: the file output has it, and a request that
+fails because its log line did not arrive is worse than a line that did not
+arrive.
+
+=head1 METHODS
+
+=head2 new(%options) = Trog::Log::Syslog
+
+Takes what tPSGI hands every logger, C<min_level> and C<log_dir>, and ignores
+C<log_dir>.  C<socket> is where to send, F</dev/log> unless a test says
+otherwise.  C<ident> is the tag, C<tcms> unless given.
+
+=cut
+
+# LOG_DAEMON, from sys/syslog.h.
+my $DAEMON = 3;
+
+sub new ( $class, %p ) {
+    my $self = bless( {}, $class );
+    $self->_basic_init( map { exists $p{$_} ? ( $_ => $p{$_} ) : () } qw{name min_level max_level} );
+
+    my $socket = $p{socket} // '/dev/log';
+    my $ident  = $p{ident}  // 'tcms';
+
+    # The sender is left out of the format, as syslog(3) leaves it out when it
+    # writes to this socket, because the receiver is this machine.
+    $self->{syslog} = Log::Syslog::Fast->new( LOG_UNIX, $socket, 0, $DAEMON, 6, '', $ident );
+    $self->{syslog}->set_format(LOG_RFC3164_LOCAL);
+
+    return $self;
+}
+
+=head2 log_message(%p)
+
+Called by Log::Dispatch for each line at or above C<min_level>.
+
+=cut
+
+sub log_message ( $self, %p ) {
+
+    # Log::Dispatch numbers its levels from debug at 0 to emergency at 7, and
+    # syslog numbers its severities the other way round.
+    my $severity = 7 - $self->_level_as_number( $p{level} );
+
+    # Trog::Log ends every line with a newline, which a syslog message does
+    # not carry.
+    chomp( my $message = $p{message} );
+
+    local $@;
+    eval {
+        $self->{syslog}->set_severity($severity);
+        $self->{syslog}->send( $message, time );
+        1;
+    } or return;
+    return;
+}
+
+1;

lib/Trog/Renderer.pm

@@ -1,12 +1,8 @@
 package Trog::Renderer;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
-
-use Carp::Always;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use Trog::Vars;
 use Trog::Log qw{:all};
@@ -38,6 +34,31 @@ our %renderers = (
     email => \&Trog::Renderer::email::render,
 );
 
+my sub yeet ( $renderer, $error, %options ) {
+    WARN($error);
+
+    # All-else fails error page
+    my $ret;
+    local $@;
+    eval {
+        $ret = $renderer->(
+            code        => 500,
+            template    => '500.tx',
+            contenttype => 'text/html',
+            data        => { %options, content => "<h1>500 Internal Server Error</h1>$error" },
+        );
+        1;
+    } or do {
+        my $msg = $error;
+        $msg .= " and subsequently during render of error template, $@" if $renderer;
+
+        #XXX bytes is probably not correct here
+        INFO( "$options{data}{method} 500 " . length($msg) . " $options{data}{route}" );
+        FATAL($msg);
+    };
+    return $ret;
+}
+
 =head2 Trog::Renderer->render(%options)
 
 Returns either the 3-arg arrayref suitable to emit at the end of a PSGI session or a response body if the component field of options is truthy.
@@ -45,70 +66,54 @@ The idea is that components will be concatenated to other rendered templates unt
 
 =cut
 
-sub render ( $class, %options ) {
+sub render ( $, %options ) {
     local $@;
     my $renderer;
-    return _yeet( $renderer, "Renderer requires a valid content type to be passed", %options ) unless $options{contenttype};
+    return yeet( $renderer, "Renderer requires a valid content type to be passed", %options ) unless $options{contenttype};
     my $rendertype = $Trog::Vars::byct{ $options{contenttype} };
-    return _yeet( $renderer, "Renderer requires a known content type (used $options{contenttype}) to be passed", %options ) unless $rendertype;
+    return yeet( $renderer, "Renderer requires a known content type (used $options{contenttype}) to be passed", %options ) unless $rendertype;
     $renderer = $renderers{$rendertype};
-    return _yeet( $renderer, "Renderer for $rendertype is not defined!", %options ) unless $renderer;
-    return _yeet( $renderer, "Status code not provided",                 %options ) if !$options{code} && !$options{component};
-    return _yeet( $renderer, "Template data not provided",               %options ) unless $options{data};
-    return _yeet( $renderer, "Template not provided",                    %options ) unless $options{template};
+    return yeet( $renderer, "Renderer for $rendertype is not defined!", %options ) unless $renderer;
+    return yeet( $renderer, "Status code not provided",                 %options ) if !$options{code} && !$options{component};
+    return yeet( $renderer, "Template data not provided",               %options ) unless $options{data};
+    return yeet( $renderer, "Template not provided",                    %options ) unless $options{template};
 
     #TODO future - save the components too and then compose them?
-    my $skip_save = !$options{component} || !$options{data}{route} || $options{data}{has_query} || $options{data}{user} || ( $options{code} // 0 ) != 200 || Trog::Log::is_debug();
+    my $data = $options{data};
+
+    # $data->{nocache} as well as $options{nocache}: TCMS::build_routes puts a
+    # route's nocache flag on the query, and exactly one caller (login) has ever
+    # forwarded it here as an option.  Every other nocache route was relying on
+    # being auth-gated, so that the $data->{user} test below caught it -- which
+    # says nothing about a route that is nocache and public, and there is now
+    # one: a datasource whose posts go stale asks for it this way.
+    my $skip_save =
+         $options{component}
+      || $options{nocache}
+      || $data->{nocache}
+      || !$data->{route}
+      || $data->{has_query}
+      || $data->{user}
+      || ( $options{code} // 0 ) != 200
+      || Trog::Log::is_debug();
 
     my $ret;
     local $@;
     eval {
         $ret = $renderer->(%options);
-        save_render( $options{data}, $ret->[2], %{ $ret->[1] } ) unless $skip_save;
+        if ( exists $data->{tpsgi} && !$skip_save ) {
+            $data->{tpsgi}->add_post_close_callback(
+                sub {
+                    # We invalidate these in the individual routes themselves.
+                    $data->{tpsgi}->save_render( $data->{route}, $rendertype, $ret->[2][0] );
+                }
+            );
+        }
         1;
     } or do {
-        return _yeet( $renderer, $@, %options );
+        return yeet( $renderer, $@, %options );
     };
     return $ret;
 }
 
-sub _yeet ( $renderer, $error, %options ) {
-    WARN($error);
-
-    # All-else fails error page
-    my $ret;
-    local $@;
-    eval {
-        $ret = $renderer->(
-            code        => 500,
-            template    => '500.tx',
-            contenttype => 'text/html',
-            data        => { %options, content => "<h1>500 Internal Server Error</h1>$error" },
-        );
-        1;
-    } or do {
-        my $msg = $error;
-        $msg .= " and subsequently during render of error template, $@" if $renderer;
-        INFO("$options{data}{method} 500 $options{data}{route}");
-        FATAL($msg);
-    };
-    return $ret;
-}
-
-sub save_render ( $vars, $body, %headers ) {
-    Path::Tiny::path( "www/statics/" . dirname( $vars->{route} ) )->mkpath;
-    my $file = "www/statics/$vars->{route}";
-
-    my $verb = -f $file ? 'Overwrite' : 'Write';
-    DEBUG("$verb static for $vars->{route}");
-    open( my $fh, '>', $file ) or die "Could not open $file for writing";
-    print $fh "HTTP/1.1 $vars->{code} OK\n";
-    foreach my $h ( keys(%headers) ) {
-        print $fh "$h:$headers{$h}\n" if $headers{$h};
-    }
-    print $fh "\n";
-    print $fh $body;
-    close $fh;
-}
-
 1;

lib/Trog/Renderer/Base.pm

@@ -1,15 +1,14 @@
 package Trog::Renderer::Base;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use Encode qw{encode_utf8};
 use IO::Compress::Gzip;
 
 use Text::Xslate;
+use Trog::Component ();
 use Trog::Themes;
 use Trog::Config;
 use Time::HiRes qw{tv_interval};
@@ -18,21 +17,47 @@ use Time::HiRes qw{tv_interval};
 
 Basic rendering structure, subclass me.
 
-Sets up the methods which must be present for all templates, e.g. render_it for rendering dynamic template strings coming from a post.
+Sets up the functions which must be present for all templates: render_it, for rendering dynamic template strings coming from a post, and component, for pulling in a Trog::Component by name.
 
 =cut
 
 our %renderers;
 
+=head2 render(%options)
+
+Render a template and build the PSGI response around it.
+
+Recognized options:
+
+    template    => the template's filename, relative to the template dir.  Required.
+    contenttype => what we're rendering, e.g. 'text/html'.  Picks the template dir.
+    component   => render a component rather than a whole page.  Returns just the
+                   body string, with no headers and no compression.
+    data        => the variables handed to the template.
+    code        => HTTP status for the response.
+    headers     => extra headers, merged over the computed ones.
+    deflate     => gzip the body and set Content-Encoding.
+    post_processor => CODEREF run over the body before headers are computed, for
+                   things like minifiers.
+    child_processor / child_renderer => override how post bodies are rendered by
+                   the render_it() template function.  Built for you if omitted.
+
+Dies unless Xslate can resolve and render the template.  Returns the body
+string for components, and a PSGI arrayref of [ code, headers, body ] otherwise.
+
+=cut
+
 sub render (%options) {
     die "Templated renders require a template to be passed" unless $options{template};
 
-    my $template_dir = Trog::Themes::template_dir( $options{template}, $options{contenttype}, $options{component} );
-    my $t            = "$template_dir/$options{template}";
-    die "Templated renders require an existing template to be passed, got $template_dir/$options{template}" unless -f $t || -s $t;
+    # Xslate resolves includes against every dir in path, first match winning,
+    # so handing it both lets a theme override individual templates without
+    # having to fork the ones next to them.  With no theme configured this is
+    # just the stock dir, exactly as it was.
+    my @template_dirs = Trog::Themes::template_dirs( $options{contenttype}, $options{component} );
 
     #TODO make this work with posts all the time
-    $options{child_processor} //= Text::Xslate->new( path => $template_dir );
+    $options{child_processor} //= Text::Xslate->new( path => \@template_dirs );
     my $child_processor = $options{child_processor};
     $options{child_renderer} //= sub {
         my ( $template_string, $options ) = @_;
@@ -42,15 +67,44 @@ sub render (%options) {
         return $out ? $out : $template_string;
     };
 
-    $renderers{$template_dir} //= Text::Xslate->new(
-        path     => $template_dir,
+    # Keyed on the whole search path, not just the winning dir: two different
+    # paths that happen to start with the same dir are not the same renderer.
+    my $renderer_key = join( ':', @template_dirs );
+    $renderers{$renderer_key} //= Text::Xslate->new(
+        path     => \@template_dirs,
         function => {
             render_it => $options{child_renderer},
+
+            # A plain package sub rather than a closure, so the \%renderers
+            # memoization here cannot bake in whatever the first caller for this
+            # path happened to pass -- which it can, and does, for render_it.
+            component => \&Trog::Component::component,
         },
     );
 
     my $code = $options{code};
-    my $body = encode_utf8( $renderers{$template_dir}->render( $options{template}, $options{data} ) );
+
+    # Xslate resolves the template itself, against the same @template_dirs it
+    # will actually use.  There used to be a pre-flight test here, and it was
+    # wrong twice over: it resolved through template_dir(), which returns one
+    # winning directory rather than the search path, so it could pass on a file
+    # Xslate would not use and name a nonexistent stock path in its error while
+    # a good theme template existed.  And the condition itself, -f $t || -s $t,
+    # short-circuited on -f, so an empty file passed, while a *directory* passed
+    # on -s returning its size.
+    #
+    # $Trog::Component::error is how a failed component() call reaches us at all:
+    # Xslate catches an exception thrown out of a template function, warns, and
+    # renders on with an empty string in its place, so the render below succeeds
+    # with a hole in it.  Localised here so that a nested render (a component
+    # rendering its own template) doesn't answer for its parent's failure.
+    my $body = eval {
+        local $Trog::Component::error;
+        my $out = encode_utf8( $renderers{$renderer_key}->render( $options{template}, $options{data} ) );
+        die $Trog::Component::error if $Trog::Component::error;
+        $out;
+    };
+    die "Could not render template '$options{template}' (searched @template_dirs): $@" unless defined $body;
 
     # Users can supply a post_processor to futz with the output (such as with minifiers) if they wish.
     $body = $options{post_processor}->($body) if $options{post_processor} && ref $options{post_processor} eq 'CODE';
@@ -70,6 +124,17 @@ sub render (%options) {
     return [ $code, [%headers], [$dfh] ];
 }
 
+=head2 headers($options, $body) = %headers
+
+The response headers for a rendered body: content type and length, caching,
+Server-Timing, and the security headers (CSP, X-Frame-Options, HSTS when we're
+on https, nosniff).  Anything in $options->{headers} is merged over the top.
+
+ETags are only set for logged in users, as everyone else is served out of the
+static render cache.
+
+=cut
+
 sub headers ( $options, $body ) {
     my $query   = $options->{data};
     my $uh      = ref $options->{headers} eq 'HASH'      ? $options->{headers}        : {};
@@ -86,17 +151,19 @@ sub headers ( $options, $body ) {
 
     #Disallow framing UNLESS we are in embed mode
     my $ancestor = $query->{domain} || 'none';
-    $headers{"Content-Security-Policy"} = qq{frame-ancestors '$ancestor'} unless $query->{embed};
+    $headers{"Content-Security-Policy"} = qq{frame-ancestors $ancestor} unless $query->{embed};
 
     $headers{'X-Frame-Options'} = 'DENY' unless $query->{embed};
     $headers{'Referrer-Policy'} = 'no-referrer-when-downgrade';
 
     #CSP. Yet another layer of 'no mixed content' plus whitelisted execution of remote resources.
-    my $scheme = $query->{scheme} ? "$query->{scheme}:" : '';
+    # Component renders (posts.tx, the bars) get a data hash built by the route
+    # rather than the request, and it carries no scheme.
+    my $scheme = ( $query->{scheme} // '' ) eq 'https' ? "$query->{scheme}:" : '';
 
     my $conf  = Trog::Config::get();
     my $sites = $conf->param('security.allow_embeds_from') // '';
-    $headers{'Content-Security-Policy'} .= ";default-src $scheme 'self' 'unsafe-eval' 'unsafe-inline' $sites";
+    $headers{'Content-Security-Policy'} .= ";default-src $scheme 'self' data: 'unsafe-eval' 'unsafe-inline' $sites";
     $headers{'Content-Security-Policy'} .= ";object-src 'none'";
 
     # Force https if we are https

lib/Trog/Renderer/blob.pm

@@ -1,10 +1,8 @@
 package Trog::Renderer::blob;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 =head1 Trog::Renderer::blob
 
@@ -12,7 +10,7 @@ Render blobs, such as files stored in a DB.
 
 =cut
 
-# TODO use the streaming code from Trog::FileHandler, etc.
+# TODO stream large blobs, as TPSGI::serve streams files.
 sub render (%options) {
     my $code    = delete $options{code};
     my $headers = delete $options{headers};

lib/Trog/Renderer/css.pm

@@ -1,10 +1,8 @@
 package Trog::Renderer::css;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use parent qw{Trog::Renderer::Base};
 
@@ -17,12 +15,8 @@ Render CSS, and minify the output.
 =cut
 
 sub render (%options) {
-    $options{post_processor} = \&_minify;
-    Trog::Renderer::Base::render(%options);
-}
-
-sub _minify {
-    return CSS::Minifier::XS::minify(shift);
+    $options{post_processor} = \&CSS::Minifier::XS::minify;
+    return Trog::Renderer::Base::render(%options);
 }
 
 1;

lib/Trog/Renderer/email.pm

@@ -1,15 +1,11 @@
 package Trog::Renderer::email;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use parent qw{Trog::Renderer::Base};
 
-use Text::Xslate;
-use Trog::Themes;
 use Trog::Renderer::html;
 
 =head1 Trog::Renderer::email

lib/Trog/Renderer/html.pm

@@ -1,10 +1,8 @@
 package Trog::Renderer::html;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use parent qw{Trog::Renderer::Base};
 
@@ -30,14 +28,14 @@ sub render (%options) {
                 return Text::Xslate::mark_raw(
                     Trog::Routes::HTML::posts(
                         { route => "/post/$this_id", style => $style },
-                        sub { },
                         1
                     )
                 );
             },
         }
     );
-    state $child_renderer = sub {
+    $options{child_processor} = $child_processor;
+    $options{child_renderer}  = sub {
         my ( $template_string, $options ) = @_;
 
         # If it fails to render, it must be something else
@@ -45,9 +43,6 @@ sub render (%options) {
         return $out ? $out : $template_string;
     };
 
-    $options{child_processor} = $child_processor;
-    $options{child_renderer}  = $child_renderer;
-
     return Trog::Renderer::Base::render(%options);
 }
 

lib/Trog/Renderer/javascript.pm

@@ -1,28 +0,0 @@
-package Trog::Renderer::javascript;
-
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
-
-use parent qw{Trog::Renderer::Base};
-
-use JavaScript::Minifier::XS;
-
-=head1 Trog::Renderer::javascript
-
-Render JS, and minify the output.
-
-=cut
-
-sub render (%options) {
-    $options{post_processor} = \&_minify;
-    Trog::Renderer::Base::render(%options);
-}
-
-sub _minify {
-    return JavaScript::Minifier::XS::minify(shift);
-}
-
-1;

lib/Trog/Renderer/json.pm

@@ -1,10 +1,8 @@
 package Trog::Renderer::json;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use JSON::MaybeXS;
 

lib/Trog/Renderer/text.pm

@@ -1,17 +1,11 @@
 package Trog::Renderer::text;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use parent qw{Trog::Renderer::Base};
 
-use Text::Xslate;
-
-use Trog::Themes;
-
 =head1 Trog::Renderer::text
 
 Render plain text.  Can be used for email as well.
@@ -19,7 +13,7 @@ Render plain text.  Can be used for email as well.
 =cut
 
 sub render (%options) {
-    Trog::Renderer::Base::render(%options);
+    return Trog::Renderer::Base::render(%options);
 }
 
 1;

lib/Trog/Routes/JSON.pm

@@ -1,69 +1,66 @@
 package Trog::Routes::JSON;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use Clone qw{clone};
-use JSON::MaybeXS();
-
-use Scalar::Util();
 
 use Trog::Utils();
-use Trog::Config();
 use Trog::Auth();
 use Trog::Routes::HTML();
 
 use Trog::Log::Metrics();
 
-my $conf = Trog::Config::get();
-
-# TODO de-duplicate this, it's shared in html
-my $theme_dir = '';
-$theme_dir = "themes/" . $conf->param('general.theme') if $conf->param('general.theme') && -d "www/themes/" . $conf->param('general.theme');
-
+# The parameters of a route are OpenAPI 3 parameter objects, which
+# TCMS::build_routes puts in the operation that tPSGI validates a request by.
 our %routes = (
     '/api/catalog' => {
-        method     => 'GET',
-        callback   => \&catalog,
-        parameters => {},
+        method   => 'GET',
+        callback => \&catalog,
     },
     '/api/webmanifest' => {
-        method     => 'GET',
-        callback   => \&webmanifest,
-        parameters => {},
+        method   => 'GET',
+        callback => \&webmanifest,
     },
     '/api/version' => {
-        method     => 'GET',
-        callback   => \&version,
-        parameters => {},
+        method   => 'GET',
+        callback => \&version,
     },
-    '/api/auth_change_request/(.*)' => {
+    '/api/auth_change_request/{token}' => {
         method     => 'GET',
         callback   => \&process_auth_change_request,
-        captures   => ['token'],
-        parameters => {
-            token => sub { my $tok = shift; $tok =~ m/[a-f|0-9|-]+/; },
-        },
+        parameters => [
+            {
+                name     => 'token',
+                in       => 'path',
+                required => true,
+
+                # What Trog::Utils::uuid() makes, ended by \z because perl's $ allows a final newline.
+                schema => { type => 'string', pattern => '^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}\z' },
+            },
+        ],
         noindex    => 1,
         robot_name => '/api/auth_change_request/*',
     },
+    '/api/posts_of_form' => {
+        method     => 'GET',
+        auth       => 1,
+        parameters => [
+
+            # Same shape series.json demands of child_form.
+            { name => 'form', in => 'query', schema => { type => 'string', pattern => '^[A-Za-z0-9_-]+\.tx\z' } },
+        ],
+        callback => \&posts_of_form,
+        noindex  => 1,
+    },
     '/api/requests_per' => {
         method     => 'GET',
         auth       => 1,
-        parameters => {
-            period => sub {
-                grep {
-                    my $valid = $_;
-                    List::Util::any { $_ eq $valid } @_
-                } qw{second minute hour day week month year};
-            },
-            num_periods => \&Scalar::Util::looks_like_number,
-            before      => \&Scalar::Util::looks_like_number,
-            code        => \&Scalar::Util::looks_like_number,
-        },
+        parameters => [
+            { name => 'period', in => 'query', schema => { type => 'string', enum => [qw{second minute hour day week month year}] } },
+            map { { name => $_, in => 'query', schema => { type => 'number' } } } qw{num_periods before code},
+        ],
         callback => \&requests_per,
     },
 );
@@ -74,25 +71,37 @@ foreach my $r ( keys(%$cloned) ) {
     delete $cloned->{$r}{callback};
 }
 
-my $enc = JSON::MaybeXS->new( utf8 => 1 );
-
 # Note to authors, don't forget to update this
-sub _version () {
+my sub _version () {
     return '1.0';
 }
 
 # Special case of a non data-structure JSON return
-sub version ($query) {
+sub version {
     state $ret = [ 200, [ 'Content-type' => "application/json", ETag => 'version-' . _version() ], [ _version() ] ];
     return $ret;
 }
 
-sub catalog ($query) {
+my sub _render ( $code, $headers, %data ) {
+    return Trog::Renderer->render(
+        code        => $code,
+        data        => \%data,
+        template    => 'bogus.tx',
+        contenttype => 'application/json',
+        headers     => $headers,
+
+        # TODO it may be appropriate to cache some of these methods.
+        nocache => 1,
+    );
+}
+
+sub catalog {
     return _render( 200, { ETag => 'catalog-' . _version() }, %$cloned );
 }
 
-sub webmanifest ($query) {
-    state $headers  = { ETag => 'manifest-' . _version() };
+sub webmanifest {
+    state $headers = { ETag => 'manifest-' . _version() };
+    my $theme_dir = Trog::Themes::get_dir();
     state %manifest = (
         "icons" => [
             { "src" => "$theme_dir/img/icon/favicon-32.png",  "type" => "image/png", "sizes" => "32x32" },
@@ -110,7 +119,7 @@ sub process_auth_change_request ($query) {
     my $token = $query->{token};
 
     my $msg = Trog::Auth::process_change_request($token);
-    return Trog::Routes::HTML::forbidden($query) unless $msg;
+    return $query->{tpsgi}->forbidden($query) unless $msg;
     return _render(
         200, undef,
         message => $msg,
@@ -118,21 +127,34 @@ sub process_auth_change_request ($query) {
     );
 }
 
-sub requests_per ($query) {
-    my $code = Trog::Utils::coerce_array( $query->{code} );
+=head2 posts_of_form
+
+Implements GET /api/posts_of_form.  Requires a login.
+
+The id and title of every post of the named type which the caller is allowed to
+see.  This is what fills a relation field's dropdown in the post editor -- see
+www/scripts/post_relations.js and the x-tcms-relations tables in the post type
+sidecars.
+
+Only id and title: the caller is populating a picker, and a post's body is
+nobody's business here.
+
+=cut
+
+sub posts_of_form ($query) {
+    my @posts = Trog::Routes::HTML::post_helper( { form => $query->{form}, limit => 0 }, [], [ Trog::Routes::HTML::viewer_acls($query) ] );
+
     return _render(
         200, undef,
-        %{ Trog::Log::Metrics::requests_per( $query->{period}, $query->{num_periods}, $query->{before}, @$code ) }
+        posts => [ map { { id => $_->{id}, title => $_->{title} } } @posts ],
     );
 }
 
-sub _render ( $code, $headers, %data ) {
-    return Trog::Renderer->render(
-        code        => 200,
-        data        => \%data,
-        template    => 'bogus.tx',
-        contenttype => 'application/json',
-        headers     => $headers,
+sub requests_per ($query) {
+    my $code = Trog::Utils::coerce_array( $query->{code} );
+    return _render(
+        200, undef,
+        %{ Trog::Log::Metrics::requests_per( $query->{period}, $query->{num_periods}, $query->{before}, @$code ) }
     );
 }
 

lib/Trog/Routes/TXT.pm

@@ -1,50 +0,0 @@
-package Trog::Routes::JSON;
-
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
-
-use Clone qw{clone};
-use JSON::MaybeXS();
-
-use Scalar::Util();
-
-use Trog::Utils();
-use Trog::Config();
-use Trog::Auth();
-use Trog::Routes::HTML();
-
-use Trog::Log::Metrics();
-
-my $conf = Trog::Config::get();
-
-# TODO de-duplicate this, it's shared in html
-my $theme_dir = '';
-$theme_dir = "themes/" . $conf->param('general.theme') if $conf->param('general.theme') && -d "www/themes/" . $conf->param('general.theme');
-
-our %routes = (
-    '/text/zone' => {
-        method     => 'GET',
-        callback   => \&zone,
-        parameters => {},
-        admin      => 1,
-    },
-);
-
-sub zone ($query) {
-    return _render( 200, {}, $query );
-}
-
-sub _render ( $code, $headers, %data ) {
-    return Trog::Renderer->render(
-        code        => 200,
-        data        => \%data,
-        template    => 'zone.tx',
-        contenttype => 'text/plain',
-        headers     => $headers,
-    );
-}
-
-1;

lib/Trog/SQLite.pm

@@ -1,121 +0,0 @@
-package Trog::SQLite;
-
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
-
-use POSIX qw{floor};
-
-use DBI;
-use DBD::SQLite;
-use File::Touch;
-use File::Slurper();
-use List::Util qw{any};
-
-=head1 Name
-
-Trog::SQLite - Abstracts the boilerpain away!
-
-=head1 SYNOPSIS
-
-    my $dbh = Trog::SQLite::dbh("my_schema.sql", "my_sqlite3.db");
-    ...
-
-=head1 FUNCTIONS
-
-Everything in this module throws when something goes wrong.
-
-=head2 dbh
-
-Get you a database handle with fkeys turned on, and schema consistency enforced.
-Caches the handle past the first call.
-
-Be careful when first calling, the standard fork-safety concerns with sqlite apply
-
-=cut
-
-# We need to make sure this is different across forks, AND consistent within them.
-my $dbh = {};
-
-# Ensure the db schema is OK, and give us a handle
-# WARNING: do not ever call during BEGIN or outside a sub.
-# Otherwise, we can't preload_app.
-sub dbh {
-    my ( $schema, $dbname ) = @_;
-    $dbh //= {};
-    return $dbh->{$dbname} if $dbh->{$dbname};
-    File::Touch::touch($dbname) unless -f $dbname;
-    my $db = DBI->connect( "dbi:SQLite:dbname=$dbname", "", "" );
-
-    if ($schema) {
-        die "No such schema file '$schema' !" unless -f $schema;
-        my $qq = File::Slurper::read_text($schema);
-        $db->{sqlite_allow_multiple_statements} = 1;
-        $db->do($qq) or die "Could not ensure database consistency: " . $db->errstr;
-        $db->{sqlite_allow_multiple_statements} = 0;
-    }
-
-    $dbh->{$dbname} = $db;
-
-    # Turn on fkeys
-    $db->do("PRAGMA foreign_keys = ON") or die "Could not enable foreign keys";
-
-    # Turn on WALmode
-    $db->do("PRAGMA journal_mode = WAL") or die "Could not enable WAL mode";
-
-    return $db;
-}
-
-=head2 bulk_insert(DBI $dbh, STRING $table, ARRAYREF $keys, STRING $action='IGNORE', MIXED @values)
-
-Insert the values into specified table corresponding to the provided keys.
-Values must be repeating tuples corresponding to the values. Example:
-
-    my $keys   = [qw{A B C}];
-    my @values = qw{1 2 3 4 5 6 7 8 9};
-
-Essentially works around the 999 named param limit and executes by re-using prepared statements.
-This results in a quick insert/update of lots of data, such as when building an index or importing data.
-
-For the vast majority of in-practice usage, this will be swatting flies with an elephant gun.
-That said, it should always do the job correctly and quickly, even for trivial datasets.
-
-If you don't put fkeys in place (or simply turn them off),
-you can use REPLACE as your action to do upserts without causing destructive consequences.
-It's less code than writing an ON CONFLICT UPDATE clause, and faster.
-
-Batch your values to whatever is appropriate given your available heap.
-
-=cut
-
-sub bulk_insert ( $dbh, $table, $keys, $ACTION = 'IGNORE', @values ) {
-    die "unsupported insert action $ACTION" unless any { $ACTION eq $_ } qw{ROLLBACK ABORT FAIL IGNORE REPLACE};
-
-    die "keys must be nonempty ARRAYREF" unless ref $keys eq 'ARRAY' && @$keys;
-    die "#Values must be a multiple of #keys" if @values % @$keys;
-
-    my ( $smt, $query ) = ( '', '' );
-    while (@values) {
-
-        #Must have even multiple of #keys, so floor divide and chop remainder
-        my $nkeys = scalar(@$keys);
-        my $limit = floor( 999 / $nkeys );
-        $limit = $limit - ( $limit % $nkeys );
-        $smt   = '' if scalar(@values) < $limit;
-        my @params = splice( @values, 0, $limit );
-        if ( !$smt ) {
-            my @value_tuples;
-            my @huh = map { '?' } @params;
-            while (@huh) {
-                push( @value_tuples, "(" . join( ',', ( splice( @huh, 0, $nkeys ) ) ) . ")" );
-            }
-            $query = "INSERT OR $ACTION INTO $table (" . join( ',', @$keys ) . ") VALUES " . join( ',', @value_tuples );
-            $smt   = $dbh->prepare($query);
-        }
-        $smt->execute(@params);
-    }
-}
-
-1;

lib/Trog/SQLite/TagIndex.pm

@@ -1,10 +1,8 @@
 package Trog::SQLite::TagIndex;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use URI::Escape;
 use List::Util qw{uniq};
@@ -22,15 +20,16 @@ Also used to retrieve cached routes from posts.
 =cut
 
 sub posts_for_tags (@tags) {
-    my $dbh    = _dbh();
+    my $dbh    = dbh();
     my $clause = @tags ? "WHERE tag IN (" . join( ',', ( map { '?' } @tags ) ) . ")" : '';
-    my $rows   = $dbh->selectall_arrayref( "SELECT DISTINCT id FROM posts $clause ORDER BY created DESC", { Slice => {} }, @tags );
+    ## no critic(ValuesAndExpressions::PreventSQLInjection)
+    my $rows = $dbh->selectall_arrayref( "SELECT DISTINCT id FROM posts $clause ORDER BY created DESC", { Slice => {} }, @tags );
     return () unless ref $rows eq 'ARRAY' && @$rows;
     return map { $_->{id} } @$rows;
 }
 
 sub routes {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT id, route, method, callback FROM all_routes", { Slice => {} } );
     return () unless ref $rows eq 'ARRAY' && @$rows;
 
@@ -40,7 +39,7 @@ sub routes {
 }
 
 sub aliases {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT actual,alias FROM aliases", { Slice => {} } );
     return () unless ref $rows eq 'ARRAY' && @$rows;
     my %aliases = map { $_->{alias} => $_->{actual} } @$rows;
@@ -48,21 +47,55 @@ sub aliases {
 }
 
 sub tags {
-    my $dbh  = _dbh();
+    my $dbh  = dbh();
     my $rows = $dbh->selectall_arrayref( "SELECT name FROM tag", { Slice => {} } );
     return () unless ref $rows eq 'ARRAY' && @$rows;
     return map { $_->{name} } @$rows;
 }
 
 sub add_post ( $post, $data_obj ) {
-    my $dbh = _dbh();
-    build_index( $data_obj, [$post] );
-    build_routes( $data_obj, [$post] );
+    my $dbh = dbh();
+    Trog::SQLite::transaction(
+        $dbh,
+        sub {
+            # posts_index has no key for INSERT OR IGNORE to skip a duplicate on,
+            # so a save would add every tag again and keep the ones it removed.
+            $dbh->do( "DELETE FROM posts_index WHERE post_id IN (SELECT id FROM post WHERE uuid=?)", undef, $post->{id} );
+            build_index( $data_obj, [$post] );
+            build_routes( $data_obj, [$post] );
+        }
+    );
+    return 1;
+}
+
+=head2 rebuild($data_obj)
+
+Empty the index, the route table and the aliases, then fill them again from
+every post $data_obj holds.  It is one transaction, so a reader sees the old
+index or the new one, and never an empty one.
+
+The HTTP methods are kept, as the schema fills those rather than any post.
+
+=cut
+
+sub rebuild ($data_obj) {
+    my $dbh = dbh();
+    Trog::SQLite::transaction(
+        $dbh,
+        sub {
+            # Cascades to posts_index, routes and post_aliases.
+            $dbh->do("DELETE FROM post");
+            $dbh->do("DELETE FROM tag");
+            $dbh->do("DELETE FROM callbacks");
+            build_index($data_obj);
+            build_routes($data_obj);
+        }
+    );
     return 1;
 }
 
 sub remove_post ($post) {
-    my $dbh = _dbh();
+    my $dbh = dbh();
 
     # Deleting the post will cascade to the post index & primary route, which cascades to the aliases
     $dbh->do( "DELETE FROM post WHERE uuid=?", undef, $post->{id} );
@@ -74,20 +107,27 @@ sub remove_post ($post) {
     return 1;
 }
 
+my sub id_for_uuid ( $dbh, @uuids ) {
+    my $bind = join( ',', ( map { '?' } @uuids ) );
+    Trog::SQLite::bulk_insert( $dbh, 'post', ['uuid'], 'IGNORE', @uuids );
+    ## no critic(ValuesAndExpressions::PreventSQLInjection)
+    return $dbh->selectall_hashref( "SELECT id,uuid FROM post WHERE uuid IN ($bind)", 'uuid', {}, @uuids );
+}
+
 sub build_index ( $data_obj, $posts = [] ) {
-    my $dbh = _dbh();
+    my $dbh = dbh();
     $posts = $data_obj->read( { limit => 0, acls => ['admin'] } ) unless @$posts;
 
     # First, slap in the UUIDs
     my @uuids = map { $_->{id} } @$posts;
     Trog::SQLite::bulk_insert( $dbh, 'post', ['uuid'], 'IGNORE', @uuids );
-    my $pids = _id_for_uuid( $dbh, @uuids );
+    my $pids = id_for_uuid( $dbh, @uuids );
     foreach my $post (@$posts) {
         $post->{post_id} = $pids->{ $post->{id} }{id};
     }
 
     # Slap in the tags, plus the aclname in the event this is a series
-    my @tags = uniq map { @{ $_->{tags} }, $_->{aclname} } @$posts;
+    my @tags = uniq map { ( @{ $_->{tags} }, $_->{aclname} ) } @$posts;
     Trog::SQLite::bulk_insert( $dbh, 'tag', ['name'], 'IGNORE', @tags );
 
     #TODO restrict query to only the specific tags we care about
@@ -105,21 +145,16 @@ sub build_index ( $data_obj, $posts = [] ) {
             map { ( $subj->{post_id}, $subj->{created}, $t->{$_} ) } @{ $subj->{tags} }
         } @$posts
     );
-}
-
-sub _id_for_uuid ( $dbh, @uuids ) {
-    my $bind = join( ',', ( map { '?' } @uuids ) );
-    Trog::SQLite::bulk_insert( $dbh, 'post', ['uuid'], 'IGNORE', @uuids );
-    return $dbh->selectall_hashref( "SELECT id,uuid FROM post WHERE uuid IN ($bind)", 'uuid', {}, @uuids );
+    return 1;
 }
 
 # It is important we use get() instead of read() because of incomplete data.
 sub build_routes ( $data_obj, $posts = [] ) {
-    my $dbh = _dbh();
+    my $dbh = dbh();
     @$posts = $data_obj->get( limit => 0, acls => ['admin'] ) unless @$posts;
 
     my @uuids = map { $_->{id} } @$posts;
-    my $pids  = _id_for_uuid( $dbh, @uuids );
+    my $pids  = id_for_uuid( $dbh, @uuids );
     foreach my $post (@$posts) {
         $post->{post_id} = $pids->{ $post->{id} }{id};
     }
@@ -147,10 +182,17 @@ sub build_routes ( $data_obj, $posts = [] ) {
         my $route = $post->{local_href};
         Trog::SQLite::bulk_insert( $dbh, 'post_aliases', [qw{route_id alias}], 'IGNORE', map { ( $routes_actual{$route}{id}, $_ ) } @{ $post->{aliases} } );
     }
+    return 1;
 }
 
-# Ensure the db schema is OK, and give us a handle
-sub _dbh {
+=head2 dbh() = DBI::db
+
+The handle to the tag index, data/posts.db, with its schema applied.
+Trog::SQLite caches it, so every call gets the same one.
+
+=cut
+
+sub dbh {
     my $file   = 'schema/flatfile.schema';
     my $dbname = "data/posts.db";
     return Trog::SQLite::dbh( $file, $dbname );

lib/Trog/Themes.pm

@@ -1,10 +1,11 @@
 package Trog::Themes;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-no warnings 'experimental';
-use feature qw{signatures state};
+use FindBin::libs;
+use Path::Tiny();
 
 use Trog::Vars;
 use Trog::Config;
@@ -15,61 +16,246 @@ Utility functions for getting themed paths.
 
 =cut
 
-my $conf = Trog::Config::get();
 our $template_dir = 'www/templates';
-our $theme_dir    = '';
-$theme_dir = "www/themes/" . $conf->param('general.theme') if $conf->param('general.theme') && -d "www/themes/" . $conf->param('general.theme');
-our $td = $theme_dir ? "/$theme_dir" : '';
 
-sub template_dir ( $template, $content_type, $is_component = 0, $is_dir = 0 ) {
-    my $ct = $Trog::Vars::byct{$content_type};
-    my ( $mtd, $mtemp ) = ( "$theme_dir/templates/$ct", "$template_dir/$ct" );
+=head2 routes() = %routes
+
+The active theme's own routing table, from its routes.pm.
+
+Themes can add routes of their own by shipping a routes.pm which populates
+%Theme::routes.  Returns an empty list when there's no theme, or when the theme
+hasn't got one.  Dies if there is a routes.pm and it won't load, as silently
+serving a site with half its routes missing is worse than not starting.
+
+=cut
+
+sub routes {
+    my $rdir = get_dir();
+    return () unless -f "$rdir/routes.pm";    ## no critic (ProhibitFiletest_f) -- theme ships routes, or it does not
+
+    # get_dir() is relative to the tCMS root, which require only searches from '.'.
+    local @INC = ( '.', @INC );
+    local $@;
+    eval { require "$rdir/routes.pm"; 1; } or do {    ## no critic (Modules::RequireBarewordIncludes) -- a theme ships a file, not a module
+        die "Could not load Theme routing package: $@";
+    };
+
+    no warnings 'once';
+    return %Theme::routes;
+}
+
+=head2 get_dir() = STRING $dir
+
+The active theme's directory, relative to the tCMS root, e.g.
+C<www/themes/mytheme>.  Empty string when no theme is configured, or when the
+configured one doesn't exist on disk -- so it's safe to interpolate either way,
+and truthiness is the test for "is there a theme".
+
+Memoized for the life of the process: changing the theme goes through
+/config/save, which signals the workers to restart.
+
+=cut
+
+sub get_dir {
+    state $tdir = '';
+    return $tdir if $tdir;
+    my $conf  = Trog::Config::get();
+    my $theme = $conf->param('general.theme') || '';
+    if ($theme) {
+        my $themedir = "www/themes/$theme";
+        $tdir = $themedir if -d $themedir;
+    }
+    return $tdir;
+}
+
+=head2 td() = STRING $dir
+
+get_dir() as a rooted URL path rather than a filesystem one, for templates to
+build asset links with.  Empty string when there's no theme.
+
+=cut
+
+sub td {
+    my $dir = get_dir();
+    return $dir ? "/$dir" : '';
+}
+
+# The theme's template dir and the stock one, in that order of preference.
+# The theme entry is empty when no theme is configured, so callers can just
+# grep for truth rather than repeating the "is there a theme" dance.
+my sub _template_dirs ( $content_type, $is_component = 0 ) {
+    my $ct    = $Trog::Vars::byct{$content_type};
+    my $theme = get_dir();
+
+    my ( $themed, $stock ) = ( $theme ? "$theme/templates/$ct" : '', "$template_dir/$ct" );
     if ($is_component) {
-        $mtd   .= "/components";
-        $mtemp .= "/components";
+        $themed .= "/components" if $themed;
+        $stock  .= "/components";
     }
+    return ( $themed, $stock );
+}
+
+=head2 template_dirs($content_type, $is_component)
+
+Every directory which could satisfy a template, most specific first.
+
+Hand this to Text::Xslate as its C<path> and a theme gets to override
+individual templates without having to fork every last one of them.
+
+=cut
+
+sub template_dirs ( $content_type, $is_component = 0 ) {
+    return grep { $_ && -d $_ } _template_dirs( $content_type, $is_component );
+}
+
+=head2 template_dir($template, $content_type, $is_component, $is_dir)
+
+The single directory which owns $template: the theme's if it has its own copy,
+the stock one otherwise.  With $is_dir, $template names a subdirectory (forms,
+headers, footers) rather than a file.
+
+This answers "who owns this one thing", which is what you want when *writing*.
+For reading a whole directory you almost always want themed_templates_in_dir()
+instead, which spans both rather than making you pick.
+
+=cut
+
+sub template_dir ( $template, $content_type, $is_component = 0, $is_dir = 0 ) {
+    my ( $mtd, $mtemp ) = _template_dirs( $content_type, $is_component );
     if ($is_dir) {
         return $mtd && -d "$mtd/$template" ? $mtd : $mtemp;
     }
-    return $mtd && -f "$mtd/$template" ? $mtd : $mtemp;
+    return $mtd && -f "$mtd/$template" ? $mtd : $mtemp;    ## no critic (ProhibitFiletest_f) -- which dir owns the template
 }
 
 # Pick appropriate dir based on whether theme override exists
-sub _dir_for_resource ($resource) {
-    return $theme_dir && -f "$theme_dir/$resource" ? $theme_dir : '';
+my sub dir_for_resource ($resource) {
+    my $theme_dir = get_dir();
+    return $theme_dir && -f "$theme_dir/$resource" ? $theme_dir : '';    ## no critic (ProhibitFiletest_f) -- theme override, else stock
 }
 
+=head2 themed($resource)
+
+Path to a www/-relative resource, preferring the theme's copy.
+
+=cut
+
 sub themed ($resource) {
-    return _dir_for_resource("$resource") . "/$resource";
+    return dir_for_resource("$resource") . "/$resource";
 }
 
+=head2 themed_style($resource) = @hrefs
+
+Stylesheets are the exception to the "one or the other" rule: you get the stock
+sheet *and* the theme's, in that order, so a theme can override a handful of
+rules without restating the whole thing.
+
+=cut
+
 # For style we want to load *both* style files and have the override come later.
 sub themed_style ($resource) {
     my @styles = ("/styles/$resource");
-    my $styled = _dir_for_resource("styles/$resource");
+    my $styled = dir_for_resource("styles/$resource");
     $styled =~ s/^www\///;
     push( @styles, "/$styled/styles/$resource" ) if $styled;
     return @styles;
 }
 
+=head2 themed_script($resource)
+
+Path to a script under www/scripts, preferring the theme's copy.
+
+=cut
+
 sub themed_script ($resource) {
-    return _dir_for_resource("scripts/$resource") . "/scripts/$resource";
+    return dir_for_resource("scripts/$resource") . "/scripts/$resource";
+}
+
+=head2 dir_for($path, $content_type, $is_component)
+
+The single directory which owns a given component subdir: the theme's if it has
+one, the stock one otherwise.  This is the right answer for I<writing> -- see
+forms_dir() and the post type wizard.  For reading, you almost certainly want
+themed_templates_in_dir() instead, which spans both.
+
+=cut
+
+sub dir_for ( $path, $ct, $is_component = 0 ) {
+    return template_dir( $path, $ct, $is_component, 1 ) . "/$path";
+}
+
+=head2 forms_dir()
+
+dir_for() the post type forms directory, which is where the post type wizard
+writes new types and their schema sidecars.
+
+=cut
+
+sub forms_dir {
+    return dir_for( 'forms', 'text/html', 1 );
 }
 
-sub themed_template ($resource) {
-    return _dir_for_resource("templates/$resource") . "/templates/$resource";
+=head2 themed_templates_in_dir($path, $content_type, $is_component)
+
+The template names in an abstract template dir, from the theme and the stock
+tree both: the theme's templates where the theme has them, plus the stock ones
+it hasn't overridden.  dir_for() is winner-take-all, so a theme with a forms/
+dir of its own would otherwise hide every core post type.
+
+Returns bare filenames, deduped, theme first.  Which of the two files a given
+name resolves to is then up to whoever renders it -- see template_dirs().
+
+=cut
+
+sub themed_templates_in_dir ( $path, $ct, $is_component = 0 ) {
+    my @dirs = grep { $_ } map { "$_/$path" } _template_dirs( $ct, $is_component );
+
+    my ( @templates, %seen );
+    foreach my $dir (@dirs) {
+        next unless -d $dir;
+        my @files = eval {
+            grep { -f } Path::Tiny::path($dir)->children(qr/[.]tx\z/);    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
+        };
+        foreach my $template ( map { $_->basename } @files ) {
+
+            # First one wins, and the theme's dir comes first.
+            push( @templates, $template ) unless $seen{$template}++;
+        }
+    }
+    return \@templates;
 }
 
-sub templates_in_dir ( $path, $ct, $is_component = 0 ) {
-    $path = template_dir( $path, $ct, $is_component, 1 ) . "/$path";
-    my $forms = [];
-    return $forms unless -d $path;
-    opendir( my $dh, $path );
-    while ( my $form = readdir($dh) ) {
-        push( @$forms, $form ) if -f "$path/$form" && $form =~ m/.*\.tx$/;
+=head2 themed_file_in_dir($path, $file, $content_type, $is_component)
+
+The path to a single named file in an abstract template dir, preferring the
+theme's copy.  Returns undef when neither has it.
+
+=cut
+
+sub themed_file_in_dir ( $path, $file, $ct, $is_component = 0 ) {
+    foreach my $dir ( grep { $_ } _template_dirs( $ct, $is_component ) ) {
+        return "$dir/$path/$file" if -f "$dir/$path/$file";    ## no critic (ProhibitFiletest_f) -- search path, first hit wins
+    }
+    return undef;
+}
+
+=head2 themed_component($file, $content_type)
+
+The path to a file sitting directly in the components dir rather than in one of
+its subdirectories, preferring the theme's copy.  Returns undef when neither has
+it.
+
+This is themed_file_in_dir() for the components which are not post types: the
+canned editor blocks every form splices in, and the JSON sidecars beside them
+which say what each one collects -- see Trog::DataModule::include_schema_for().
+
+=cut
+
+sub themed_component ( $file, $ct = 'text/html' ) {
+    foreach my $dir ( template_dirs( $ct, 1 ) ) {
+        return "$dir/$file" if -f "$dir/$file";    ## no critic (ProhibitFiletest_f) -- search path, first hit wins
     }
-    close($dh);
-    return $forms;
+    return undef;
 }
 
 1;

lib/Trog/Utils.pm

@@ -1,49 +1,60 @@
 package Trog::Utils;
 
-use strict;
-use warnings;
-
-no warnings 'experimental';
-use feature qw{signatures state};
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
 use UUID;
-use HTTP::Tiny::UNIX();
 use Plack::MIME;
 use Mojo::File;
 use File::LibMagic;
 use Ref::Util qw{is_hashref};
 
-use Trog::Log qw{WARN};
-use Trog::Config();
+=head1 Trog::Utils
+
+Odds and ends which are needed in more than one place and belong to no
+particular subsystem.
+
+=head1 FUNCTIONS
+
+=head2 coerce_array(SCALAR|ARRAYREF param) = ARRAYREF
+
+Deal with Params which may or may not be arrays.
+
+Query parameters arrive as a bare scalar when the caller passed one of
+something and as an arrayref when they passed several, which means every
+consumer would otherwise have to check.  Returns an empty arrayref for anything
+false, so the result is always safe to dereference.
+
+=cut
 
-# Deal with Params which may or may not be arrays
 sub coerce_array ($param) {
     my $p = $param || [];
     $p = [$param] if $param && ( ref $param ne 'ARRAY' );
     return $p;
 }
 
+=head2 strip_and_trunc(STRING s) = STRING
+
+Flatten a chunk of post body into something fit for a meta description or
+preview blurb -- tags stripped, truncated to 280 characters.
+
+Returns undef when handed nothing, rather than an empty string.
+
+=cut
+
 sub strip_and_trunc ($s) {
     return unless $s;
     $s =~ s/<[^>]*>//g;
     return substr $s, 0, 280;
 }
 
-# Instruct the parent to restart.  Normally this is HUP, but nginx-unit decides to be special.
-# Don't do anything if running NOHUP=1, which is useful when doing bulk operations
-sub restart_parent {
-    return if $ENV{NOHUP};
-    if ( $ENV{PSGI_ENGINE} && $ENV{PSGI_ENGINE} eq 'nginx-unit' ) {
-        my $conf         = Trog::Config->get();
-        my $nginx_socket = $conf->param('nginx-unit.socket');
-        my $client       = HTTP::Tiny::UNIX->new();
-        my $res          = $client->request( 'GET', "http:$nginx_socket//control/applications/tcms/restart" );
-        WARN("could not reload application (got $res->{status} from nginx-unit)!") unless $res->{status} == 200;
-        return 1;
-    }
-    my $parent = getppid;
-    kill 'HUP', $parent;
-}
+=head2 uuid() = STRING
+
+A fresh UUID.  Thin wrapper around UUID::uuid(), so that callers don't have to
+care which of the several UUID modules we ended up using.
+
+=cut
 
 sub uuid {
     return UUID::uuid();
@@ -54,6 +65,19 @@ my %extra_types = (
     '.docx' => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
 );
 
+=head2 mime_type(STRING file) = STRING
+
+Figure out a file's Content-Type.
+
+Tries the extension first, as that's cheap and right nearly all of the time,
+and only falls back to libmagic sniffing the file's contents when the extension
+tells us nothing.  %extra_types patches in the handful of types the upstream
+finders don't know about.
+
+Returns undef if even libmagic can't say.
+
+=cut
+
 sub mime_type ($file) {
 
     # Use libmagic and if that doesn't work try guessing based on extension.

lib/Trog/Vars.pm

@@ -1,17 +1,40 @@
 package Trog::Vars;
 
-use strict;
-use warnings;
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
 
-use feature qw{signatures};
-no warnings qw{experimental};
+=head1 Trog::Vars
 
-use Ref::Util();
-use List::Util qw{any};
+Constants shared between the data model, the renderer and the routes.
 
-#1MB chunks
-our $CHUNK_SEP  = 'tCMSep666YOLO42069';
-our $CHUNK_SIZE = 1024000;
+Nothing here is computed; it's all package variables so that callers can read
+them directly rather than paying for a function call on every request.
+
+=head2 VARIABLES
+
+=over 4
+
+=item %content_types
+
+Maps the short names used in templates and route definitions (html, json, ...)
+onto the Content-Type header they mean.
+
+=item %byct
+
+The reverse of %content_types, for going from a Content-Type back to the short
+name -- which is how the renderer picks which Trog::Renderer subclass handles a
+response.
+
+=item %cache_control
+
+Named Cache-Control policies.  'revalidate' for content which may have changed,
+'nocache' for anything user specific, and 'static' for assets which are
+immutable once published.
+
+=back
+
+=cut
 
 our %content_types = (
     text  => "text/plain",
@@ -33,91 +56,8 @@ our %cache_control = (
     static     => "public, max-age=604800, immutable",
 );
 
-our $not_ref = sub {
-    return !Ref::Util::is_ref(shift);
-};
-
-our $valid_cb = sub {
-    my $subname = shift;
-    my ($modname) = $subname =~ m/^([\w|:]+)::\w+$/;
-
-    # Modules always return 0 if they succeed!
-    eval { require $modname; } and do {
-        WARN("Post uses a callback whos module ($modname) cannot be found!");
-        return 0;
-    };
-
-    no strict 'refs';
-    my $ref = eval '\&' . $subname;
-    use strict;
-    return Ref::Util::is_coderef($ref);
-};
-
-our $hashref_or_string = sub {
-    my $subj = shift;
-    return Ref::Util::is_hashref($subj) || $not_ref->($subj);
-};
-
-# Shared Post schema
-our %schema = (
-    ## Parameters which must be in every single post
-    'title'      => $not_ref,
-    'callback'   => $valid_cb,
-    'tags'       => \&Ref::Util::is_arrayref,
-    'version'    => $not_ref,
-    'visibility' => $not_ref,
-    'aliases'    => \&Ref::Util::is_arrayref,
-
-    # title links here
-    'href' => $not_ref,
-
-    # Link to post locally
-    'local_href' => $not_ref,
-
-    # Post body
-    'data' => $not_ref,
-
-    # How do I edit this post?
-    'form' => $not_ref,
-
-    # Post is restricted to visibility to these ACLs if not public/unlisted
-    'acls' => \&Ref::Util::is_arrayref,
-    'id'   => $not_ref,
-
-    # Author of the post
-    'user'    => $not_ref,
-    'created' => $not_ref,
-);
-
-=head2 filter($data,[$schema]) = %$data_filtered
-
-Filter the provided data through the default schema, and optionally a user-provided schema.
-
-Remove unwanted params to keep data slim & secure.
-
-=cut
-
-sub filter ( $data, $user_schema = {} ) {
-    %$user_schema = (
-        %schema,
-        %$user_schema,
-    );
-
-    # Filter all the irrelevant data
-    foreach my $key ( keys(%$data) ) {
-
-        # We need to have the key in the schema, and it validate.
-        delete $data->{$key} unless List::Util::any { ( $_ eq $key ) && ( $user_schema->{$key}->( $data->{$key} ) ) } keys(%$user_schema);
-
-        #use Data::Dumper;
-        #print Dumper($data);
-
-        # All parameters in the schema are MANDATORY.
-        foreach my $param ( keys(%$user_schema) ) {
-            die "Missing mandatory parameter $param" unless exists $data->{$param};
-        }
-    }
-    return %$data;
-}
+# NOTE: the post schema and its validators used to be duplicated here as well
+# as in Trog::DataModule, and filter() had no callers at all.  Both are gone --
+# a post's shape is now an OpenAPIv3 schema, see Trog::DataModule::schema_for().
 
 1;

lib/Trog/Vault.pm

@@ -0,0 +1,359 @@
+package Trog::Vault;
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Crypt::AuthEnc::GCM  ();
+use Crypt::KeyDerivation ();
+use Crypt::Misc          ();
+use Crypt::PRNG          ();
+use Digest::SHA          ();
+use File::Slurper        ();
+
+use Trog::Auth;
+use Trog::Log qw{WARN INFO};
+use Trog::SQLite;
+
+=head1 Trog::Vault
+
+Things a user asked us to remember, kept where the database alone will not give
+them up.
+
+=head1 WHAT THIS IS FOR
+
+Some of what tCMS does on a user's behalf needs a password that is not tCMS's:
+the KeePass passphrase every provisioning recipe's secret: values are behind,
+for one.  Asking for it every time works, and is what reprovisioning used to do,
+but it means the person has to be holding it -- so it gets written down, and the
+thing that was too dangerous to keep in a config file ends up in a text file
+instead.
+
+So we keep it, and ask for a TOTP code instead of the password when it is time
+to use it.
+
+=head1 WHAT A TOTP CODE IS AND IS NOT
+
+It is not a key.  Six digits is twenty bits, it changes every thirty seconds,
+and we have to know the secret to check it, so nothing can be encrypted with it
+and stay encrypted.  What it is, is evidence that the person is at the keyboard
+right now, which is exactly what you want to demand before handing a stored
+password to a process.  See Trog::Auth::spend_totp: a code is worth one thing
+rather than everything you can do inside its window.
+
+The key is elsewhere.
+
+=head1 WHERE THE KEY IS
+
+An installation has one master key, and it is not in the database, so the
+database on its own is ciphertext.  It is looked for in this order:
+
+    TPSGI_VAULT_KEY             base64, in the environment
+    $CREDENTIALS_DIRECTORY/tpsgi-vault
+    config/secrets.key          base64, in a file
+
+The first is how a real deployment does it, and the reason it is first is the
+chroot: tPSGI runs the workers chrooted into the installation, and systemd's
+credential store is a ramdisk at /run/credentials which is outside it.  So the
+unit takes the credential, service/tpsgi.sh reads it before the chroot happens
+and puts it in the environment, and the key never touches a disk anywhere.
+
+It is named for tPSGI rather than for tCMS because tPSGI is what owns the unit
+and runs whatever is in the directory, and tCMS is only one of the things that
+can be.  One service, one key.
+
+It is taken out of the environment at load, so nothing we fork afterwards
+inherits it -- which matters, because one of the things we fork is a provisioner
+that we are handing a decrypted password to on its stdin.  Read once, in the
+parent, before there are any workers; the workers inherit the key as a variable
+and an environment without it.
+
+The second is for a service that is not chrooted.
+
+The third is for a tCMS nothing is handing a key to, which is what you get from
+running tPSGI by hand -- the ordinary way to develop against this, since it is
+easier to watch and to restart.  There is no unit and no service/tpsgi.sh in that
+path, so nothing put a key in the environment, and bin/tcms-vault-key --file
+writes one here instead.
+
+It is the weakest of the three and the only one you should not be running in
+production: a file next to the database it protects is a file that goes into the
+same backup.
+
+No key means no vault.  Nothing is stored and nothing is offered, and the parts
+of tCMS which would have used one ask for the password directly, as they did
+before.  That is a feature being off, not a failure.
+
+=head1 WHAT IS ACTUALLY DONE TO A SECRET
+
+AES-256-GCM, under a key derived for that one row:
+
+    salt        32 random bytes, fresh for every write
+    key, iv     HKDF-SHA256(master, salt) -- 44 bytes, split 32 and 12
+    aad         the username and the secret's name
+
+The salt being fresh per write is what makes the derived key and iv fresh per
+write, which is the thing GCM cares about.  The username and name go in as
+associated data rather than being merely stored alongside, so a row cannot be
+lifted into another user's account or renamed into being the answer to a
+different question -- the tag stops checking out.
+
+key_id is a fingerprint of the master key.  It is not needed to decrypt
+anything; it is there so that a row written under a key you no longer have says
+so, rather than presenting as corruption.
+
+=head1 FUNCTIONS
+
+=cut
+
+# 32 raw bytes.  Read at load: see WHERE THE KEY IS -- this is the moment the
+# environment is scrubbed, and it has to be before anything forks.
+our $key_file   = 'config/secrets.key';
+our $credential = 'tpsgi-vault';
+our $key_bytes  = 32;
+my sub decode ( $raw, $whence ) {
+    $raw =~ s/\s+//g;
+    my $key = eval { Crypt::Misc::decode_b64($raw) };
+    if ( !defined $key || length($key) != $key_bytes ) {
+        WARN("The vault key in $whence is not $key_bytes base64 encoded bytes; ignoring it");
+        return undef;
+    }
+    return $key;
+}
+
+our $master = do {
+    my $raw = delete $ENV{TPSGI_VAULT_KEY};
+    $raw ? decode( $raw, 'TPSGI_VAULT_KEY' ) : undef;
+};
+our $looked_further = 0;
+
+# The two places worth looking that are not the environment.  Deferred rather
+# than done at load, since both are files and this module is loaded by things
+# which have no interest in a vault.
+my sub look_further {    ## no critic (ProhibitSingleUseLexicalSubs) -- 21 lines, which would overcomplicate key()
+    $looked_further = 1;
+
+    my $dir = $ENV{CREDENTIALS_DIRECTORY};
+    if ($dir) {
+        my $path = "$dir/$credential";
+        my $raw  = eval { File::Slurper::read_binary($path) };
+        return decode( $raw, $path ) if defined $raw;
+    }
+
+    my $raw = eval { File::Slurper::read_binary($key_file) };
+    return undef unless defined $raw;
+
+    # A key file the group or the world can read is a key file that has already
+    # been read.  Said rather than refused: the alternative is a site that
+    # silently stops being able to open its own secrets.
+    my @stat = stat($key_file);
+    WARN("$key_file is readable by more than its owner; chmod 600 it") if @stat && ( $stat[2] & oct('077') );
+
+    return decode( $raw, $key_file );
+}
+
+=head2 key() = STRING or undef
+
+The master key, or undef when this installation has none.
+
+=head2 has_key() = BOOL
+
+Whether there is a vault at all.  Ask this before offering a user anywhere to
+put a secret, so that a site with no key says so rather than accepting one and
+losing it.
+
+=cut
+
+sub key {
+    $master //= look_further() unless $looked_further;
+    return $master;
+}
+
+sub has_key { return key() ? 1 : 0 }
+
+=head2 key_id() = STRING
+
+A fingerprint of the master key, stored on each row so that a row written under
+a key which is no longer here can say which.
+
+=cut
+
+sub key_id {
+    my $key = key() or return '';
+    return substr( Digest::SHA::sha256_hex($key), 0, 16 );
+}
+
+# Bound into the ciphertext, so that moving a row between users or renaming it
+# breaks the tag rather than working.
+my sub aad ( $user, $name ) { return join( "\0", $user, $name ) }
+
+my sub derive ($salt) {
+    my $material = Crypt::KeyDerivation::hkdf( key(), $salt, 'SHA256', 44, 'tcms/user-secret' );
+    return ( substr( $material, 0, 32 ), substr( $material, 32, 12 ) );
+}
+
+# The same database the users are in, since a secret belongs to one.
+my sub dbh { return Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' ) }
+
+=head2 set($user, $name, $secret) = ($ok, $message)
+
+Remember one thing for one user, replacing whatever was there under that name.
+
+=cut
+
+sub set ( $user, $name, $secret ) {
+    return ( 0, 'this installation has no vault key, so there is nowhere to keep it' ) unless has_key();
+
+    # A name is a label in a form and a key in a table, and it is half of what
+    # binds a row to its owner, so it is a short plain thing or it is nothing.
+    return ( 0, 'a secret needs a name' ) if !$name || length $name > 64 || $name !~ m/^[[:alnum:]][\w.-]*$/;
+    return ( 0, 'nothing to store' )      if ( $secret // q{} ) eq q{};
+
+    my $salt = Crypt::PRNG::random_bytes(32);
+    my ( $key, $iv ) = derive($salt);
+
+    my $gcm = Crypt::AuthEnc::GCM->new( 'AES', $key, $iv );
+    $gcm->adata_add( aad( $user, $name ) );
+    my $ciphertext = $gcm->encrypt_add($secret);
+    my $tag        = $gcm->encrypt_done();
+
+    my $dbh = dbh();
+    eval {
+        $dbh->do(
+            "INSERT OR REPLACE INTO user_secret (username, name, key_id, salt, ciphertext, tag, created) VALUES (?,?,?,?,?,?,?)",
+            undef, $user, $name, key_id(), $salt, $ciphertext, $tag, time()
+        );
+        1;
+    } or do {
+        WARN("Could not store the secret '$name' of $user: $@");
+        return ( 0, 'could not store it' );
+    };
+
+    Trog::Auth::log_event( 'secret_write', $user );
+    return ( 1, "'$name' stored" );
+}
+
+# The plaintext, or undef with a reason in the log.  Never dies: a row that will
+# not open is a thing to report to somebody who can store it again, not an
+# exception halfway through drawing a page.
+my sub _open ( $row, $user, $name ) {
+    if ( $row->{key_id} ne key_id() ) {
+        WARN( "'$name' for $user was sealed under vault key $row->{key_id}, and this installation has " . key_id() );
+        return undef;
+    }
+
+    my ( $key, $iv ) = derive( $row->{salt} );
+    my $gcm = Crypt::AuthEnc::GCM->new( 'AES', $key, $iv );
+    $gcm->adata_add( aad( $user, $name ) );
+    my $secret = $gcm->decrypt_add( $row->{ciphertext} );
+
+    # The tag is the whole point: it says this ciphertext, under this key, for
+    # this user and this name, is the one that was written.
+    if ( !$gcm->decrypt_done( $row->{tag} ) ) {
+        WARN("'$name' for $user did not survive its own tag check; it has been tampered with or the database is damaged");
+        return undef;
+    }
+
+    return $secret;
+}
+
+# What is in one row, or nothing.
+#
+# Every question anybody asks about a stored secret comes through here, get()
+# and has() alike, and they all get the same answer -- which is the point.  A
+# page that says a secret is there and a request that finds it will not open are
+# a way to send somebody round a loop typing codes at a row that was never going
+# to work.  Opening it is the only way to know, and it is microseconds.
+#
+# What get() adds is that reading a secret is an event: it moves last_used and
+# writes to the audit log.  Asking whether one is usable is not an event, and
+# does not.
+my sub stored ( $user, $name ) {
+    return undef unless has_key();
+
+    my $dbh  = dbh();
+    my $rows = $dbh->selectall_arrayref(
+        "SELECT key_id, salt, ciphertext, tag FROM user_secret WHERE username=? AND name=?",
+        { Slice => {} }, $user, $name
+    );
+    return undef unless ref $rows eq 'ARRAY' && @$rows;
+
+    return _open( $rows->[0], $user, $name );
+}
+
+=head2 get($user, $name) = STRING or undef
+
+What was stored, or undef if there is nothing under that name, no key to open it
+with, or a key which is not the one it was sealed under.
+
+Every call is an audit_log row.  Reading a stored password is the interesting
+event here, not writing one.
+
+=cut
+
+sub get ( $user, $name ) {
+    my $secret = stored( $user, $name );
+    return undef unless defined $secret;
+
+    my $dbh = dbh();
+    $dbh->do( "UPDATE user_secret SET last_used=? WHERE username=? AND name=?", undef, time(), $user, $name );
+    Trog::Auth::log_event( 'secret_read', $user );
+    return $secret;
+}
+
+=head2 list($user) = ARRAYREF
+
+What this user has stored, as names and dates.  Never values -- there is no
+route, page or log line anywhere that shows one back to them, because a secret
+you can read off a screen is one you did not need us to keep.
+
+=cut
+
+sub list ($user) {
+    my $dbh  = dbh();
+    my $rows = $dbh->selectall_arrayref(
+        "SELECT name, created, last_used, key_id, salt, ciphertext, tag FROM user_secret WHERE username=? ORDER BY name",
+        { Slice => {} }, $user
+    );
+    return [] unless ref $rows eq 'ARRAY';
+
+    # Opened rather than guessed at from the key fingerprint, so that a row this
+    # page calls readable is one that will actually open when something asks for
+    # it.  This is the page somebody comes to when a secret has stopped working,
+    # and it is no use to them if it agrees that everything looks fine.
+    foreach my $row (@$rows) {
+        $row->{readable} = ( has_key() && defined _open( $row, $user, $row->{name} ) ) ? 1 : 0;
+        delete $row->{$_} foreach qw{salt ciphertext tag};
+    }
+    return $rows;
+}
+
+=head2 has($user, $name) = BOOL
+
+Whether there is something stored under that name that this installation can
+actually open.
+
+Not "is there a row": a row sealed under a key that is gone is a row that will
+never open again, and answering yes to this would have somebody typing codes at
+it.  The question this is really being asked is whether to draw a passphrase box
+or a code box, and the honest answer to that is the one where the code works.
+
+Separate from get() because reading a secret is an event and asking about one is
+not.  This moves nothing and writes nothing to the audit log.
+
+=cut
+
+sub has ( $user, $name ) { return defined stored( $user, $name ) ? 1 : 0 }
+
+=head2 forget($user, $name) = BOOL
+
+=cut
+
+sub forget ( $user, $name ) {
+    my $dbh = dbh();
+    my $res = $dbh->do( "DELETE FROM user_secret WHERE username=? AND name=?", undef, $user, $name );
+    Trog::Auth::log_event( 'secret_delete', $user ) if $res && $res != 0;
+    return $res && $res != 0 ? 1 : 0;
+}
+
+1;

lib/Trog/Zone.pm

@@ -1,152 +0,0 @@
-package Trog::Zone;
-
-=head1 Trog::Zone
-
-=head2 DESCRIPTION
-
-Zonefile CRUD
-
-=cut
-
-use strict;
-use warnings;
-
-use feature qw{signatures};
-no warnings qw{experimental};
-
-use Trog::Config;
-use Trog::Data;
-use Trog::Vars;
-use Trog::SQLite;
-
-use Net::IP;
-use Ref::Util;
-
-=head2 zone($domain) = @zonedata
-
-Returns the zone data for the requested zone.
-Like any other post in TCMS it's versioned.
-
-=cut
-
-sub zone ( $domain, $version = undef ) {
-    my $conf = Trog::Config::get();
-    my $data = Trog::Data->new($conf);
-
-    my @zonedata = $data->get( tags => ['zone'], acls => [qw{admin}], title => $domain );
-    @zonedata = grep { $_->{version} == $version } @zonedata if defined $version;
-    return @zonedata;
-}
-
-=head2 addzone($domain, %options)
-
-Add a post of 'zone' type.
-
-=cut
-
-my $valid_ip = sub {
-    return Net::IP->new(shift);
-};
-
-my $valid_rev_ip = sub {
-    return shift =~ m/\.in-addr\.arpa\.$/;
-};
-
-my $valid_rev_ip6 = sub {
-    return shift =~ m/\.ip6\.arpa\.$/;
-};
-
-my $spec = {
-    ip             => $valid_ip,
-    ip6            => $valid_ip,
-    ip_reversed    => $valid_rev_ip,
-    ip6_reversed   => $valid_rev_ip6,
-    nameservers    => \&Ref::Util::is_arrayref,
-    subdomains     => \&Ref::Util::is_arrayref,
-    cnames         => \&Ref::Util::is_arrayref,
-    gsv_string     => $Trog::Vars::not_ref,
-    dkim_pkey      => $Trog::Vars::not_ref,
-    acme_challenge => $Trog::Vars::not_ref,
-};
-
-sub addzone ($query) {
-    my $domain = $query->{title};
-    return unless $domain;
-    my ($latest) = zone($domain);
-    $latest //= {};
-
-    my $conf = Trog::Config::get();
-    my $data = Trog::Data->new($conf);
-
-    #XXX TODO make this instead use @records2add, complexity demon BAD
-    my $processor = Text::Xslate->new( path => 'www/templates/text' );
-    $query->{data} = $processor->render( 'zone.tx', $query );
-
-    %$latest = (
-        %$latest,
-        Trog::Vars::filter( $query, $spec ),
-    );
-
-    $data->add($latest);
-
-    #import into pdns
-    my ( $ttl, $prio, $disabled ) = ( 300, 0, 0 );
-
-    my $insert_sql  = q{insert into records (domain_id, name, type,content,ttl,prio,disabled) select id , ?, ?, ?, ?, ?, ? from domains where name=?};
-    my @records2add = (
-        [ $query->{title},                    'SOA',  "$query->{title} soa.$query->{title} $query->{version} 10800 3600 604800 10800" ],
-        [ $query->{title},                    'A',    $query->{ip} ],
-        [ $query->{title},                    'AAAA', $query->{ip6} ],
-        [ $query->{ip_reversed},              'PTR',  $query->{title} ],
-        [ $query->{ip6_reversed},             'PTR',  $query->{title} ],
-        [ $query->{title},                    'MX',   "mail.$query->{title}" ],
-        [ "_smtps._tcp.mail.$query->{title}", 'SRV',  "5 587 ." ],
-        [ "_imaps._tcp.mail.$query->{title}", 'SRV',  "5 993 ." ],
-        [ "_pop3s._tcp.mail.$query->{title}", 'SRV',  "5 995 ." ],
-        [ "_dmarc.$query->{title}",           'TXT',  "v=DMARC1; p=reject; rua=mailto:postmaster\@$query->{title}; ruf=mailto:postmaster\@$query->{title}" ],
-        [ "mail._domainkey.$query->{title}",  'TXT',  "v=DKIM1; h=sha256; k=rsa; t=y; p=$query->{dkim_pkey}" ],
-        [ $query->{title},                    'TXT',  "v=spf1 +mx +a +ip4:$query->{ip} +ip6:$query->{ip6} -all" ],
-        [ $query->{title},                    'TXT',  "google-site-verification=$query->{gsv_string}" ],
-        [ "_acme-challenge.$query->{title}",  'TXT',  $query->{acme_challenge} ],
-        [ $query->{title},                    'CAA',  '0 issue "letsencrypt.org"' ],
-    );
-
-    push( @records2add, ( map { [ "$_.$query->{title}", "CNAME", $query->{title} ] } @{ $query->{cnames} } ) );
-    push( @records2add, ( map { [ $query->{title}, 'NS', $_ ] } @{ $query->{nameservers} } ) );
-    foreach my $subdomain ( @{ $query->{subdomains} } ) {
-        push( @records2add, [ "$subdomain->{name}.$query->{title}", 'A',    $subdomain->{ip} ] );
-        push( @records2add, [ "$subdomain->{name}.$query->{title}", 'AAAA', $subdomain->{ip6} ] );
-        push( @records2add, ( map { [ "$subdomain->{name}.$query->{title}", 'NS', $_ ] } @{ $subdomain->{nameservers} } ) );
-    }
-
-    my $dbh = _dbh();
-    $dbh->begin_work();
-    $dbh->do("DELETE FROM records") or _roll_and_die($dbh);
-    foreach my $record (@records2add) {
-        $dbh->do( $insert_sql, undef, @$record, $ttl, $prio, $disabled, $query->{title} ) or _roll_and_die($dbh);
-    }
-    $dbh->commit() or _roll_and_die($dbh);
-
-    return $latest;
-}
-
-sub delzone ($domain) {
-    my $conf = Trog::Config::get();
-    my $data = Trog::Data->new($conf);
-
-    my ($latest) = zone($domain);
-    return unless $latest;
-    return $data->delete($latest);
-}
-
-sub _dbh {
-    return Trog::SQLite::dbh( undef, "dns/zones.db" );
-}
-
-sub _roll_and_die ($dbh) {
-    my $err = $dbh->errstr;
-    $dbh->rollback();
-    die $err;
-}
-
-1;

lib/tCMS/Manual.pod

@@ -75,4 +75,16 @@ Within that we have a components subdirectory for UI components intended to be i
 The idea is that these are not dynamic, but can be statically compiled to strings for faster template builds.
 Things like emoji pickers, modals and other stuff you might populate later with an XHR are good candidates for being a component.
 Each component will have it's own module encapsulating it in the Trog::Component namespace.
-They must have a render() method which returns a string processed by Trog::Renderer->render().
+They must have a render(%args) method which returns a string processed by Trog::Renderer->render().
+On failure they die rather than returning a PSGI triplet, as there is nowhere to put one halfway through a page.
+
+Templates pull them in by name with the component() function, which Trog::Renderer::Base injects into the template processor alongside render_it():
+
+    <: component('EmojiPicker') :>
+    <: component('Gallery', { album => $post.id, cols => 3 }) :>
+
+The optional hash is flattened into the component's render(), and the output comes back marked raw.
+Only the name is accepted, one flat level under Trog::Component, so a template cannot name its way out of that namespace.
+
+The page furniture works this way: index.tx asks for its own Header, Footer, HtmlTitle, MidTitle, TopBar, LeftBar, RightBar, FootBar and CategoryBar, and posts.tx asks for the PostHeader and PostFooter a series names in its metadata.
+Each of those modules owns the name of the template it renders, so adding a piece of furniture no longer means editing a route.

mail/mongle_dkim_config

@@ -1,99 +0,0 @@
-#!/usr/bin/env perl
-
-use strict;
-use warnings;
-
-no warnings qw{experimental};
-use feature qw{signatures};
-
-use List::Util qw{uniq};
-use Config::Simple;
-use File::Copy;
-use File::Touch;
-use DNS::Unbound;
-use Net::DNS::Packet;
-
-my @domains2add = @ARGV;
-
-my $dkim_config_file   = "/etc/opendkim.conf";
-my $trusted_hosts_file = '/etc/opendkim/TrustedHosts';
-my $keytable_file      = '/etc/opendkim/KeyTable';
-my $signing_table_file = '/etc/opendkim/SigningTable';
-
-DKIM_CONFIG: {
-    my $cfg = Config::Simple->new($dkim_config_file);
-    die "Can't open opendkim config file" unless $cfg;
-
-    $cfg->param('KeyTable',           $keytable_file );
-    $cfg->param('SigningTable',       $signing_table_file);
-    $cfg->param('ExternalIgnoreList', $trusted_hosts_file);
-    $cfg->param('InternalHosts',      $trusted_hosts_file);
-
-    # This way we support signing more than one domain
-    $cfg->delete('Domain');
-    $cfg->delete('KeyFile');
-    $cfg->delete('Selector');
-
-    File::Copy::copy($dkim_config_file, "$dkim_config_file.bak") or die "Could not back up old dkim config";
-    $cfg->save();
-
-    print "OpenDKIM config file ($dkim_config_file) changed.\n";
-}
-
-TRUSTED_HOSTS: {
-    my @hosts = read_lines( $trusted_hosts_file );
-
-    my @ips2add = grep { defined $_ } map {
-        ( domain2ips( $_, "A" ),
-        domain2ips( $_, "AAAA" ) )
-    } @domains2add;
-
-    push(@hosts, "127.0.0.1", "localhost", "::1", @domains2add, @ips2add);
-    @hosts = uniq @hosts;
-
-    backup_and_emit( $trusted_hosts_file, @hosts);
-}
-
-KEY_TABLE: {
-    my @lines = read_lines( $keytable_file );
-
-    push(@lines, (map { "mail._domainkey.$_ $_:mail:/etc/opendkim/keys/$_/mail.private" } @domains2add ) );
-    @lines = uniq @lines;
-
-    backup_and_emit($keytable_file, @lines);
-}
-
-SIGNING_TABLE: {
-    my @lines = read_lines( $signing_table_file );
-
-    push(@lines, (map { "$_ mail._domainkey.$_" } @domains2add ) );
-    @lines = uniq @lines;
-
-    backup_and_emit($signing_table_file, @lines);
-}
-
-sub read_lines( $file ) {
-    File::Touch::touch($file);
-    open(my $fh, '<', $file);
-    my @lines = map { chomp $_; $_ } readline $fh;
-    close $fh;
-    return @lines;
-}
-
-sub backup_and_emit($file, @lines) {
-    File::Copy::copy($file, "$file.bak") or die "Could not back up $file";
-    open(my $wh, '>', $file);
-    foreach my $line (@lines) {
-        print $wh "$line\n";
-    }
-    close $wh;
-    print "$file changed.\n";
-}
-
-sub domain2ips( $domain, $type ) {
-    my $resolver = DNS::Unbound->new();
-
-    my $p = $resolver->resolve( $domain, $type )->answer_packet();
-    my @rrs = Net::DNS::Packet->new( \$p )->answer;
-    return map { $_->address } @rrs;
-}

mail/mongle_dmarc_config

@@ -1,30 +0,0 @@
-#!/usr/bin/env perl
-
-use strict;
-use warnings;
-
-use List::Util qw{uniq};
-use Config::Simple;
-use File::Copy;
-
-my @domains2add = @ARGV;
-
-my $dmarc_config_file = "/etc/opendmarc.conf";
-
-my $cfg = Config::Simple->new($dmarc_config_file);
-die "Can't open opendmarc config file" unless $cfg;
-
-$cfg->param('IgnoreAuthenticatedClients', 'true');
-$cfg->param('RequiredHeaders',            'true');
-$cfg->param('SPFSelfValidate',            'true');
-
-my @authserv = $cfg->param('TrustedAuthservIDs');
-push(@authserv, @domains2add);
-@authserv = uniq @authserv;
-
-$cfg->param('TrustedAuthservIDs', \@authserv);
-
-File::Copy::copy($dmarc_config_file, "$dmarc_config_file.bak") or die "Could not back up old dmarc config";
-$cfg->save();
-
-print "OpenDMARC config file ($dmarc_config_file) changed.\n";