HTML.pm 78 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268
  1. package Trog::Routes::HTML;
  2. use strict;
  3. use warnings;
  4. no warnings qw{experimental once};
  5. use feature qw{signatures state};
  6. use POSIX qw{strftime};
  7. use Errno qw{ENOENT};
  8. use File::Touch();
  9. use File::Basename qw{basename};
  10. use List::Util();
  11. use List::MoreUtils();
  12. use Ref::Util();
  13. use Capture::Tiny qw{capture};
  14. use HTML::SocialMeta;
  15. use Clone qw{clone};
  16. use Encode qw{encode_utf8};
  17. use Digest::MD5 qw{md5_hex};
  18. use Digest::SHA qw{sha256_hex};
  19. use JSON::MaybeXS();
  20. use IO::Compress::Gzip;
  21. use Path::Tiny();
  22. use File::Basename qw{dirname};
  23. use URI();
  24. use URI::Escape();
  25. use FindBin::libs;
  26. use Trog::Log qw{:all};
  27. use Trog::Utils;
  28. use Trog::Config;
  29. use Trog::Auth;
  30. use Trog::Data;
  31. use Trog::FileHandler;
  32. use Trog::Themes;
  33. use Trog::Renderer;
  34. use Trog::Email;
  35. use Trog::Component::EmojiPicker;
  36. our $landing_page = 'default.tx';
  37. our $htmltitle = 'title.tx';
  38. our $midtitle = 'midtitle.tx';
  39. our $rightbar = 'rightbar.tx';
  40. our $leftbar = 'leftbar.tx';
  41. our $topbar = 'topbar.tx';
  42. our $footbar = 'footbar.tx';
  43. our $categorybar = 'categories.tx';
  44. # Note to maintainers: never ever remove backends from this list.
  45. # the auth => 1 is a crucial protection.
  46. our %routes = (
  47. default => {
  48. callback => \&Trog::Routes::HTML::setup,
  49. nomap => 1,
  50. },
  51. '/index' => {
  52. method => 'GET',
  53. callback => \&Trog::Routes::HTML::index,
  54. },
  55. # This should only be enabled to debug
  56. # '/setup' => {
  57. # method => 'GET',
  58. # callback => \&Trog::Routes::HTML::setup,
  59. # },
  60. '/login' => {
  61. method => 'GET',
  62. callback => \&Trog::Routes::HTML::login,
  63. noindex => 1,
  64. },
  65. '/logout' => {
  66. method => 'GET',
  67. callback => \&Trog::Routes::HTML::logout,
  68. noindex => 1,
  69. nocache => 1,
  70. },
  71. '/auth' => {
  72. method => 'POST',
  73. callback => \&Trog::Routes::HTML::login,
  74. nocache => 1,
  75. noindex => 1,
  76. },
  77. '/totp' => {
  78. method => 'GET',
  79. auth => 1,
  80. callback => \&Trog::Routes::HTML::totp,
  81. },
  82. '/post/save' => {
  83. method => 'POST',
  84. auth => 1,
  85. callback => \&Trog::Routes::HTML::post_save,
  86. },
  87. '/post/delete' => {
  88. method => 'POST',
  89. auth => 1,
  90. callback => \&Trog::Routes::HTML::post_delete,
  91. },
  92. '/config/save' => {
  93. method => 'POST',
  94. auth => 1,
  95. callback => \&Trog::Routes::HTML::config_save,
  96. },
  97. '/themeclone' => {
  98. method => 'POST',
  99. auth => 1,
  100. callback => \&Trog::Routes::HTML::themeclone,
  101. },
  102. '/profile' => {
  103. method => 'POST',
  104. auth => 1,
  105. callback => \&Trog::Routes::HTML::profile,
  106. },
  107. '/manual' => {
  108. method => 'GET',
  109. auth => 1,
  110. callback => \&Trog::Routes::HTML::manual,
  111. },
  112. '/lib/(.*)' => {
  113. method => 'GET',
  114. auth => 1,
  115. captures => ['module'],
  116. callback => \&Trog::Routes::HTML::manual,
  117. },
  118. '/password_reset' => {
  119. method => 'GET',
  120. callback => \&Trog::Routes::HTML::resetpass,
  121. noindex => 1,
  122. },
  123. # When we are logged in, we get a diff ver of the page.
  124. '/secure/password_reset' => {
  125. method => 'GET',
  126. callback => \&Trog::Routes::HTML::resetpass,
  127. auth => 1,
  128. },
  129. '/request_password_reset' => {
  130. method => 'POST',
  131. callback => \&Trog::Routes::HTML::do_resetpass,
  132. noindex => 1,
  133. nocache => 1,
  134. },
  135. '/request_totp_clear' => {
  136. method => 'POST',
  137. callback => \&Trog::Routes::HTML::do_totp_clear,
  138. noindex => 1,
  139. nocache => 1,
  140. },
  141. '/processed' => {
  142. method => 'GET',
  143. callback => \&Trog::Routes::HTML::processed,
  144. noindex => 1,
  145. },
  146. '/metrics' => {
  147. method => 'GET',
  148. auth => 1,
  149. callback => \&Trog::Routes::HTML::metrics,
  150. },
  151. '/admin/sessions' => {
  152. method => 'GET',
  153. auth => 1,
  154. callback => \&Trog::Routes::HTML::sessions,
  155. noindex => 1,
  156. nocache => 1,
  157. },
  158. '/admin/wyzzerdd' => {
  159. method => 'GET',
  160. auth => 1,
  161. callback => \&Trog::Routes::HTML::post_wizard,
  162. noindex => 1,
  163. nocache => 1,
  164. },
  165. '/admin/wyzzerdd/save' => {
  166. method => 'POST',
  167. auth => 1,
  168. callback => \&Trog::Routes::HTML::post_wizard_save,
  169. noindex => 1,
  170. nocache => 1,
  171. },
  172. #TODO transform into posts?
  173. '/sitemap',
  174. => {
  175. method => 'GET',
  176. callback => \&Trog::Routes::HTML::sitemap,
  177. },
  178. '/sitemap_index.xml',
  179. => {
  180. method => 'GET',
  181. callback => \&Trog::Routes::HTML::sitemap,
  182. data => { xml => 1 },
  183. },
  184. '/sitemap_index.xml.gz',
  185. => {
  186. method => 'GET',
  187. callback => \&Trog::Routes::HTML::sitemap,
  188. data => { xml => 1, compressed => 1 },
  189. },
  190. '/sitemap/static.xml' => {
  191. method => 'GET',
  192. callback => \&Trog::Routes::HTML::sitemap,
  193. data => { xml => 1, map => 'static' },
  194. },
  195. '/sitemap/static.xml.gz' => {
  196. method => 'GET',
  197. callback => \&Trog::Routes::HTML::sitemap,
  198. data => { xml => 1, compressed => 1, map => 'static' },
  199. },
  200. '/sitemap/(.*).xml' => {
  201. method => 'GET',
  202. callback => \&Trog::Routes::HTML::sitemap,
  203. data => { xml => 1 },
  204. captures => ['map'],
  205. },
  206. '/sitemap/(.*).xml.gz' => {
  207. method => 'GET',
  208. callback => \&Trog::Routes::HTML::sitemap,
  209. data => { xml => 1, compressed => 1 },
  210. captures => ['map'],
  211. },
  212. '/humans.txt' => {
  213. method => 'GET',
  214. callback => \&Trog::Routes::HTML::posts,
  215. data => { tag => ['about'] },
  216. },
  217. '/styles/avatars.css' => {
  218. method => 'GET',
  219. callback => \&Trog::Routes::HTML::avatars,
  220. data => { tag => ['about'] },
  221. },
  222. '/avatar/(.*)' => {
  223. method => 'GET',
  224. callback => \&Trog::Routes::HTML::libravatar,
  225. captures => ['avatar_hash'],
  226. noindex => 1,
  227. nocache => 1,
  228. },
  229. '/favicon.ico' => {
  230. method => 'GET',
  231. callback => \&Trog::Routes::HTML::icon,
  232. },
  233. '/totp_qr/(.*)' => {
  234. auth => 1,
  235. method => 'GET',
  236. callback => \&Trog::Routes::HTML::totp_qr,
  237. },
  238. '/styles/rss-style.xsl' => {
  239. method => 'GET',
  240. callback => \&Trog::Routes::HTML::rss_style,
  241. },
  242. );
  243. # Grab theme routes
  244. my $themed = 0;
  245. my $theme_dir = Trog::Themes::get_dir();
  246. if ($theme_dir) {
  247. my $theme_mod = "$theme_dir/routes.pm";
  248. if ( -f $theme_mod ) {
  249. use lib '.';
  250. require $theme_mod;
  251. @routes{ keys(%Theme::routes) } = values(%Theme::routes);
  252. $themed = 1;
  253. }
  254. else {
  255. # Use the special "default" theme
  256. require Theme;
  257. }
  258. }
  259. =head1 PRIMARY ROUTE
  260. =head2 index
  261. Implements the primary route used by all pages not behind auth.
  262. Most subsequent functions simply pass content to this function.
  263. =cut
  264. sub index ( $query, $content = '', $i_styles = [], $i_scripts = [] ) {
  265. $query->{theme_dir} = Trog::Themes::td();
  266. my $to_render = $query->{template} // $landing_page;
  267. $content ||= Trog::Renderer->render( template => $to_render, data => $query, component => 1, contenttype => 'text/html' );
  268. return $content if ref $content eq "ARRAY";
  269. my @styles;
  270. unshift( @styles, qw{embed.css} ) if $query->{embed};
  271. unshift( @styles, qw{screen.css structure.css} );
  272. push( @styles, @$i_styles );
  273. my @p_styles = qw{structure.css print.css};
  274. unshift( @p_styles, qw{embed.css} ) if $query->{embed};
  275. my @series = _get_series(0);
  276. my $title = $query->{primary_post}{title} // $query->{title} // $Theme::default_title // 'tCMS';
  277. # Handle link "unfurling" correctly
  278. my ( $default_tags, $meta_desc, $meta_tags ) = _build_social_meta( $query, $title );
  279. #Do embed content
  280. my $tmpl = $query->{embed} ? 'embed.tx' : 'index.tx';
  281. $query->{theme_dir} =~ s/^\/www\///;
  282. # TO support theming we have to do things like this rather than with an include directive in the templates.
  283. my $htmltitle = Trog::Renderer->render( template => $htmltitle, data => $query, component => 1, contenttype => 'text/html' );
  284. return $htmltitle if ref $htmltitle eq 'ARRAY';
  285. my $midtitle = Trog::Renderer->render( template => $midtitle, data => $query, component => 1, contenttype => 'text/html' );
  286. return $midtitle if ref $midtitle eq 'ARRAY';
  287. my $rightbar = Trog::Renderer->render( template => $rightbar, data => $query, component => 1, contenttype => 'text/html' );
  288. return $rightbar if ref $rightbar eq 'ARRAY';
  289. my $leftbar = Trog::Renderer->render( template => $leftbar, data => $query, component => 1, contenttype => 'text/html' );
  290. return $leftbar if ref $leftbar eq 'ARRAY';
  291. my $topbar = Trog::Renderer->render( template => $topbar, data => $query, component => 1, contenttype => 'text/html' );
  292. return $topbar if ref $topbar eq 'ARRAY';
  293. my $footbar = Trog::Renderer->render( template => $footbar, data => $query, component => 1, contenttype => 'text/html' );
  294. return $footbar if ref $footbar eq 'ARRAY';
  295. my $categorybar = Trog::Renderer->render( template => $categorybar, data => { %$query, categories => \@series }, component => 1, contenttype => 'text/html' );
  296. return $categorybar if ref $categorybar eq 'ARRAY';
  297. # Grab the avatar class for the logged in user
  298. if ( $query->{user} ) {
  299. $query->{user_class} = Trog::Auth::username2classname( $query->{user} );
  300. }
  301. state $data;
  302. $data //= Trog::Data->new(Trog::Config::get());
  303. return finish_render(
  304. $tmpl,
  305. {
  306. %$query,
  307. search_lang => $data->lang(),
  308. search_help => $data->help(),
  309. theme_dir => Trog::Themes::td(),
  310. content => $content,
  311. title => $title,
  312. htmltitle => $htmltitle,
  313. midtitle => $midtitle,
  314. rightbar => $rightbar,
  315. leftbar => $leftbar,
  316. topbar => $topbar,
  317. footbar => $footbar,
  318. categorybar => $categorybar,
  319. categories => \@series,
  320. stylesheets => \@styles,
  321. print_styles => \@p_styles,
  322. scripts => $i_scripts,
  323. show_madeby => $Theme::show_madeby ? 1 : 0,
  324. embed => $query->{embed} ? 1 : 0,
  325. embed_video => $query->{primary_post}{is_video},
  326. default_tags => $default_tags,
  327. meta_desc => $meta_desc,
  328. meta_tags => $meta_tags,
  329. }
  330. );
  331. }
  332. sub _build_social_meta ( $query, $title ) {
  333. return ( undef, undef, undef ) unless $query->{social_meta} && $query->{route} && $query->{domain};
  334. my $default_tags = $Theme::default_tags;
  335. $default_tags .= ',' . join( ',', @{ $query->{primary_post}->{tags} } ) if $default_tags && $query->{primary_post}->{tags};
  336. my $primary_data = ref $query->{primary_post}{data} eq 'ARRAY' ? $query->{primary_post}{data}[0] : $query->{primary_post}{data};
  337. my $meta_desc = $primary_data // $Theme::description // "tCMS Site";
  338. $meta_desc = Trog::Utils::strip_and_trunc($meta_desc) || '';
  339. my $meta_tags = '';
  340. my $card_type = 'summary';
  341. $card_type = 'featured_image' if $query->{primary_post} && $query->{primary_post}{is_image};
  342. $card_type = 'player' if $query->{primary_post} && $query->{primary_post}{is_video};
  343. my $image = $Theme::default_image ? "https://$query->{domain}/" . Trog::Themes::get_dir() . "/$Theme::default_image" : '';
  344. $image = "https://$query->{domain}/$query->{primary_post}{preview}" if $query->{primary_post} && $query->{primary_post}{preview};
  345. $image = "https://$query->{domain}/$query->{primary_post}{href}" if $query->{primary_post} && $query->{primary_post}{is_image};
  346. my $primary_route = "https://$query->{domain}/$query->{route}";
  347. $primary_route =~ s/[\/]+/\//g;
  348. my $display_name = $Theme::display_name || 'Another tCMS Site';
  349. my $extra_tags = '';
  350. my %sopts = (
  351. site => '',
  352. image => '',
  353. fb_app_id => '',
  354. site_name => $display_name,
  355. app_name => $display_name,
  356. title => $title,
  357. description => $meta_desc,
  358. url => $primary_route,
  359. );
  360. $sopts{site} = $Theme::twitter_account if $Theme::twitter_account;
  361. $sopts{image} = $image if $image;
  362. $sopts{fb_app_id} = $Theme::fb_app_id if $Theme::fb_app_id;
  363. if ( $query->{primary_post} && $query->{primary_post}{is_video} ) {
  364. #$sopts{player} = "$primary_route?embed=1";
  365. $sopts{player} = "https://$query->{domain}/$query->{primary_post}{href}";
  366. #XXX don't hardcode this
  367. $sopts{player_width} = 1280;
  368. $sopts{player_height} = 720;
  369. $extra_tags .= "<meta property='og:video:type' content='$query->{primary_post}{content_type}' />\n";
  370. }
  371. my $social = HTML::SocialMeta->new(%sopts);
  372. $meta_tags = eval { $social->create($card_type) };
  373. $meta_tags =~ s/content="video"/content="video:other"/mg if $meta_tags;
  374. $meta_tags .= $extra_tags if $extra_tags;
  375. print STDERR "WARNING: Theme misconfigured, social media tags will not be included\n$@\n" if $theme_dir && !$meta_tags;
  376. return ( $default_tags, $meta_desc, $meta_tags );
  377. }
  378. =head1 NORMAL ROUTES
  379. These are expected to either return a 200, or redirect to something which does.
  380. =head2 setup
  381. One time setup page; should only display to the first user to visit the site which we presume to be the administrator.
  382. =cut
  383. sub setup ($query) {
  384. File::Touch::touch("config/setup");
  385. Trog::Renderer->render(
  386. template => 'notconfigured.tx',
  387. data => {
  388. title => 'tCMS Requires Setup to Continue...',
  389. stylesheets => _build_themed_styles( ['notconfigured.css'] ),
  390. %$query,
  391. },
  392. contenttype => 'text/html',
  393. code => 200,
  394. );
  395. }
  396. =head2 totp
  397. Enable 2 factor auth via TOTP for the currently authenticated user.
  398. Returns a page with a QR code & TOTP uri for pasting into your authenticator app of choice.
  399. =cut
  400. sub totp ($query) {
  401. my $active_user = $query->{user};
  402. my $domain = $query->{domain};
  403. $query->{failure} //= -1;
  404. my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp( $active_user, $domain );
  405. my $now_tm = time;
  406. my $now_string = strftime("%a %b %e T%H:%M:%SZ %Y", gmtime($now_tm));
  407. return Trog::Routes::HTML::index(
  408. {
  409. title => 'Enable TOTP 2-Factor Auth',
  410. theme_dir => Trog::Themes::td(),
  411. uri => $uri,
  412. qr => $qr,
  413. failure => $failure,
  414. message => $message,
  415. template => 'totp.tx',
  416. is_admin => 1,
  417. cur_code => $totp->expected_totp_code($now_tm),
  418. timestamp => $now_string,
  419. %$query,
  420. },
  421. undef,
  422. [qw{post.css}],
  423. );
  424. }
  425. =head2 login
  426. Sets the user cookie if the provided user exists, or sets up the user as an admin with the provided credentials in the event that no users exist.
  427. =cut
  428. sub login ($query) {
  429. # Redirect if we actually have a logged in user.
  430. # Note to future me -- this user value is overwritten explicitly in server.psgi.
  431. # If that ever changes, you will die
  432. $query->{to} //= $query->{route};
  433. $query->{to} = '/config' if List::Util::any { $query->{to} eq $_ } qw{/login /logout};
  434. if ( $query->{user} ) {
  435. DEBUG("Login by $query->{user}, redirecting to $query->{to}");
  436. return $query->{tpsgi}->see_also( $query->{to} );
  437. }
  438. #Check and see if we have no users. If so we will just accept whatever creds are passed.
  439. my $hasusers = -f "config/has_users";
  440. my $btnmsg = $hasusers ? "Log In" : "Register";
  441. my $headers;
  442. my $has_totp = 0;
  443. if ( $query->{username} && $query->{password} ) {
  444. if ( !$hasusers ) {
  445. # Make the first user
  446. Trog::Auth::useradd( $query->{username}, $query->{display_name}, $query->{password}, ['admin'], $query->{contact_email} );
  447. # Add a stub user page and the initial series.
  448. my $dat = Trog::Data->new(Trog::Config::get());
  449. _setup_initial_db( $dat, $query->{username}, $query->{display_name}, $query->{contact_email} );
  450. # Ensure we stop registering new users
  451. File::Touch::touch("config/has_users");
  452. }
  453. $query->{failed} = 1;
  454. my $cookie = Trog::Auth::mksession( $query->{username}, $query->{password}, $query->{token}, $query->{ip} // '' );
  455. if ($cookie) {
  456. # TODO secure / sameSite cookie to kill csrf, maybe do rememberme with Expires=~0
  457. my $secure = '';
  458. $secure = '; Secure' if $query->{scheme} eq 'https';
  459. $headers = {
  460. "Set-Cookie" => "tcmslogin=$cookie; HttpOnly; SameSite=Strict$secure",
  461. };
  462. $query->{failed} = 0;
  463. }
  464. }
  465. $query->{failed} //= -1;
  466. return Trog::Renderer->render(
  467. template => 'login.tx',
  468. data => {
  469. title => 'tCMS 2 ~ Login',
  470. to => $query->{to},
  471. failure => int( $query->{failed} ),
  472. message => int( $query->{failed} ) < 1 ? "Login Successful, Redirecting..." : "Login Failed.",
  473. btnmsg => $btnmsg,
  474. stylesheets => _build_themed_styles( [qw{structure.css screen.css login.css}] ),
  475. theme_dir => Trog::Themes::td(),
  476. has_users => $hasusers,
  477. %$query,
  478. },
  479. headers => $headers,
  480. contenttype => 'text/html',
  481. code => 200,
  482. nocache => $query->{nocache},
  483. );
  484. }
  485. sub _setup_initial_db ( $dat, $user, $display_name, $contact_email ) {
  486. $dat->add(
  487. {
  488. "aclname" => "series",
  489. "acls" => [],
  490. "callback" => "Trog::Routes::HTML::series",
  491. method => 'GET',
  492. "data" => "Series",
  493. "href" => "/series",
  494. "local_href" => "/series",
  495. "preview" => "/img/sys/testpattern.jpg",
  496. "tags" => [qw{series topbar}],
  497. visibility => 'public',
  498. "title" => "Series",
  499. user => $user,
  500. form => 'series.tx',
  501. child_form => 'series.tx',
  502. aliases => [],
  503. },
  504. {
  505. "aclname" => "about",
  506. "acls" => [],
  507. "callback" => "Trog::Routes::HTML::series",
  508. method => 'GET',
  509. "data" => "About",
  510. "href" => "/about",
  511. "local_href" => "/about",
  512. "preview" => "/img/sys/testpattern.jpg",
  513. "tags" => [qw{series topbar public}],
  514. visibility => 'public',
  515. "title" => "About",
  516. user => $user,
  517. form => 'series.tx',
  518. child_form => 'profile.tx',
  519. aliases => [],
  520. },
  521. {
  522. "aclname" => "config",
  523. acls => [],
  524. "callback" => "Trog::Routes::HTML::config",
  525. 'method' => 'GET',
  526. "content_type" => "text/html",
  527. "data" => "Config",
  528. "href" => "/config",
  529. "local_href" => "/config",
  530. "preview" => "/img/sys/testpattern.jpg",
  531. "tags" => [qw{admin}],
  532. visibility => 'private',
  533. "title" => "Configure tCMS",
  534. user => $user,
  535. aliases => [],
  536. },
  537. {
  538. title => $display_name,
  539. data => 'Default user',
  540. preview => '/img/avatar/humm.gif',
  541. wallpaper => '/img/sys/testpattern.jpg',
  542. tags => ['about'],
  543. visibility => 'public',
  544. acls => ['admin'],
  545. local_href => "/users/$display_name",
  546. display_name => $display_name,
  547. contact_email => $contact_email,
  548. callback => "Trog::Routes::HTML::users",
  549. method => 'GET',
  550. user => $user,
  551. form => 'profile.tx',
  552. aliases => [],
  553. },
  554. );
  555. }
  556. =head2 logout
  557. Deletes your users' session and opens the index.
  558. =cut
  559. sub logout ($query) {
  560. Trog::Auth::killsession( $query->{user}, $query->{ip} // '' ) if $query->{user};
  561. delete $query->{user};
  562. return Trog::Routes::HTML::index($query);
  563. }
  564. =head2 config
  565. Renders the configuration page, or redirects you back to the login page.
  566. =cut
  567. sub config ( $query = {} ) {
  568. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  569. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  570. $query->{failure} //= -1;
  571. #XXX ACHTUNG config::simple has this brain damaged behavior of returning a multiple element array when you access something that does not exist.
  572. #XXX straight up dying would be preferrable.
  573. #XXX anyways, this means you can NEVER NEVER NEVER access a param from within a hash directly. YOU HAVE BEEN WARNED!
  574. my $conf = Trog::Config::get();
  575. state $theme = $conf->param('general.theme') // '';
  576. state $dm = $conf->param('general.data_model') // 'DUMMY';
  577. state $embeds = $conf->param('security.allow_embeds_from') // '';
  578. state $hostname = $conf->param('general.hostname') // '';
  579. return Trog::Routes::HTML::index(
  580. {
  581. title => 'Configure tCMS',
  582. theme_dir => Trog::Themes::td(),
  583. stylesheets => [qw{config.css}],
  584. scripts => [qw{post.js}],
  585. themes => _get_themes() || [],
  586. data_models => _get_data_models(),
  587. current_theme => $theme,
  588. current_data_model => $dm,
  589. message => $query->{message},
  590. failure => $query->{failure},
  591. to => '/config',
  592. scheme => $query->{scheme},
  593. embeds => $embeds,
  594. is_admin => 1,
  595. template => 'config.tx',
  596. %$query,
  597. hostname => $hostname,
  598. },
  599. undef,
  600. [qw{config.css}],
  601. );
  602. }
  603. =head2 resetpass
  604. =head2 do_resetpass
  605. =head2 do_totp_clear
  606. Routes for user service of their authentication details.
  607. =cut
  608. sub resetpass ($query) {
  609. $query->{failure} //= -1;
  610. my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
  611. return Trog::Routes::HTML::index(
  612. {
  613. title => 'Request Authentication Resets',
  614. theme_dir => Trog::Themes::td(),
  615. stylesheets => [qw{config.css}],
  616. scripts => [qw{post.js}],
  617. message => $query->{message},
  618. failure => $query->{failure},
  619. scheme => $query->{scheme},
  620. template => 'resetpass.tx',
  621. is_admin => $is_admin,
  622. %$query,
  623. },
  624. undef,
  625. [qw{config.css}],
  626. );
  627. }
  628. sub do_resetpass ($query) {
  629. my $user = $query->{username};
  630. # User Does not exist
  631. return $query->{tpsgi}->forbidden($query) if !Trog::Auth::user_exists($user);
  632. # User exists, but is not logged in this session
  633. return $query->{tpsgi}->forbidden($query) if !$query->{user} && Trog::Auth::user_has_session($user);
  634. my $token = Trog::Utils::uuid();
  635. my $newpass = $query->{password} // Trog::Utils::uuid();
  636. my $res = Trog::Auth::add_change_request( type => 'reset_pass', user => $user, secret => $newpass, token => $token );
  637. die "Could not add auth change request!" unless $res;
  638. # If the user is logged in, just do the deed, otherwise send them the token in an email
  639. if ( $query->{user} ) {
  640. return $query->{tpsgi}->see_also("/api/auth_change_request/$token");
  641. }
  642. Trog::Email::contact(
  643. $user,
  644. "root\@$query->{domain}",
  645. "$query->{domain}: Password reset URL for $user",
  646. { uri => "$query->{scheme}://$query->{domain}/api/auth_change_request/$token", template => 'password_reset.tx' }
  647. );
  648. return $query->{tpsgi}->see_also("/processed");
  649. }
  650. sub do_totp_clear ($query) {
  651. my $user = $query->{username};
  652. # User Does not exist
  653. return $query->{tpsgi}->forbidden($query) if !Trog::Auth::user_exists($user);
  654. # User exists, but is not logged in this session
  655. return $query->{tpsgi}->forbidden($query) if !$query->{user} && Trog::Auth::user_has_session($user);
  656. my $token = Trog::Utils::uuid();
  657. my $res = Trog::Auth::add_change_request( type => 'clear_totp', user => $user, token => $token );
  658. die "Could not add auth change request!" unless $res;
  659. # If the user is logged in, just do the deed, otherwise send them the token in an email
  660. if ( $query->{user} ) {
  661. return $query->{tpsgi}->see_also("/api/auth_change_request/$token");
  662. }
  663. Trog::Email::contact(
  664. $user,
  665. "root\@$query->{domain}",
  666. "$query->{domain}: Password reset URL for $user",
  667. { uri => "$query->{scheme}://$query->{domain}/api/auth_change_request/$token", template => 'totp_reset.tx' }
  668. );
  669. return $query->{tpsgi}->see_also("/processed");
  670. }
  671. sub _get_series ( $edit = 0 ) {
  672. state $data;
  673. $data //= Trog::Data->new(Trog::Config::get());
  674. my @series = $data->get(
  675. acls => [qw{public}],
  676. tags => [qw{topbar}],
  677. limit => 10,
  678. page => 1,
  679. );
  680. @series = map { $_->{local_href} = "/post$_->{local_href}"; $_ } @series if $edit;
  681. return @series;
  682. }
  683. sub _get_themes {
  684. my $dir = 'www/themes';
  685. opendir( my $dh, $dir ) || do { die "Can't opendir $dir: $!" unless $!{ENOENT} };
  686. my @tdirs = grep { !/^\./ && -d "$dir/$_" } readdir($dh);
  687. closedir $dh;
  688. return \@tdirs;
  689. }
  690. sub _get_data_models {
  691. foreach my $incdir (@INC) {
  692. my $dir = "$incdir/Trog/Data";
  693. next unless -d $dir;
  694. opendir( my $dh, $dir ) || die "Can't opendir $dir: $!";
  695. my @dmods = map { s/\.pm$//g; $_ } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);
  696. closedir $dh;
  697. return \@dmods;
  698. }
  699. die "Could not find tCMS data modules! Is tCMS in \@INC?";
  700. }
  701. =head2 config_save
  702. Implements /config/save route. Saves what little configuration we actually use to ~/.tcms/tcms.conf
  703. =cut
  704. sub config_save ($query) {
  705. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  706. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  707. my $conf = Trog::Config::get();
  708. $conf->param( 'general.theme', $query->{theme} ) if defined $query->{theme};
  709. $conf->param( 'general.data_model', $query->{data_model} ) if $query->{data_model};
  710. $conf->param( 'security.allow_embeds_from', $query->{embeds} ) if $query->{embeds};
  711. $conf->param( 'general.hostname', $query->{hostname} ) if $query->{hostname};
  712. $query->{failure} = 1;
  713. $query->{message} = "Failed to save configuration!";
  714. if ( $conf->write($Trog::Config::home_cfg) ) {
  715. $query->{failure} = 0;
  716. $query->{message} = "Configuration updated succesfully.";
  717. }
  718. #We need to reap the children with outdated configuration.
  719. $query->{tpsgi}->signal_restart_parent();
  720. return config($query);
  721. }
  722. =head2 themeclone
  723. Clone a theme by copying a directory.
  724. =cut
  725. sub themeclone ($query) {
  726. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  727. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  728. my ( $theme, $newtheme ) = ( $query->{theme}, $query->{newtheme} );
  729. my $themedir = 'www/themes';
  730. $query->{failure} = 1;
  731. $query->{message} = "Failed to clone theme '$theme' as '$newtheme'!";
  732. require File::Copy::Recursive;
  733. if ( $theme && $newtheme && File::Copy::Recursive::dircopy( "$themedir/$theme", "$themedir/$newtheme" ) ) {
  734. $query->{failure} = 0;
  735. $query->{message} = "Successfully cloned theme '$theme' as '$newtheme'.";
  736. }
  737. return $query->{tpsgi}->see_also('/config');
  738. }
  739. =head2 post_save
  740. Saves posts submitted via the /post pages
  741. =cut
  742. sub post_save ($qq) {
  743. return $qq->{tpsgi}->see_also('/login') unless $qq->{user};
  744. return $qq->{tpsgi}->forbidden($qq) unless grep { $_ eq 'admin' } @{ $qq->{user_acls} };
  745. my $query = clone($qq);
  746. my $to = delete $query->{to};
  747. #Copy this down since it will be deleted later
  748. my $acls = $query->{acls};
  749. $query->{tags} = Trog::Utils::coerce_array( $query->{tags} );
  750. # Support data with multiple pages like presentations
  751. $query->{data} = Trog::Utils::coerce_array( $query->{data} ) if $query->{data_is_array};
  752. $query->{attachments} = Trog::Utils::coerce_array( $query->{attachments} );
  753. # Filter bits and bobs XXX this is done deeper in, may require removal
  754. delete $query->{primary_post};
  755. delete $query->{social_meta};
  756. delete $query->{deflate};
  757. delete $query->{acls};
  758. # Ensure there are no null tags
  759. @{ $query->{tags} } = grep { defined $_ } @{ $query->{tags} };
  760. # Posts will always be GET
  761. $query->{method} = 'GET';
  762. state $data;
  763. $data //= Trog::Data->new(Trog::Config::get());
  764. # A post that doesn't match its type's schema is the user's mistake, not a
  765. # server error, so hand the validation errors back rather than dying.
  766. local $@;
  767. eval { $data->add($query); 1 } or do {
  768. my @errors = Ref::Util::is_arrayref($@) ? @{$@} : ($@);
  769. my $why = "Post failed validation:\n" . join( "\n", @errors );
  770. WARN("Rejected post from $qq->{user}: $why");
  771. return $qq->{tpsgi}->badrequest( $qq, $why );
  772. };
  773. # Instruct tpsgi to invalidate the cached render.
  774. $qq->{tpsgi}->add_post_close_callback(sub {
  775. # XXX there is not a great way to find what needs to be re-rendered because posts can include other posts.
  776. # As such we just have to nuke all the .html renders.
  777. $qq->{tpsgi}->invalidate_renders('html');
  778. });
  779. # Force a reload of the routing table
  780. $qq->{tpsgi}->signal_restart_parent();
  781. return $qq->{tpsgi}->see_also('/secure'.$to);
  782. }
  783. =head2 profile
  784. Saves / updates new users.
  785. =cut
  786. sub profile ($query) {
  787. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  788. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  789. # Find the user's post and edit it
  790. state $data;
  791. $data //= Trog::Data->new(Trog::Config::get());
  792. my @userposts = $data->get( tags => ['about'], acls => [qw{admin}] );
  793. # Users are always self-authored, you see
  794. my $user_obj = List::Util::first { ( $_->{user} || '' ) eq $query->{username} } @userposts;
  795. my $username = $query->{username};
  796. my $password = $query->{password};
  797. my $changed = $username ne ( $user_obj->{user} // '' )
  798. || $password
  799. || ( $query->{contact_email} // '' ) ne ( $user_obj->{contact_email} // '' )
  800. || ( $query->{display_name} // '' ) ne ( $user_obj->{display_name} // '' );
  801. #Make sure it is "self-authored", redact pw
  802. $query->{user} = delete $query->{username};
  803. delete $query->{password};
  804. # Use the display name as the title
  805. $query->{title} = $query->{display_name};
  806. my %merged = (
  807. %$user_obj,
  808. %$query,
  809. $query->{display_name} ? ( local_href => "/users/$query->{display_name}" ) : ( local_href => $user_obj->{local_href} ),
  810. );
  811. # Validate before touching the auth database, not after. useradd() does an
  812. # INSERT OR REPLACE on the user row, which cascades to the session table and
  813. # logs the user straight out -- doing that and *then* rejecting the post
  814. # leaves the credentials disagreeing with the profile post they came from.
  815. my @errors = Trog::DataModule::validate( clone( \%merged ) );
  816. if (@errors) {
  817. my $why = "Post failed validation:\n" . join( "\n", @errors );
  818. WARN("Rejected profile update from $query->{user}: $why");
  819. return $query->{tpsgi}->badrequest( $query, $why );
  820. }
  821. if ($changed) {
  822. my $for_user = Trog::Auth::acls4user($username);
  823. #TODO support non-admin users
  824. my @acls = @$for_user ? @$for_user : qw{admin};
  825. Trog::Auth::useradd( $username, $merged{display_name}, $password, \@acls, $merged{contact_email} );
  826. }
  827. return post_save( \%merged );
  828. }
  829. =head2 post_delete
  830. deletes posts.
  831. =cut
  832. sub post_delete ($query) {
  833. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  834. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  835. state $data;
  836. $data //= Trog::Data->new(Trog::Config::get());
  837. $data->delete($query) and die "Could not delete post";
  838. return $query->{tpsgi}->see_also( $query->{to} );
  839. }
  840. my %enrich = (
  841. 'invoice.tx' => sub {
  842. my ($post,$query) = @_;
  843. # TODO it's probably a performance problem doing this per post rather than only for the series entry
  844. my %ret = ( entities => [ _post_helper({ form => 'entities.tx', visibility => 'public' }, [], $query->{user_acls}) ] );
  845. return %ret unless ref $post->{data} eq 'ARRAY';
  846. # Figure out the payee/payor
  847. $ret{payee_entity} = List::Util::first { $_->{id} eq $post->{payee} } @{$ret{entities}};
  848. $ret{payor_entity} = List::Util::first { $_->{id} eq $post->{payor} } @{$ret{entities}};
  849. # Build total
  850. my $denom;
  851. my @prices = map {
  852. my $price = 0;
  853. ($denom, $price) = m/^Price:\s*(\D)(\d+)/mix;
  854. $price;
  855. } @{$post->{data}};
  856. $denom //= '$';
  857. $ret{total} = $denom.(List::Util::sum(@prices) // 0);
  858. return %ret;
  859. },
  860. );
  861. =head2 series
  862. Series specific view, much like the users/ route
  863. Displays identified series, not all series.
  864. =cut
  865. sub series ($query) {
  866. my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
  867. # rip away /secure if present
  868. $query->{route} =~ s|^/secure||;
  869. #we are either viewed one of two ways, /post/$id or /$aclname
  870. my ( undef, $aclname, $id ) = split( /\//, $query->{route} );
  871. $query->{aclname} = $aclname if !$id;
  872. $query->{id} = $id if $id;
  873. # Don't show topbar series on the series page. That said, don't exclude it from direct series view.
  874. $query->{exclude_tags} = ['topbar'] if !$is_admin && $aclname && $aclname eq 'series';
  875. #XXX I'd prefer to overload id to actually *be* the aclname...
  876. # but this way, accomodates things like the flat file time-indexing hack.
  877. # TODO I should probably have it for all posts, and make *everything* a series.
  878. # WE can then do threaded comments/posts.
  879. # That will essentially necessitate it *becoming* the ID for real.
  880. #Grab the relevant tag (aclname), then pass that to posts
  881. my @posts = _post_helper( $query, ['series'], $query->{user_acls} );
  882. # Enrich posts with additional data based on the template if necessary
  883. if (exists $enrich{$posts[0]->{child_form}}) {
  884. my $callback = $enrich{$posts[0]->{child_form}};
  885. my %extra_data = $callback->($posts[0], $query);
  886. foreach my $key (keys(%extra_data)) {
  887. $posts[0]->{$key} = $extra_data{$key};
  888. }
  889. }
  890. delete $query->{id};
  891. delete $query->{aclname};
  892. $query->{subhead} = $posts[0]->{data};
  893. $query->{title} = $posts[0]->{title};
  894. $query->{tag} = $posts[0]->{aclname};
  895. $query->{primary_post} = $posts[0];
  896. $query->{in_series} = 1;
  897. return posts($query);
  898. }
  899. =head2 avatars
  900. Returns the avatars.css.
  901. =cut
  902. sub avatars ($query) {
  903. push( @{ $query->{user_acls} }, 'public' );
  904. my $tags = Trog::Utils::coerce_array( $query->{tag} );
  905. my @posts = _post_helper( $query, $tags, $query->{user_acls} );
  906. if (@posts) {
  907. # Set the eTag so that we don't get a re-fetch
  908. $query->{etag} = "$posts[0]{id}-$posts[0]{version}";
  909. }
  910. @posts = map { $_->{id} =~ tr/-/_/; $_->{id} = "a_$_->{id}"; $_ } @posts;
  911. return Trog::Renderer->render(
  912. template => 'avatars.tx',
  913. data => {
  914. users => \@posts,
  915. %$query,
  916. },
  917. code => 200,
  918. contenttype => 'text/css',
  919. );
  920. }
  921. =head2 libravatar
  922. Implements the libravatar protocol (https://wiki.libravatar.org/running_your_own/).
  923. Accepts GET /avatar/{hash} where {hash} is the MD5 or SHA-256 of the user's
  924. lowercased email address, and redirects to their profile avatar image.
  925. Returns 404 when no matching user is found or the user has no avatar.
  926. =cut
  927. sub libravatar ($query) {
  928. my $hash = lc( $query->{avatar_hash} // '' );
  929. my $users = Trog::Auth::users_with_emails();
  930. my $matched_user;
  931. for my $u (@$users) {
  932. next unless $u->{contact_email};
  933. my $email = lc( $u->{contact_email} );
  934. if ( $hash eq sha256_hex($email) || $hash eq md5_hex($email) ) {
  935. $matched_user = $u->{name};
  936. last;
  937. }
  938. }
  939. return $query->{tpsgi}->notfound($query) unless $matched_user;
  940. my @posts = _post_helper( { author => $matched_user }, ['about'], [qw{public admin}] );
  941. my $preview = @posts ? $posts[0]->{preview} : '';
  942. return $query->{tpsgi}->notfound($query) unless $preview;
  943. return $query->{tpsgi}->redirect_permanent("/$preview");
  944. }
  945. =head2 users
  946. Implements direct user profile view.
  947. =cut
  948. sub users ($query) {
  949. # rip away /secure if present
  950. $query->{route} =~ s|^/secure||;
  951. # Capture the username
  952. my ( undef, undef, $display_name ) = split( /\//, $query->{route} );
  953. $display_name = URI::Escape::uri_unescape($display_name);
  954. my $username = Trog::Auth::display2username($display_name);
  955. return $query->{tpsgi}->notfound($query) unless $username;
  956. $query->{username} //= $username;
  957. push( @{ $query->{user_acls} }, 'public' );
  958. $query->{exclude_tags} = ['about'];
  959. # Don't show topbar series on the series page. That said, don't exclude it from direct series view.
  960. my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
  961. push( @{ $query->{exclude_tags} }, 'topbar' ) if !$is_admin;
  962. my @posts = _post_helper( { author => $query->{username} }, ['about'], $query->{user_acls} );
  963. $query->{id} = $posts[0]->{id};
  964. $query->{title} = $posts[0]->{display_name};
  965. $posts[0]->{title} = $posts[0]->{display_name};
  966. $query->{user_obj} = $posts[0];
  967. $query->{primary_post} = $posts[0];
  968. $query->{in_series} = 1;
  969. return posts($query);
  970. }
  971. =head2 posts
  972. Display multi or single posts, supports RSS and pagination.
  973. =cut
  974. sub posts ( $query, $direct = 0 ) {
  975. # Allow rss.xml to tell what posts to loop over
  976. my $fmt = $query->{format} || '';
  977. #Process the input URI to capture tag/id
  978. $query->{route} //= $query->{to};
  979. # rip away /secure if present
  980. $query->{route} =~ s|^/secure||;
  981. my ( undef, undef, $id ) = split( /\//, $query->{route} );
  982. my $tags = Trog::Utils::coerce_array( $query->{tag} );
  983. $query->{id} = $id if $id && !$query->{in_series};
  984. my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
  985. push( @{ $query->{user_acls} }, 'public' );
  986. push( @{ $query->{user_acls} }, 'unlisted' ) if $query->{id};
  987. push( @{ $query->{user_acls} }, 'private' ) if $is_admin;
  988. my @posts;
  989. # Discover this user's visibility, so we can make them post in this category by default
  990. my $user_visibility = 'public';
  991. if ( $query->{user_obj} ) {
  992. #Optimize the /users/* route
  993. @posts = ( $query->{user_obj} );
  994. $user_visibility = $query->{user_obj}->{visibility};
  995. }
  996. else {
  997. if ( $query->{user} ) {
  998. my @me = _post_helper( { author => $query->{user} }, ['about'], $query->{user_acls} );
  999. $user_visibility = $me[0]->{visibility};
  1000. }
  1001. @posts = _post_helper( $query, $tags, $query->{user_acls} );
  1002. }
  1003. if ( $query->{id} ) {
  1004. $query->{primary_post} = $posts[0] if @posts;
  1005. }
  1006. #OK, so if we have a user as the ID we found, go grab the rest of their posts
  1007. if ( $query->{id} && @posts && List::Util::any { $_ eq 'about' } @{ $posts[0]->{tags} } ) {
  1008. my $user = shift(@posts);
  1009. my $id = delete $query->{id};
  1010. $query->{author} = $user->{user};
  1011. @posts = _post_helper( $query, $tags, $query->{user_acls} );
  1012. @posts = grep { $_->{id} ne $id } @posts;
  1013. unshift @posts, $user;
  1014. }
  1015. if ( !$is_admin ) {
  1016. return $query->{tpsgi}->notfound($query) unless @posts;
  1017. }
  1018. # Set the eTag so that we don't get a re-fetch
  1019. $query->{etag} = "$posts[0]{id}-$posts[0]{version}" if @posts;
  1020. #Correct page headers
  1021. my $ph = $themed ? _themed_title( $query->{route} ) : $query->{route};
  1022. return _rss( $query, $ph, \@posts ) if $fmt eq 'rss';
  1023. #XXX Is used by the sitemap, maybe just fix there?
  1024. my @post_aliases = map { $_->{local_href} } _get_series();
  1025. # Allow themes to put in custom headers/footers on posts
  1026. my ( $header, $footer );
  1027. $header = Trog::Renderer->render(
  1028. template => 'headers/' . $query->{primary_post}{header},
  1029. data => { theme_dir => Trog::Themes::td(), %$query },
  1030. component => 1,
  1031. contenttype => 'text/html',
  1032. ) if $query->{primary_post}{header};
  1033. return $header if ref $header eq 'ARRAY';
  1034. $footer = Trog::Renderer->render(
  1035. template => 'footers/' . $query->{primary_post}{footer},
  1036. data => { theme_dir => Trog::Themes::td(), %$query },
  1037. component => 1,
  1038. contenttype => 'text/html',
  1039. ) if $query->{primary_post}{footer};
  1040. return $header if ref $footer eq 'ARRAY';
  1041. # List the available headers/footers
  1042. my $headers = Trog::Themes::themed_templates_in_dir( "headers", 'text/html', 1 );
  1043. my $footers = Trog::Themes::themed_templates_in_dir( "footers", 'text/html', 1 );
  1044. #XXX used to be post.css, but probably not good anymore?
  1045. my $styles = [];
  1046. # Build page title if it wasn't set by a wrapping sub
  1047. $query->{title} = "$query->{domain} : $query->{title}" if $query->{title} && $query->{domain};
  1048. $query->{title} ||= @$tags && $query->{domain} ? "$query->{domain} : @$tags" : undef;
  1049. #Handle paginator vars
  1050. $query->{limit} ||= 25;
  1051. my $limit = int( $query->{limit} );
  1052. my $now_year = ( localtime(time) )[5] + 1900;
  1053. my $oldest_year = $now_year - 20; #XXX actually find oldest post year
  1054. # Handle post style.
  1055. if ( $query->{style} ) {
  1056. undef $header;
  1057. undef $footer;
  1058. }
  1059. my $older = !@posts ? 0 : $posts[-1]->{created};
  1060. $query->{failure} //= -1;
  1061. $query->{id} //= '';
  1062. my $newer = !@posts ? 0 : $posts[0]->{created};
  1063. #XXX messed up data has to be fixed unfortunately
  1064. @$tags = List::Util::uniq @$tags;
  1065. #Filter displaying visibility tags
  1066. my @visibuddies = qw{public unlisted private};
  1067. foreach my $post (@posts) {
  1068. @{ $post->{tags} } = grep {
  1069. my $tag = $_;
  1070. !grep { $tag eq $_ } @visibuddies
  1071. } @{ $post->{tags} };
  1072. }
  1073. #XXX note that we are explicitly relying on the first tag to be the ACL
  1074. my $aclselected = $tags->[0] || '';
  1075. my @acls = map {
  1076. $_->{selected} = $_->{aclname} eq $aclselected ? 'selected' : '';
  1077. $_
  1078. } _post_helper( {}, ['series'], $query->{user_acls} );
  1079. my $forms = Trog::Themes::themed_templates_in_dir( "forms", 'text/html', 1 );
  1080. my $edittype = $query->{primary_post} ? $query->{primary_post}->{child_form} : $query->{form};
  1081. my $tiled = $query->{primary_post} ? !$is_admin && $query->{primary_post}->{tiled} : 0;
  1082. state $data;
  1083. $data //= Trog::Data->new(Trog::Config::get());
  1084. # Grab the rest of the tags to dump into the edit form
  1085. my @tags_all = $data->tags();
  1086. #Filter out the visibilities and special series tags
  1087. @tags_all = grep {
  1088. my $subj = $_;
  1089. scalar( grep { $_ eq $subj } qw{public private unlisted admin series about topbar} ) == 0
  1090. } @tags_all;
  1091. @posts = map {
  1092. my $subject = $_;
  1093. my @et = grep {
  1094. my $subj = $_;
  1095. grep { $subj eq $_ } @tags_all
  1096. } @{ $subject->{tags} };
  1097. @et = grep { $_ ne $aclselected } @et;
  1098. $_->{extra_tags} = \@et;
  1099. $_
  1100. } @posts;
  1101. my @et = List::MoreUtils::singleton( @$tags, @tags_all );
  1102. $query->{author} = $query->{primary_post}{user} // $posts[0]{user};
  1103. my $picker = Trog::Component::EmojiPicker::render();
  1104. return $picker if ref $picker eq 'ARRAY';
  1105. # Enrich posts with additional data based on the template if necessary
  1106. foreach my $poast (@posts) {
  1107. if (exists $enrich{$poast->{form}}) {
  1108. my $callback = $enrich{$poast->{form}};
  1109. my %extra_data = $callback->($poast, $query);
  1110. foreach my $key (keys(%extra_data)) {
  1111. $poast->{$key} = $extra_data{$key};
  1112. }
  1113. }
  1114. }
  1115. #XXX the only reason this is needed is due to direct=1
  1116. #XXX is this even used?
  1117. my $content = Trog::Renderer->render(
  1118. template => 'posts.tx',
  1119. data => {
  1120. acls => \@acls,
  1121. can_edit => $is_admin,
  1122. forms => $forms,
  1123. post => { tags => $tags, extra_tags => \@et, form => $edittype, visibility => $user_visibility, addpost => 1 },
  1124. post_visibilities => \@visibuddies,
  1125. failure => $query->{failure},
  1126. to => $query->{to},
  1127. message => $query->{failure} ? "Failed to add post!" : "Successfully added Post as $query->{id}",
  1128. direct => $direct,
  1129. title => $query->{title},
  1130. author => $query->{primary_post}{user} // $posts[0]{user},
  1131. primary_post => $query->{primary_post},
  1132. style => $query->{style},
  1133. posts => \@posts,
  1134. like => $query->{like},
  1135. in_series => exists $query->{in_series} || !!( $query->{route} =~ m/^\/series\// ),
  1136. route => $query->{route},
  1137. limit => $limit,
  1138. pages => scalar(@posts) == $limit,
  1139. older => $older,
  1140. newer => $newer,
  1141. sizes => [ 25, 50, 100 ],
  1142. rss => !$query->{id} && !$query->{older},
  1143. tiled => $tiled,
  1144. category => $ph,
  1145. subhead => $query->{subhead},
  1146. header => $header,
  1147. footer => $footer,
  1148. headers => $headers,
  1149. footers => $footers,
  1150. years => [ reverse( $oldest_year .. $now_year ) ],
  1151. months => [ 0 .. 11 ],
  1152. emoji_picker => $picker,
  1153. embed => $query->{embed},
  1154. nochrome => $query->{nochrome},
  1155. },
  1156. contenttype => 'text/html',
  1157. component => 1,
  1158. );
  1159. # Something exploded
  1160. return $content if ref $content eq "ARRAY";
  1161. return $content if $direct;
  1162. return Trog::Routes::HTML::index( $query, $content, $styles );
  1163. }
  1164. sub _themed_title ($path) {
  1165. return $path unless %Theme::paths;
  1166. return $Theme::paths{$path} ? $Theme::paths{$path} : $path;
  1167. }
  1168. sub _post_helper ( $query, $tags, $acls ) {
  1169. state $data;
  1170. $data //= Trog::Data->new(Trog::Config::get());
  1171. $query->{page} ||= 1;
  1172. $query->{limit} ||= 25;
  1173. my @d = $data->get(
  1174. older => $query->{older},
  1175. newer => $query->{newer},
  1176. page => int( $query->{page} ),
  1177. limit => int( $query->{limit} ),
  1178. tags => $tags,
  1179. exclude_tags => $query->{exclude_tags},
  1180. acls => $acls,
  1181. aclname => $query->{aclname},
  1182. like => $query->{like},
  1183. author => $query->{author},
  1184. id => $query->{id},
  1185. version => $query->{version},
  1186. form => $query->{form},
  1187. );
  1188. return map {
  1189. my $subj = $_;
  1190. $subj->{local_href} = "/secure$_->{local_href}";
  1191. $subj
  1192. } @d if $query->{user};
  1193. return @d;
  1194. }
  1195. =head2 sitemap
  1196. Return the sitemap index unless the static or a set of dynamic routes is requested.
  1197. We have a maximum of 99,990,000 posts we can make under this model
  1198. As we have 10,000 * 10,000 posts which are indexable via the sitemap format.
  1199. 1 top level index slot (10k posts) is taken by our static routes, the rest will be /posts.
  1200. Passing ?xml=1 will result in an appropriate sitemap.xml instead.
  1201. This is used to generate the static sitemaps as expected by search engines.
  1202. Passing compressed=1 will gzip the output.
  1203. =cut
  1204. sub sitemap ($query) {
  1205. state $data;
  1206. $data //= Trog::Data->new(Trog::Config::get());
  1207. state $etag = "sitemap-" . time();
  1208. my ( @to_map, $is_index, $route_type );
  1209. my $warning = '';
  1210. $query->{map} //= '';
  1211. if ( $query->{map} eq 'static' ) {
  1212. # Return the map of static routes
  1213. $route_type = 'Static Routes';
  1214. @to_map = grep { !defined $routes{$_}->{captures} && !$routes{$_}->{auth} && !$routes{$_}->{noindex} && !$routes{$_}->{nomap} } keys(%routes);
  1215. }
  1216. elsif ( !$query->{map} ) {
  1217. # Return the index instead
  1218. @to_map = ('static');
  1219. my $tot = $data->count();
  1220. my $size = 50000;
  1221. my $pages = int( $tot / $size ) + ( ( $tot % $size ) ? 1 : 0 );
  1222. # Truncate pages at 10k due to standard
  1223. my $clamped = $pages > 49999 ? 49999 : $pages;
  1224. $warning = "More posts than possible to represent in sitemaps & index! Old posts have been truncated." if $pages > 49999;
  1225. foreach my $page ( $clamped .. 1 ) {
  1226. push( @to_map, "$page" );
  1227. }
  1228. $is_index = 1;
  1229. }
  1230. else {
  1231. $route_type = "Posts: Page $query->{map}";
  1232. # Return the map of the particular range of dynamic posts
  1233. $query->{limit} = 50000;
  1234. $query->{page} = $query->{map};
  1235. @to_map = _post_helper( $query, [], ['public'] );
  1236. }
  1237. if ( $query->{xml} ) {
  1238. DEBUG("RENDER SITEMAP XML");
  1239. my $sm;
  1240. my $xml_date = time();
  1241. my $fmt = "xml";
  1242. $fmt .= ".gz" if $query->{compressed};
  1243. if ( !$query->{map} ) {
  1244. require WWW::SitemapIndex::XML;
  1245. $sm = WWW::SitemapIndex::XML->new();
  1246. foreach my $url (@to_map) {
  1247. $sm->add(
  1248. loc => "http://$query->{domain}/sitemap/$url.$fmt",
  1249. lastmod => $xml_date,
  1250. );
  1251. }
  1252. }
  1253. else {
  1254. require WWW::Sitemap::XML;
  1255. $sm = WWW::Sitemap::XML->new();
  1256. my $changefreq = $query->{map} eq 'static' ? 'monthly' : 'daily';
  1257. foreach my $url (@to_map) {
  1258. my $true_uri = "http://$query->{domain}$url";
  1259. if ( ref $url eq 'HASH' ) {
  1260. my $is_user_page = grep { $_ eq 'about' } @{ $url->{tags} };
  1261. $true_uri = "http://$query->{domain}/posts/$url->{id}";
  1262. $true_uri = "http://$query->{domain}/users/$url->{title}" if $is_user_page;
  1263. }
  1264. my %out = (
  1265. loc => $true_uri,
  1266. lastmod => $xml_date,
  1267. mobile => 1,
  1268. changefreq => $changefreq,
  1269. priority => 1.0,
  1270. );
  1271. if ( ref $url eq 'HASH' ) {
  1272. #add video & preview image if applicable
  1273. $out{images} = [
  1274. {
  1275. loc => "http://$query->{domain}$url->{href}",
  1276. caption => $url->{data},
  1277. title => substr( $url->{title}, 0, 100 ),
  1278. }
  1279. ]
  1280. if $url->{is_image};
  1281. # Truncate descriptions
  1282. my $desc = substr( $url->{data}, 0, 2048 ) || '';
  1283. my $href = $url->{href} || '';
  1284. my $preview = $url->{preview} || '';
  1285. my $domain = $query->{domain} || '';
  1286. $out{videos} = [
  1287. {
  1288. content_loc => "http://$domain$href",
  1289. thumbnail_loc => "http://$domain$preview",
  1290. title => substr( $url->{title}, 0, 100 ) || '',
  1291. description => $desc,
  1292. }
  1293. ]
  1294. if $url->{is_video};
  1295. }
  1296. $sm->add(%out);
  1297. }
  1298. }
  1299. my $xml = $sm->as_xml();
  1300. require IO::String;
  1301. my $buf = IO::String->new();
  1302. my $ct = 'application/xml';
  1303. $xml->toFH( $buf, 0 );
  1304. seek $buf, 0, 0;
  1305. if ( $query->{compressed} ) {
  1306. require IO::Compress::Gzip;
  1307. my $compressed = IO::String->new();
  1308. IO::Compress::Gzip::gzip( $buf => $compressed );
  1309. $ct = 'application/gzip';
  1310. $buf = $compressed;
  1311. seek $compressed, 0, 0;
  1312. }
  1313. #XXX This is one of the few exceptions where we don't use finish_render, as it *requires* gzip.
  1314. return [ 200, [ "Content-type" => $ct, 'ETag' => $etag ], $buf ];
  1315. }
  1316. @to_map = sort @to_map unless $is_index;
  1317. my $styles = ['sitemap.css'];
  1318. $query->{title} = "$query->{domain} : Sitemap";
  1319. $query->{template} = 'sitemap.tx',
  1320. $query->{to_map} = \@to_map,
  1321. $query->{is_index} = $is_index,
  1322. $query->{route_type} = $route_type,
  1323. $query->{etag} = $etag;
  1324. return Trog::Routes::HTML::index( $query, undef, $styles );
  1325. }
  1326. sub _rss ( $query, $subtitle, $posts ) {
  1327. require XML::RSS;
  1328. my $rss = XML::RSS->new( version => '2.0', stylesheet => '/styles/rss-style.xsl' );
  1329. my $now = DateTime->from_epoch( epoch => time() );
  1330. my $port = $query->{port} ? ":$query->{port}" : '';
  1331. $rss->channel(
  1332. title => "$query->{domain}",
  1333. subtitle => $subtitle,
  1334. link => "http://$query->{domain}$port/$query->{route}?format=xml",
  1335. language => 'en', #TODO localization
  1336. description => "$query->{domain} : $query->{route}",
  1337. pubDate => $now,
  1338. lastBuildDate => $now,
  1339. );
  1340. $rss->image(
  1341. title => $query->{domain},
  1342. url => "/favicon.ico",
  1343. link => "http://$query->{domain}$port",
  1344. width => 32,
  1345. height => 32,
  1346. description => "$query->{domain} favicon",
  1347. );
  1348. foreach my $post (@$posts) {
  1349. my $url = "http://$query->{domain}$port$post->{local_href}";
  1350. _post2rss( $rss, $url, $post );
  1351. next unless ref $post->{aliases} eq 'ARRAY';
  1352. foreach my $alias ( @{ $post->{aliases} } ) {
  1353. $url = "http://$query->{domain}$port$alias";
  1354. _post2rss( $rss, $url, $post );
  1355. }
  1356. }
  1357. return Trog::Renderer->render(
  1358. template => 'raw.tx',
  1359. data => {
  1360. etag => $query->{etag},
  1361. body => encode_utf8( $rss->as_string ),
  1362. scheme => $query->{scheme},
  1363. },
  1364. headers => { 'Content-Disposition' => 'inline; filename="rss.xml"' },
  1365. #XXX if you do the "proper" content-type of application/rss+xml, browsers download rather than display.
  1366. contenttype => "text/xml",
  1367. code => 200,
  1368. );
  1369. }
  1370. sub _post2rss ( $rss, $url, $post ) {
  1371. $rss->add_item(
  1372. title => $post->{title},
  1373. permaLink => $url,
  1374. link => $url,
  1375. enclosure => { url => $url, type => "text/html" },
  1376. description => "<![CDATA[$post->{data}]]>",
  1377. pubDate => DateTime->from_epoch( epoch => $post->{created} ), #TODO format like Thu, 23 Aug 1999 07:00:00 GMT
  1378. author => $post->{user}, #TODO translate to "email (user)" format
  1379. );
  1380. }
  1381. =head2 manual
  1382. Implements the /manual and /lib/* routes.
  1383. Basically a thin wrapper around Pod::Html.
  1384. =cut
  1385. sub manual ($query) {
  1386. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  1387. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  1388. require Pod::Html;
  1389. require Capture::Tiny;
  1390. #Fix links from Pod::HTML
  1391. $query->{module} =~ s/\.html$//g if $query->{module};
  1392. $query->{failure} //= -1;
  1393. my $infile = $query->{module} ? "$query->{module}.pm" : 'tCMS/Manual.pod';
  1394. my $found = 0;
  1395. foreach my $libdir (@INC) {
  1396. $found = $libdir if -f "$libdir/$infile";
  1397. last if $found;
  1398. }
  1399. return $query->{tpsgi}->notfound($query) unless $found;
  1400. my $content = capture { Pod::Html::pod2html( qw{--podpath=lib --podroot=.}, "--infile=$found/$infile" ) };
  1401. return Trog::Routes::HTML::index(
  1402. {
  1403. title => 'tCMS Manual',
  1404. theme_dir => Trog::Themes::td(),
  1405. content => $content,
  1406. template => 'manual.tx',
  1407. is_admin => 1,
  1408. %$query,
  1409. },
  1410. undef,
  1411. ['post.css'],
  1412. );
  1413. }
  1414. =head2 processed
  1415. Implements /processed.
  1416. The "we got it, go check your email" page, shown after a request that finishes
  1417. out of band -- password and TOTP resets, chiefly. Deliberately says nothing
  1418. about whether the account existed.
  1419. =cut
  1420. sub processed ($query) {
  1421. return Trog::Routes::HTML::index(
  1422. {
  1423. title => "Your request has been processed",
  1424. theme_dir => Trog::Themes::td(),
  1425. },
  1426. "Your request has been processed.<br /><br />You will recieve subsequent communications about this matter via means you have provided earlier.",
  1427. ['post.css']
  1428. );
  1429. }
  1430. =head2 metrics
  1431. Implements /metrics. Admin only.
  1432. Renders the request metrics dashboard. The page pulls its actual numbers from
  1433. /api/requests_per over XHR and draws them with chart.js, so there's nothing to
  1434. compute here.
  1435. =cut
  1436. sub metrics ($query) {
  1437. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  1438. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  1439. $query->{failure} //= -1;
  1440. return Trog::Routes::HTML::index(
  1441. {
  1442. title => 'tCMS Metrics',
  1443. theme_dir => Trog::Themes::td(),
  1444. template => 'metrics.tx',
  1445. is_admin => 1,
  1446. %$query,
  1447. },
  1448. undef,
  1449. ['post.css'],
  1450. ['chart.js'],
  1451. );
  1452. }
  1453. =head2 sessions
  1454. Implements /sessions. Admin only.
  1455. The session audit log: logins, logouts and failures, most recent first.
  1456. Filterable by username and event type via the filter_user and filter_event
  1457. parameters, and capped by limit (100 by default).
  1458. Timestamps are formatted here rather than in the template, and session ids are
  1459. truncated to their first 8 characters -- there's no reason to put a live
  1460. session id on a page.
  1461. =cut
  1462. sub sessions ($query) {
  1463. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  1464. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  1465. my $limit = int( $query->{limit} // 100 );
  1466. my $events = Trog::Auth::audit_log(
  1467. limit => $limit,
  1468. username => $query->{filter_user} // '',
  1469. event_type => $query->{filter_event} // '',
  1470. );
  1471. # Format timestamps for display
  1472. @$events = map {
  1473. my $e = {%$_};
  1474. my @t = localtime( $e->{event_time} );
  1475. $e->{event_ts} = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0] );
  1476. $e->{session_short} = $e->{session_id} ? substr( $e->{session_id}, 0, 8 ) . '...' : '';
  1477. $e
  1478. } @$events;
  1479. return Trog::Routes::HTML::index(
  1480. {
  1481. title => 'tCMS Session Audit Log',
  1482. theme_dir => Trog::Themes::td(),
  1483. template => 'sessions.tx',
  1484. is_admin => 1,
  1485. events => $events,
  1486. limit => $limit,
  1487. filter_user => $query->{filter_user} // '',
  1488. filter_event => $query->{filter_event} // '',
  1489. %$query,
  1490. },
  1491. undef,
  1492. ['post.css'],
  1493. );
  1494. }
  1495. # The canned includes the wizard is willing to splice into a generated form.
  1496. # Deliberately a whitelist keyed on the checkbox name -- the include name ends
  1497. # up interpolated straight into a template file, so it can never come from the
  1498. # submitted data.
  1499. our %wizard_includes = (
  1500. inc_preview => 'preview.tx',
  1501. inc_visibility => 'visibility.tx',
  1502. inc_acls => 'acls.tx',
  1503. inc_tags => 'tags.tx',
  1504. inc_aliases => 'aliases.tx',
  1505. inc_attachments => 'attachments.tx',
  1506. );
  1507. # Emitted in this order, so generated forms read like the hand-written ones.
  1508. our @wizard_include_order = qw{inc_preview inc_visibility inc_acls inc_tags inc_aliases inc_attachments};
  1509. # Every checkbox on the wizard, and which of them start out ticked.
  1510. our @wizard_checkboxes = ( qw{wrapper inc_post_title inc_post_tags inc_title_input}, @wizard_include_order, 'overwrite' );
  1511. our %wizard_checked_by_default = map { $_ => 1 } qw{wrapper inc_post_title inc_post_tags inc_title_input inc_preview inc_visibility inc_acls inc_tags inc_aliases};
  1512. # Which HTML input the wizard emits, and what that field is in the sidecar's
  1513. # OpenAPIv3 schema. No 'file': _process() in Trog::DataModule only knows how to
  1514. # turn the four hardcoded upload fields into hrefs, so a custom file field would
  1515. # store an HTTP::Body::OctetStream that nothing ever picks up. Point folks at
  1516. # the attachment uploader instead.
  1517. our %wizard_field_types = (
  1518. text => { type => 'string' },
  1519. url => { type => 'string' },
  1520. date => { type => 'string' },
  1521. textarea => { type => 'string' },
  1522. number => { type => 'integer' },
  1523. checkbox => { type => 'boolean' },
  1524. );
  1525. # Field names which aren't in %schema but would still collide with something.
  1526. our @wizard_reserved = qw{app to form data_is_array addpost extra_tags is_image is_video is_audio is_profile content_type version};
  1527. =head2 post_wizard
  1528. Implements /admin/wyzzerdd. Admin only.
  1529. The post type wizard: lists the post types which currently exist and offers a
  1530. form for building a new one. See post_wizard_save() for what happens when that
  1531. form comes back.
  1532. Re-rendered by post_wizard_save() on both success and failure, so it keeps the
  1533. submitted values and checkbox states rather than making the admin retype
  1534. everything after a rejected submission.
  1535. =cut
  1536. sub post_wizard ($query) {
  1537. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  1538. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  1539. $query->{failure} //= -1;
  1540. # Get the existing post types
  1541. my $forms = Trog::Themes::themed_templates_in_dir( "forms", 'text/html', 1 );
  1542. # Sticky checkboxes. Nothing is submitted on a fresh GET, so fall back to
  1543. # the defaults rather than rendering everything unticked.
  1544. my %checked = map { $_ => ( $query->{wizard_submitted} ? $query->{$_} : $wizard_checked_by_default{$_} ) ? 'checked' : '' } @wizard_checkboxes;
  1545. return Trog::Routes::HTML::index(
  1546. {
  1547. # Sticky form values first, so a failed submission doesn't lose the
  1548. # admin's work -- but everything the template actually depends on is
  1549. # set *after* this, as the whole of %$query is attacker controlled.
  1550. %$query,
  1551. title => 'tCMS Post Wizard',
  1552. theme_dir => Trog::Themes::td(),
  1553. template => 'post_wizard.tx',
  1554. is_admin => 1,
  1555. forms => $forms,
  1556. forms_dir => Trog::Themes::forms_dir(),
  1557. checked => \%checked,
  1558. name => _wizard_scalar( $query->{name} ),
  1559. title_placeholder => _wizard_scalar( $query->{title_placeholder} ),
  1560. body_form => _wizard_scalar( $query->{body_form} ),
  1561. display => _wizard_scalar( $query->{display} ),
  1562. failure => $query->{failure},
  1563. message => $query->{message} // '',
  1564. to => $query->{to} // '',
  1565. },
  1566. undef,
  1567. ['post.css'],
  1568. );
  1569. }
  1570. =head2 post_wizard_save
  1571. Implements POST /admin/wyzzerdd/save.
  1572. Writes a new post type template into whichever forms directory is currently in
  1573. use, along with a JSON sidecar naming its custom fields so that
  1574. Trog::DataModule::schema_for will merge it over the base post schema, so the
  1575. type's own fields survive validation at save time.
  1576. =cut
  1577. sub post_wizard_save ($query) {
  1578. return $query->{tpsgi}->see_also('/login') unless $query->{user};
  1579. return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
  1580. # Anchored capture rather than a substitution, so anything containing a '/'
  1581. # or a '..' simply fails to match instead of being silently scrubbed into
  1582. # something that still escapes the directory.
  1583. my ($name) = _wizard_scalar( $query->{name} ) =~ m/^([A-Za-z0-9_-]+)$/;
  1584. return _wizard_fail( $query, "Post type names may only contain letters, numbers, '-' and '_'." ) unless $name;
  1585. # Whichever forms dir is in use: the theme's if it has one, the stock one
  1586. # otherwise. Never mkdir it -- silently conjuring a forms/ dir inside a
  1587. # theme is not something an admin asked for by pressing this button.
  1588. my $dir = Trog::Themes::forms_dir();
  1589. return _wizard_fail( $query, "Forms directory '$dir' does not exist, or is not writable." ) unless -d $dir && -w $dir;
  1590. my $tx_file = "$dir/$name.tx";
  1591. my $json_file = "$dir/$name.json";
  1592. my $overwriting = -e $tx_file;
  1593. return _wizard_fail( $query, "Post type '$name.tx' already exists. Tick 'Overwrite' if you meant to replace it." )
  1594. if $overwriting && !$query->{overwrite};
  1595. my $fields = _wizard_fields($query);
  1596. my @includes = grep { $query->{$_} } @wizard_include_order;
  1597. my $body_form = _wizard_scalar( $query->{body_form} ) eq 'form_multi.tx' ? 'form_multi.tx' : 'form_common.tx';
  1598. my $spec = _wizard_sidecar( $name, $fields, \@includes, $body_form );
  1599. local $@;
  1600. eval {
  1601. Path::Tiny::path($tx_file)->spew_utf8( _wizard_template( $query, $fields, \@includes, $body_form ) );
  1602. Path::Tiny::path($json_file)->spew_utf8( JSON::MaybeXS->new( pretty => 1, canonical => 1 )->encode($spec) );
  1603. 1;
  1604. } or return _wizard_fail( $query, "Failed to write post type '$name': $@" );
  1605. INFO("Post type '$name' written to $tx_file by $query->{user}");
  1606. # Nothing else is needed to publish a new type: themed_templates_in_dir()
  1607. # re-reads
  1608. # the directory every call, and Xslate resolves includes lazily, so both the
  1609. # wizard's own list and the series child_form dropdown pick it up on the
  1610. # next request without a restart. Overwriting an *existing* type is another
  1611. # matter -- that changes how already-rendered anonymous pages should look.
  1612. if ($overwriting) {
  1613. $query->{tpsgi}->add_post_close_callback(
  1614. sub {
  1615. $query->{tpsgi}->invalidate_renders('html');
  1616. }
  1617. );
  1618. }
  1619. return post_wizard(
  1620. {
  1621. %$query,
  1622. wizard_submitted => 1,
  1623. failure => 0,
  1624. message => "Created post type '$name.tx'.",
  1625. to => '/admin/wyzzerdd',
  1626. }
  1627. );
  1628. }
  1629. # Repeated params arrive as arrayrefs; anywhere we want one string, insist on one string.
  1630. sub _wizard_scalar ( $value = '' ) {
  1631. return '' if !defined $value || ref $value;
  1632. return $value;
  1633. }
  1634. sub _wizard_fail ( $query, $message ) {
  1635. WARN($message);
  1636. return post_wizard(
  1637. {
  1638. %$query,
  1639. wizard_submitted => 1,
  1640. failure => 1,
  1641. message => $message,
  1642. }
  1643. );
  1644. }
  1645. =head2 _kolon_safe
  1646. Make a submitted string safe to splice into a generated Kolon template.
  1647. Newlines have to go, as a ':' at the start of a line is a Kolon directive, and
  1648. the angle brackets have to go so that '<:' can never be reassembled.
  1649. =cut
  1650. sub _kolon_safe ( $string = '' ) {
  1651. $string = _wizard_scalar($string);
  1652. $string =~ s/[\r\n]+/ /g;
  1653. $string =~ s/&/&amp;/g;
  1654. $string =~ s/</&lt;/g;
  1655. $string =~ s/>/&gt;/g;
  1656. $string =~ s/"/&quot;/g;
  1657. return $string;
  1658. }
  1659. =head2 _wizard_fields
  1660. Zip the parallel param_* arrays submitted by the wizard back into a list of
  1661. field definitions. Every row always submits exactly one of each param, so the
  1662. arrays stay aligned even when a row is left blank.
  1663. =cut
  1664. sub _wizard_fields ($query) {
  1665. my $names = Trog::Utils::coerce_array( $query->{param_name} );
  1666. my $types = Trog::Utils::coerce_array( $query->{param_type} );
  1667. my $labels = Trog::Utils::coerce_array( $query->{param_label} );
  1668. my $phs = Trog::Utils::coerce_array( $query->{param_placeholder} );
  1669. my $reqs = Trog::Utils::coerce_array( $query->{param_required} );
  1670. my ( @fields, %seen );
  1671. foreach my $index ( 0 .. $#$names ) {
  1672. my ($fname) = lc( _wizard_scalar( $names->[$index] ) ) =~ m/^([a-z][a-z0-9_]{0,31})$/;
  1673. # Blank and bogus rows just get dropped.
  1674. next unless $fname;
  1675. next if $seen{$fname}++;
  1676. # Never let a custom field shadow a core post attribute.
  1677. next if exists $Trog::DataModule::post_schema{properties}{$fname};
  1678. next if grep { $fname eq $_ } @wizard_reserved;
  1679. my $type = _wizard_scalar( $types->[$index] );
  1680. $type = 'text' unless $wizard_field_types{$type};
  1681. push(
  1682. @fields,
  1683. {
  1684. name => $fname,
  1685. type => $type,
  1686. label => _kolon_safe( $labels->[$index] ) || ucfirst($fname),
  1687. placeholder => _kolon_safe( $phs->[$index] ),
  1688. required => _wizard_scalar( $reqs->[$index] ) ? 1 : 0,
  1689. }
  1690. );
  1691. }
  1692. return \@fields;
  1693. }
  1694. =head2 _wizard_sidecar
  1695. Turn the wizard's field list into the post type's JSON sidecar: an OpenAPIv3
  1696. object schema describing what this type ingests, with the wizard's own UI
  1697. metadata hung off x- extension keys so there's only one file to keep in sync.
  1698. Trog::DataModule::schema_for() merges this over the base post schema.
  1699. =cut
  1700. sub _wizard_sidecar ( $name, $fields, $includes, $body_form ) {
  1701. my %properties;
  1702. my @required;
  1703. foreach my $field (@$fields) {
  1704. my $property = { %{ $wizard_field_types{ $field->{type} } } };
  1705. $property->{'x-tcms-input'} = $field->{type};
  1706. $property->{'x-tcms-label'} = $field->{label};
  1707. $property->{'x-tcms-placeholder'} = $field->{placeholder} if length $field->{placeholder};
  1708. $properties{ $field->{name} } = $property;
  1709. push( @required, $field->{name} ) if $field->{required};
  1710. }
  1711. my %spec = (
  1712. 'x-tcms-post-type' => {
  1713. name => $name,
  1714. generated => JSON::MaybeXS::true(),
  1715. generator => 'Trog::Routes::HTML::post_wizard_save',
  1716. body_form => $body_form,
  1717. includes => [ map { $wizard_includes{$_} } @$includes ],
  1718. },
  1719. type => 'object',
  1720. properties => \%properties,
  1721. );
  1722. $spec{required} = \@required if @required;
  1723. return \%spec;
  1724. }
  1725. sub _wizard_field_html ($field) {
  1726. my ( $n, $t, $l, $p ) = @$field{qw{name type label placeholder}};
  1727. my $required = $field->{required} ? 'required ' : '';
  1728. return qq| $l<br /><textarea ${required}class="cooltext" name="$n" placeholder="$p"><: \$post.$n :></textarea>\n|
  1729. if $t eq 'textarea';
  1730. return qq| <label for="<: \$post.id :>-$n">$l<input id="<: \$post.id :>-$n" class="coolcb" type="checkbox" name="$n" value="1" <: if ( \$post.$n ) { "checked" } :> /></label><br />\n|
  1731. if $t eq 'checkbox';
  1732. return qq| $l<br /><input ${required}class="cooltext" type="$t" name="$n" placeholder="$p" value="<: \$post.$n :>" />\n|;
  1733. }
  1734. =head2 _wizard_template
  1735. Assemble the actual .tx file, following the shape of the hand-written forms:
  1736. a display half guarded by !$post.addpost, and an edit half guarded by $can_edit.
  1737. =cut
  1738. sub _wizard_template ( $query, $fields, $includes, $body_form ) {
  1739. my $placeholder = _kolon_safe( $query->{title_placeholder} ) || 'Iowa Man Destroys Moon';
  1740. # NOT escaped, on purpose. Letting an admin write template code is the
  1741. # entire point of the wizard, and it is no more privileged than the data
  1742. # field of any post, which already gets run through render_it(). Both
  1743. # sides of this route are behind the admin ACL.
  1744. my $display = _wizard_scalar( $query->{display} );
  1745. my $out = "<!-- Generated by the tCMS Post Type Wizard. Regenerating this type will overwrite any hand edits. -->\n";
  1746. $out .= qq|<div class="post <: \$style :>">\n| if $query->{wrapper};
  1747. $out .= qq| : if ( !\$post.addpost ) {\n|;
  1748. $out .= qq| : include "post_title.tx";\n| if $query->{inc_post_title};
  1749. $out .= qq| : include "post_tags.tx";\n| if $query->{inc_post_tags};
  1750. $out .= "$display\n" if $display;
  1751. $out .= qq| : }\n\n|;
  1752. $out .= qq| : if ( \$can_edit ) {\n|;
  1753. $out .= qq| <div class="postedit">\n|;
  1754. $out .= qq| : include "edit_head.tx";\n|;
  1755. $out .= qq| <form class="Submissions" action="/post/save" method="POST" enctype="multipart/form-data">\n|;
  1756. $out .= qq| Title *<br /><input required class="cooltext" type="text" name="title" placeholder="$placeholder" value="<: \$post.title :>" />\n|
  1757. if $query->{inc_title_input};
  1758. $out .= _wizard_field_html($_) foreach @$fields;
  1759. foreach my $include (@$includes) {
  1760. $out .= qq| : include "$wizard_includes{$include}";\n|;
  1761. }
  1762. # Always last, and never optional: this is what carries the post body, the
  1763. # app/to/id/form hiddens and the submit button.
  1764. $out .= qq| : include "$body_form";\n|;
  1765. $out .= qq| </form>\n|;
  1766. $out .= qq| : include "edit_foot.tx";\n|;
  1767. $out .= qq| </div>\n|;
  1768. $out .= qq| : }\n|;
  1769. $out .= qq|</div>\n| if $query->{wrapper};
  1770. return $out;
  1771. }
  1772. # basically a file rewrite rule for themes
  1773. =head2 icon
  1774. Implements the /img/icon/* routes.
  1775. Serves a themed icon, falling back to the stock one. A rewrite rule with extra
  1776. steps, essentially, so that themes can replace individual icons.
  1777. =cut
  1778. sub icon ($query) {
  1779. my $path = $query->{route};
  1780. my $tpath = Trog::Themes::themed("img/icon/$path");
  1781. return $query->{tpsgi}->serve( $path, $tpath, $query->{start}, $query->{streaming}, $query->{ranges}, $query->{last_fetched}, $query->{deflate} );
  1782. }
  1783. =head2 totp_qr
  1784. Implements the /totp/* routes.
  1785. Serves the QR code generated when a user enables TOTP. These live outside
  1786. www/, so they go out through serve() rather than the static file handler --
  1787. handing someone else's enrolment QR out to the world would be handing them the
  1788. shared secret.
  1789. =cut
  1790. sub totp_qr ($query) {
  1791. my $fname = basename($query->{route});
  1792. # For authenticated content, we have to now do a serve().
  1793. return $query->{tpsgi}->serve(
  1794. "totp/$fname",
  1795. "totp/$fname",
  1796. $query->{start},
  1797. $query->{streaming},
  1798. $query->{ranges},
  1799. $query->{last_fetched},
  1800. $query->{deflate},
  1801. );
  1802. }
  1803. =head2 rss_style
  1804. Implements /styles/rss-style.xsl.
  1805. The XSL stylesheet which makes the RSS feed legible in a browser. The header
  1806. and footer are rendered here and passed in as strings because the output is
  1807. XSL rather than HTML, so an include directive isn't available.
  1808. =cut
  1809. sub rss_style ($query) {
  1810. $query->{port} = ":$query->{port}" if $query->{port};
  1811. $query->{title} = qq{<xsl:value-of select="rss/channel/title"/>};
  1812. $query->{no_doctype} = 1;
  1813. # Due to this being html rather than XML, we can't use an include directive.
  1814. $query->{header} = Trog::Renderer->render( template => 'header.tx', data => $query, contenttype => 'text/html', component => 1 );
  1815. $query->{footer} = Trog::Renderer->render( template => 'footer.tx', data => $query, contenttype => 'text/html', component => 1 );
  1816. return Trog::Renderer->render(
  1817. template => 'rss-style.tx',
  1818. contenttype => 'text/xsl',
  1819. data => $query,
  1820. code => 200,
  1821. );
  1822. }
  1823. sub _build_themed_styles ($styles) {
  1824. my @styles = map { ( Trog::Themes::themed_style("$_") ) } @{ Trog::Utils::coerce_array($styles) };
  1825. return \@styles;
  1826. }
  1827. sub _build_themed_scripts ($scripts) {
  1828. my @scripts = map { Trog::Themes::themed_script("$_") } @{ Trog::Utils::coerce_array($scripts) };
  1829. return \@scripts;
  1830. }
  1831. =head2 finish_render($template, $vars, %headers)
  1832. Render a full page, as opposed to a component.
  1833. Fills in the defaults every page needs (lang, title, status code, content type,
  1834. cache control), resolves stylesheet and script names through the theme, makes
  1835. their paths absolute, renders the header and footer, and hands the lot to
  1836. Trog::Renderer.
  1837. Just about everything in this module ends up here; index() is the usual way in.
  1838. =cut
  1839. sub finish_render ( $template, $vars, %headers ) {
  1840. #XXX default vars that need to be pulled from config
  1841. $vars->{lang} //= 'en-US';
  1842. $vars->{title} //= 'tCMS';
  1843. $vars->{stylesheets} //= [];
  1844. $vars->{print_styles} //= [qw{structure.css print.css}];
  1845. $vars->{scripts} //= [];
  1846. # Theme-ize the paths
  1847. $vars->{stylesheets} = [ @{ _build_themed_styles( $vars->{stylesheets} ) } ];
  1848. $vars->{print_styles} = [ @{ _build_themed_styles( $vars->{print_styles} ) } ];
  1849. $vars->{scripts} = [ map { s/^www\///; $_ } @{ _build_themed_scripts( $vars->{scripts} ) } ];
  1850. # Add in avatars.css, it's special
  1851. push( @{ $vars->{stylesheets} }, "/styles/avatars.css" );
  1852. # Absolute-ize the paths for scripts & stylesheets
  1853. @{ $vars->{stylesheets} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{stylesheets} };
  1854. @{ $vars->{print_styles} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{print_styles} };
  1855. @{ $vars->{scripts} } = map { CORE::index( $_, '/' ) == 0 ? $_ : "/$_" } @{ $vars->{scripts} };
  1856. # TODO Smash together the stylesheets and minify
  1857. $vars->{contenttype} //= $Trog::Vars::content_types{html};
  1858. $vars->{cachecontrol} //= $Trog::Vars::cache_control{revalidate};
  1859. $vars->{code} ||= 200;
  1860. $vars->{theme_dir} =~ s/^\/www\/// if $vars->{theme_dir};
  1861. $vars->{header} = Trog::Renderer->render( template => 'header.tx', data => $vars, contenttype => 'text/html', component => 1 );
  1862. $vars->{footer} = Trog::Renderer->render( template => 'footer.tx', data => $vars, contenttype => 'text/html', component => 1 );
  1863. return Trog::Renderer->render( template => $template, data => $vars, contenttype => 'text/html', code => $vars->{code} );
  1864. }
  1865. 1;