DataModule.pm 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839
  1. package Trog::DataModule;
  2. use v5.36;
  3. use re '/aa';
  4. use FindBin::libs;
  5. use List::Util;
  6. use File::Copy;
  7. use Path::Tiny();
  8. use Ref::Util();
  9. use File::Basename qw{basename};
  10. use File::Slurper();
  11. use JSON::MaybeXS();
  12. use JSON::Validator::Schema::Troglodyne();
  13. use Time::HiRes();
  14. use Trog::Themes();
  15. use Trog::Log qw{:all};
  16. use Trog::Utils;
  17. use Trog::Auth();
  18. =head1 QUERY FORMAT
  19. The $query_language and $query_help variables are presented to the user as to how to use the search box in the tCMS header.
  20. =head1 POST STRUCTURE
  21. Posts generally need to have the following:
  22. data: Brief description of content, or the content itself.
  23. content_type: What this content actually is. Used to filter into the appropriate pages.
  24. href: Primary link. This is the subject of a news post, or a link to the item itself. Can be local or remote.
  25. local_href: Backup link. Automatically created link to a static cache of the content.
  26. title: Title of the content. Used as link name for the 'href' attribute.
  27. user: User was banned for this post
  28. id: Internal identifier in datastore for the post.
  29. tags: array ref of appropriate tags.
  30. created: timestamp of creation of this version of the post
  31. version: revision # of this post.
  32. =head1 CONSTRUCTOR
  33. =head2 new(Config::Simple $config)
  34. Try not to do expensive things here.
  35. =cut
  36. sub new ( $class, $config ) {
  37. $config = $config->vars();
  38. return bless( $config, $class );
  39. }
  40. =head1 ABSTRACT METHODS
  41. Subclasses must implement all of these; the stubs here do nothing but die.
  42. count() belongs to this set as well, and is documented with the rest of the
  43. querying interface below.
  44. =head2 lang() = STRING $language
  45. The name of the query language this data model understands, shown to the user
  46. beside the search bar.
  47. =head2 help() = STRING $help
  48. Documentation for that query language, shown to the user alongside it.
  49. =head2 read($query) = ARRAYREF $posts
  50. Every post the data model holds, as an arrayref of hashrefs. Filtering is
  51. get()'s job unless your storage engine can do it more cheaply itself, in which
  52. case honour $query here and override get() too.
  53. =head2 write($posts)
  54. Commit an arrayref of posts to storage. Called by add() once the posts have
  55. been filtered and validated; don't validate again here.
  56. =head2 tags() = ARRAYREF $tags
  57. Every tag known to the datastore, for building tag pickers.
  58. =cut
  59. #It is required that subclasses implement this
  60. sub lang ($self) { ... }
  61. sub help ($self) { ... }
  62. sub read ( $self, $query = {} ) { ... }
  63. sub write ($self) { ... }
  64. sub count ($self) { ... }
  65. sub tags ($self) { ... }
  66. =head1 METHODS
  67. =head2 get(%request)
  68. Queries the data model. Should return the following:
  69. id => Filter down to just the post by ID. May be subsequently filtered by ACL, resulting in a 404 (which is good, as it does not disclose info).
  70. version => if id is passed, return the provided post version rather than the most recent one
  71. tags => ARRAYREF of tags, any one of which is required to give a result. If none are passed, no filtering is performed.
  72. acls => ARRAYREF of acl tags, any one of which is required to give result. Filter applies after tags. 'admin' ACL being present skips this filter.
  73. page => Offset multiplier for pagination.
  74. limit => Offset for pagination.
  75. like => Search query, as might be passed in the search bar.
  76. author => filter by post author
  77. If it is more efficient to filter within your data storage engine, you probably should override this method.
  78. As implemented, this takes the data as a given and filters in post.
  79. =cut
  80. sub get ( $self, %request ) {
  81. my $posts = $self->read( \%request );
  82. return @$posts if $request{raw};
  83. my @filtered = $self->filter( \%request, @$posts );
  84. @filtered = $self->_fixup(@filtered);
  85. @filtered = $self->paginate( \%request, @filtered );
  86. return @filtered;
  87. }
  88. sub _fixup ( $self, @filtered ) {
  89. my %user2display;
  90. # urlencode spaces in filenames
  91. @filtered = map {
  92. my $subj = $_;
  93. foreach my $param (qw{href preview video_href audio_href local_href wallpaper}) {
  94. next unless exists $subj->{$param};
  95. #XXX I don't remember what this fixes, but it also breaks things. URI::Escape usage instead is indicated.
  96. $subj->{$param} =~ s/ /%20/g;
  97. }
  98. $user2display{ $subj->{user} } //= Trog::Auth::username2display( $subj->{user} );
  99. $subj->{display_name} = $user2display{ $subj->{user} };
  100. #XXX Add dynamic routing data for posts which don't have them (/posts/$id) and (/users/$user)
  101. my $is_user_page = List::Util::any { ( $_ // '' ) eq 'about' } @{ $subj->{tags} };
  102. if ( !exists $subj->{local_href} ) {
  103. $subj->{local_href} = "/posts/$subj->{id}";
  104. #XXX this needs to be correctly populated in the form?
  105. if ($is_user_page) {
  106. my $display_name = $user2display{ $subj->{user} };
  107. die "No display name for user!" unless $display_name;
  108. $subj->{local_href} = "/users/$display_name";
  109. }
  110. }
  111. if ( !exists $subj->{callback} ) {
  112. $subj->{callback} = "Trog::Routes::HTML::posts";
  113. $subj->{callback} = "Trog::Routes::HTML::users" if $is_user_page;
  114. }
  115. $subj->{method} = 'GET' unless exists( $subj->{method} );
  116. $subj->{user_class} = Trog::Auth::username2classname( $subj->{user} );
  117. $subj
  118. } @filtered;
  119. return @filtered;
  120. }
  121. sub _filter_param ( $query, $param, @filtered ) {
  122. @filtered = grep { ( $_->{$param} || '' ) eq $query->{$param} } @filtered;
  123. @filtered = _dedup_versions( $query->{version}, @filtered );
  124. return @filtered;
  125. }
  126. =head2 filter($query, @posts) = @filtered
  127. Apply a get() request's filters to a list of posts: tags, exclude_tags, acls,
  128. visibility, id, title, form, search terms and author.
  129. The ACL check is the load bearing one -- a post is only visible if the caller
  130. holds one of its acls, or the post is public or unlisted. Callers holding the
  131. 'admin' acl skip that filter entirely.
  132. =cut
  133. sub filter ( $self, $query, @filtered ) {
  134. $query->{acls} //= [];
  135. $query->{tags} //= [];
  136. $query->{exclude_tags} //= [];
  137. # If an ID or title or acl is passed, just get that (and all it's prior versions)
  138. foreach my $key (qw{id title aclname}) {
  139. next unless $query->{$key};
  140. return _filter_param( $query, $key, @filtered );
  141. }
  142. @filtered = _dedup_versions( undef, @filtered );
  143. #Filter out posts which are too old
  144. #Coerce older into numeric
  145. if ( $query->{older} ) {
  146. $query->{older} =~ s/[^0-9]//g;
  147. @filtered = grep { $_->{created} < $query->{older} } @filtered;
  148. }
  149. if ( $query->{newer} ) {
  150. $query->{newer} =~ s/[^0-9]//g;
  151. @filtered = grep { $_->{created} > $query->{newer} } @filtered;
  152. }
  153. # Filter posts not matching the passed tag(s), if any
  154. @filtered = grep {
  155. my $tags = $_->{tags};
  156. grep {
  157. my $t = $_;
  158. grep { ( $t // '' ) eq $_ } @{ $query->{tags} }
  159. } @$tags
  160. } @filtered if @{ $query->{tags} };
  161. # Filter posts *matching* the passed exclude_tag(s), if any
  162. @filtered = grep {
  163. my $tags = $_->{tags};
  164. !grep {
  165. my $t = $_;
  166. grep { $t eq $_ } @{ $query->{exclude_tags} }
  167. } @$tags
  168. } @filtered if @{ $query->{exclude_tags} };
  169. # Filter posts without the proper ACLs
  170. @filtered = grep {
  171. my $tags = $_->{tags};
  172. grep {
  173. my $t = $_;
  174. grep { $t eq $_ } @{ $query->{acls} }
  175. } @$tags
  176. } @filtered unless grep { $_ eq 'admin' } @{ $query->{acls} };
  177. @filtered = grep { ( $_->{form} || '' ) eq $query->{form} } @filtered if $query->{form};
  178. @filtered = grep { $_->{title} =~ m/\Q$query->{like}\E/i || $_->{data} =~ m/\Q$query->{like}\E/i } @filtered if $query->{like};
  179. @filtered = grep { $_->{user} eq $query->{author} } @filtered if $query->{author};
  180. return @filtered;
  181. }
  182. =head2 paginate($query, @posts) = @page
  183. The slice of @posts named by the request's page and limit. Both have to be
  184. present to page at all; limit defaults to 25 when computing the offset.
  185. =cut
  186. sub paginate ( $self, $query, @filtered ) {
  187. my $offset = int( $query->{limit} // 25 );
  188. $offset = @filtered < $offset ? @filtered : $offset;
  189. @filtered = splice( @filtered, ( int( $query->{page} ) - 1 ) * $offset, $offset ) if $query->{page} && $query->{limit};
  190. return @filtered;
  191. }
  192. sub _dedup_versions ( $version = -1, @posts ) {
  193. #ASSUMPTION made here - if we pass version this is direct ID query
  194. if ( defined $version ) {
  195. my $version_max = List::Util::max( map { $_->{version} } @posts );
  196. return map {
  197. $_->{version_max} //= $version_max;
  198. $_
  199. } grep { $_->{version} eq $version } @posts;
  200. }
  201. my @uniqids = List::Util::uniq( map { $_->{id} } @posts );
  202. my %posts_deduped;
  203. for my $id (@uniqids) {
  204. my @ofid = sort { $b->{version} <=> $a->{version} } grep { $_->{id} eq $id } @posts;
  205. my $version_max = List::Util::max( map { $_->{version} } @ofid );
  206. $posts_deduped{$id} = $ofid[0];
  207. $posts_deduped{$id}{version_max} = $version_max;
  208. # Show orig creation date, and original author.
  209. # XXX this doesn't show the mtime correctly for whatever reason, so I'm omitting it from the interface
  210. $posts_deduped{$id}{modified} = $ofid[0]{created};
  211. $posts_deduped{$id}{created} = $ofid[-1]{created};
  212. $posts_deduped{$id}{author} = $ofid[-1]{author};
  213. }
  214. my @deduped = @posts_deduped{@uniqids};
  215. return @deduped;
  216. }
  217. =head2 count() = INT $num
  218. Returns the total number of posts.
  219. Used to determine paginator parameters.
  220. =cut
  221. =head2 add(@posts) = BOOL $failed_or_not
  222. Add the provided posts to the datastore.
  223. If any post already exists with the same id, a new post with a version higher than it will be added.
  224. Passes an array of new posts to add to the data store module's write() function.
  225. These will have their parameters filtered to those described by the post type's
  226. schema (see schema_for()), and then validated against it. If the post doesn't
  227. hold up, this dies with an ARRAYREF of validation error strings -- a ref rather
  228. than a string so that Carp::Always doesn't staple a stack trace onto something
  229. we intend to show the user.
  230. You probably won't want to override this.
  231. =cut
  232. # The shape of a post, as an OpenAPIv3 object schema.
  233. #
  234. # This covers the fields every post has regardless of which form produced it.
  235. # Anything a *particular* post type ingests lives in that type's JSON sidecar
  236. # next to its template in the forms directory -- see _schema_for().
  237. our %post_schema = (
  238. type => 'object',
  239. properties => {
  240. ## Parameters which must be in every single post
  241. title => { type => 'string' },
  242. callback => { type => 'callback' },
  243. tags => { type => 'array', items => { type => 'string' } },
  244. version => { type => 'integer', minimum => 0 },
  245. visibility => { type => 'string', enum => [qw{public unlisted private}] },
  246. aliases => { type => 'array', items => { type => 'string' } },
  247. # title links here
  248. href => { type => 'string' },
  249. # Link to post locally
  250. local_href => { type => 'string' },
  251. # Post body. Multi-page types (presentations, invoices) send an array.
  252. data => {
  253. oneOf => [
  254. { type => 'string' },
  255. { type => 'array', items => { type => 'string' } },
  256. ],
  257. },
  258. # How do I edit this post?
  259. form => { type => 'string' },
  260. # Post is restricted to visibility to these ACLs if not public/unlisted
  261. acls => { type => 'array', items => { type => 'string' } },
  262. id => { type => 'string' },
  263. # Author of the post
  264. user => { type => 'string' },
  265. created => { type => 'integer' },
  266. # Posts are always GET, but it's stored, so it has to be describable.
  267. method => { type => 'string' },
  268. },
  269. );
  270. # Uploads arrive as an HTTP::Body hashref on the way in, and as the href string
  271. # they were turned into on the way back out of the datastore. Sidecars say
  272. # 'upload' and mean this.
  273. our %upload_schema = (
  274. oneOf => [
  275. { type => 'string' },
  276. { type => 'object' },
  277. ],
  278. );
  279. =head2 schema_for($form)
  280. Return the OpenAPIv3 schema describing what the named post type ingests: the
  281. base post schema above, with the type's JSON sidecar merged over the top.
  282. Sidecars live beside their templates (blog.tx has blog.json) and are written
  283. either by hand or by the Post Type Wizard. A post with no form, or a form with
  284. no sidecar, just gets the base schema.
  285. Cached, but keyed on the mtimes of the component dirs rather than memoized
  286. outright: adding or editing a sidecar bumps one of them, so every forked worker
  287. picks the change up on its very next add() with no restart needed.
  288. =cut
  289. # Stat the forms dirs, not their parents -- writing blog.json bumps the mtime
  290. # of forms/, and nothing above it. Both candidates, since either one gaining a
  291. # sidecar changes the answer.
  292. #
  293. # Time::HiRes::stat, because core stat truncates mtime to the second: the post
  294. # type wizard writes a sidecar and something reads it back moments later, and at
  295. # one second of resolution those two are frequently the same generation. The
  296. # reader then answers out of the cache it filled before the write, which is how
  297. # a type saved and used inside the same second validated against the schema it
  298. # had a moment ago. Falls back to whatever stat gives where the filesystem
  299. # carries no sub-second timestamps.
  300. sub _sidecar_generation {
  301. return join( ':', map { ( Time::HiRes::stat("$_/forms") )[9] // 0 } Trog::Themes::template_dirs( 'text/html', 1 ) );
  302. }
  303. # A signature default only covers an absent arg, and plenty of posts have an
  304. # explicitly undef form.
  305. sub _type_of ($form) {
  306. $form = '' if !defined $form || ref $form;
  307. my ($type) = $form =~ m/^([A-Za-z0-9_-]+)\.tx$/;
  308. return $type // '';
  309. }
  310. =head2 type_meta_for($form)
  311. The parts of a post type's sidecar which aren't schema: x-tcms-relations,
  312. x-tcms-post-type and friends.
  313. schema_for() deliberately keeps only properties and required, since everything
  314. else would be noise to the validator -- but the relation tables and the post
  315. type's own metadata live out there and something has to read them.
  316. =cut
  317. sub type_meta_for ( $form = '' ) {
  318. state %cache;
  319. my $generation = _sidecar_generation();
  320. %cache = () unless exists $cache{$generation};
  321. my $type = _type_of($form);
  322. return $cache{$generation}{$type} if exists $cache{$generation}{$type};
  323. my $path = $type ? Trog::Themes::themed_file_in_dir( 'forms', "$type.json", 'text/html', 1 ) : undef;
  324. my $sidecar = $path ? _read_sidecar($path) : undef;
  325. my %meta;
  326. if ($sidecar) {
  327. %meta = map { $_ => $sidecar->{$_} } grep { $_ ne 'properties' && $_ ne 'required' && $_ ne 'type' } keys(%$sidecar);
  328. }
  329. $cache{$generation}{$type} = \%meta;
  330. return $cache{$generation}{$type};
  331. }
  332. =head2 private_fields_for($form)
  333. The fields of a post type which only an editor may see, as declared by
  334. x-tcms-private in the sidecar.
  335. A field is public unless it says otherwise. The point of declaring it here
  336. rather than guarding it in the template is that the value can then be dropped
  337. before rendering, so no amount of getting a template wrong can leak it.
  338. =cut
  339. sub private_fields_for ( $form = '' ) {
  340. my $properties = schema_for($form)->{properties} // {};
  341. return [ grep { $properties->{$_}{'x-tcms-private'} } keys(%$properties) ];
  342. }
  343. =head2 indexed_fields_for($form)
  344. The custom fields of a post type which the Post Type Wizard was told to index,
  345. as declared by x-tcms-indexed in the sidecar.
  346. A field is unindexed unless it says otherwise. What indexing a field actually
  347. means is up to the data model -- see index_fields(), which most of them ignore.
  348. =cut
  349. sub indexed_fields_for ( $form = '' ) {
  350. my $properties = schema_for($form)->{properties} // {};
  351. # Sorted, unlike private_fields_for(), which is only ever asked whether a
  352. # given field is in it. This list is collected across every post type and
  353. # handed to a data model to act on, and an answer that comes back in a
  354. # different order each run makes a reconciliation impossible to reason about.
  355. return [ sort grep { $properties->{$_}{'x-tcms-indexed'} } keys(%$properties) ];
  356. }
  357. =head2 index_fields(@fields)
  358. Tell the data model which custom fields ought to be queryable, and let it do
  359. whatever that means for it.
  360. The default is to do nothing at all, and that is a perfectly good answer: a
  361. model with no notion of an index has nothing to build, and the wizard should not
  362. have to know which model it is talking to in order to offer the option.
  363. Called with the full set every time rather than with a delta, so a model that
  364. does act on it can bring itself into line in one pass -- including letting go of
  365. what is no longer asked for.
  366. =cut
  367. sub index_fields ( $self, @fields ) { return 0 }
  368. =head2 relations_for($form)
  369. The x-tcms-relations table for a post type, as a hashref keyed on the template
  370. variable the resolved posts land in. Empty when the type declares none.
  371. Each entry is { form => 'other.tx', from => 'field_name' } -- 'from' naming the
  372. field holding a UUID to resolve, or absent to mean every post of that type.
  373. =cut
  374. sub relations_for ( $form = '' ) {
  375. my $relations = type_meta_for($form)->{'x-tcms-relations'};
  376. return {} unless Ref::Util::is_hashref($relations);
  377. return $relations;
  378. }
  379. sub schema_for ( $form = '' ) {
  380. state %cache;
  381. my $generation = _sidecar_generation();
  382. # Only ever keep the current generation around.
  383. %cache = () unless exists $cache{$generation};
  384. my $type = _type_of($form);
  385. return $cache{$generation}{$type} if exists $cache{$generation}{$type};
  386. my %merged = ( %post_schema, properties => { %{ $post_schema{properties} } } );
  387. # Themed like the templates themselves: a theme that overrides blog.tx can
  388. # ship its own blog.json alongside it, and one that doesn't still gets the
  389. # stock schema rather than nothing at all.
  390. my $path = $type ? Trog::Themes::themed_file_in_dir( 'forms', "$type.json", 'text/html', 1 ) : undef;
  391. my $sidecar = $path ? _read_sidecar($path) : undef;
  392. if ($sidecar) {
  393. # The base schema is merged *last*, so a sidecar can add fields but can
  394. # never redefine one of ours. That matters: a sidecar retyping
  395. # 'callback' as a plain string would defeat the check that the sub it
  396. # names actually exists, which is a privilege problem rather than a
  397. # cosmetic one.
  398. %{ $merged{properties} } = ( %{ $sidecar->{properties} // {} }, %{ $merged{properties} } );
  399. # A sidecar may insist on its own fields, but it can't relax anything
  400. # the base schema already demands.
  401. my @required = List::Util::uniq( @{ $post_schema{required} // [] }, @{ $sidecar->{required} // [] } );
  402. # An empty required list isn't legal OpenAPI, so don't emit one.
  403. $merged{required} = \@required if @required;
  404. }
  405. $cache{$generation}{$type} = \%merged;
  406. return $cache{$generation}{$type};
  407. }
  408. sub _read_sidecar ($path) {
  409. # -e, not -f: the question is whether a sidecar exists at all, and most
  410. # post types have none. Letting the read below fail instead would WARN
  411. # about every type that simply does not have one.
  412. return undef unless -e $path;
  413. local $@;
  414. my $spec = eval { JSON::MaybeXS::decode_json( File::Slurper::read_text($path) ) };
  415. if ( !$spec ) {
  416. WARN("Could not parse post type sidecar '$path': $@");
  417. return undef;
  418. }
  419. return undef unless Ref::Util::is_hashref($spec);
  420. _expand_pseudo_types($spec);
  421. return $spec;
  422. }
  423. # A relation is stored as the referenced post's UUID, and resolved into the
  424. # post itself at render time -- see the x-tcms-relations table a sidecar
  425. # declares alongside it, and Trog::Routes::HTML::_enrich_post. The pseudo-type
  426. # exists so a sidecar can say what a field *means* rather than just that it
  427. # happens to be a string.
  428. our %relation_schema = ( type => 'string' );
  429. # Sugar: a sidecar says {"type":"upload"} rather than spelling out the
  430. # string-or-hashref dance every upload field would otherwise need. Uploads are
  431. # a hashref on the way in from the browser and the href string they became on
  432. # the way back out of the datastore.
  433. sub _expand_pseudo_types ($node) {
  434. return unless Ref::Util::is_hashref($node);
  435. my %pseudo = (
  436. upload => \%upload_schema,
  437. relation => \%relation_schema,
  438. );
  439. my $type = $node->{type} // '';
  440. if ( $pseudo{$type} ) {
  441. delete $node->{type};
  442. %$node = ( %$node, %{ $pseudo{$type} } );
  443. return;
  444. }
  445. _expand_pseudo_types($_) foreach values( %{ $node->{properties} // {} } );
  446. _expand_pseudo_types( $node->{items} ) if $node->{items};
  447. foreach my $key (qw{oneOf anyOf allOf}) {
  448. next unless Ref::Util::is_arrayref( $node->{$key} );
  449. _expand_pseudo_types($_) foreach @{ $node->{$key} };
  450. }
  451. return;
  452. }
  453. =head2 validate($post)
  454. Filter a post down to the fields its type actually describes, then run what's
  455. left through the schema.
  456. Returns the list of validation errors, which is empty when the post is good.
  457. Note that filtering happens first and silently: the query hash handed to us by
  458. the router is full of things which aren't post fields at all, and never was
  459. meant to round-trip.
  460. =cut
  461. sub validate ($post) {
  462. state $validator;
  463. $validator //= JSON::Validator::Schema::Troglodyne->new();
  464. my $schema = schema_for( $post->{form} );
  465. foreach my $key ( keys(%$post) ) {
  466. # Drop everything the schema doesn't describe.
  467. my $property = $schema->{properties}{$key};
  468. if ( !$property ) {
  469. delete $post->{$key};
  470. next;
  471. }
  472. # An untouched form input submits the empty string, which is HTML for
  473. # "I wasn't filled in" rather than a number, a boolean or a file. We
  474. # leave it alone for actual string fields, which is what got stored
  475. # before any of this was typed.
  476. delete $post->{$key}
  477. if defined $post->{$key}
  478. && !ref $post->{$key}
  479. && $post->{$key} eq ''
  480. && ( $property->{type} // '' ) ne 'string';
  481. }
  482. # OpenAPIv3 coerces as it goes, so "4" lands in the datastore as 4 and
  483. # checkbox values land as real booleans.
  484. return $validator->validate( $post, $schema );
  485. }
  486. sub add ( $self, @posts ) {
  487. my @to_write;
  488. foreach my $post (@posts) {
  489. # Filter to what this post type actually describes, then validate it.
  490. my @errors = validate($post);
  491. # An arrayref rather than a string on purpose. These errors get shown
  492. # to whoever submitted the post, and Carp::Always decorates a string
  493. # die with a stack trace they have no use for.
  494. die [ map { "$_" } @errors ] if @errors;
  495. $post->{id} //= Trog::Utils::uuid();
  496. $post->{aliases} //= [];
  497. $post->{aliases} = [ $post->{aliases} ] unless ref $post->{aliases} eq 'ARRAY';
  498. if ( $post->{aclname} ) {
  499. # Then this is a series
  500. $post->{local_href} //= "/$post->{aclname}";
  501. push( @{ $post->{aliases} }, "/posts/$post->{id}", "/series/$post->{id}" );
  502. }
  503. # Every post needs one: _process pushes it into the tags, and an
  504. # undef there is a tag no query will ever match, which makes the post
  505. # invisible to everyone but an admin. A post type built without a
  506. # visibility selector would otherwise produce exactly that. Private
  507. # rather than public, because guessing wrong in the other direction
  508. # publishes something nobody asked to publish.
  509. $post->{visibility} //= 'private';
  510. $post->{callback} //= 'Trog::Routes::HTML::posts';
  511. # If this is a user creation post, add in the /user/ route
  512. if ( $post->{callback} eq 'Trog::Routes::HTML::users' ) {
  513. $post->{local_href} //= "/users/$post->{display_name}";
  514. $post->{title} //= $post->{display_name};
  515. }
  516. $post->{local_href} //= "/posts/$post->{id}";
  517. $post->{method} //= 'GET';
  518. $post->{created} = time();
  519. my @existing_posts = $self->get( id => $post->{id} );
  520. if (@existing_posts) {
  521. my $existing_post = $existing_posts[0];
  522. $post->{version} = $existing_post->{version};
  523. $post->{version}++;
  524. }
  525. $post->{version} //= 0;
  526. #XXX if local_href has /secure paths in it, fix this. We don't want to save that.
  527. if ( index( $post->{local_href}, '/secure/' ) == 0 ) {
  528. $post->{local_href} =~ s|/secure||gmx;
  529. }
  530. $post = _process($post);
  531. push @to_write, $post;
  532. }
  533. $self->write( \@to_write );
  534. return 0;
  535. }
  536. #XXX this level of post-processing seems gross, but may be unavoidable
  537. # Not actually a subprocess, kek
  538. sub _process ($post) {
  539. # If the post is private, make sure it's associated assets are too.
  540. my $is_private_post = $post->{visibility} eq 'private';
  541. $post->{href} = _handle_upload( $post->{file}, $post->{id}, $is_private_post ) if $post->{file};
  542. $post->{preview} = _handle_upload( $post->{preview_file}, $post->{id}, $is_private_post ) if $post->{preview_file};
  543. $post->{wallpaper} = _handle_upload( $post->{wallpaper_file}, $post->{id}, $is_private_post ) if $post->{wallpaper_file};
  544. @{ $post->{attachments} } = map { _handle_upload( $_, $post->{id}, $is_private_post ) } @{ $post->{attachments} } if $post->{attachments};
  545. $post->{preview} = $post->{href} if $post->{app} && $post->{app} eq 'image';
  546. delete $post->{app};
  547. delete $post->{file};
  548. delete $post->{preview_file};
  549. delete $post->{wallpaper_file};
  550. delete $post->{scheme};
  551. delete $post->{route};
  552. delete $post->{domain};
  553. # Handle acls/tags
  554. $post->{tags} //= [];
  555. $post->{acls} //= [];
  556. @{ $post->{tags} } = grep {
  557. my $subj = $_;
  558. !grep { $_ eq $subj } qw{public private unlisted}
  559. } @{ $post->{tags} };
  560. push( @{ $post->{tags} }, @{ $post->{acls} } ) if $is_private_post;
  561. delete $post->{acls};
  562. push( @{ $post->{tags} }, $post->{visibility} );
  563. # Add the 'series' tag if we are in a series, restrict to relevant acl
  564. if ( $post->{series} ) {
  565. push( @{ $post->{tags} }, 'series' );
  566. push( @{ $post->{tags} }, $post->{series} );
  567. }
  568. #Filter adding the same acl twice
  569. @{ $post->{tags} } = List::Util::uniq( @{ $post->{tags} } );
  570. @{ $post->{aliases} } = List::Util::uniq( @{ $post->{aliases} } );
  571. # Handle multimedia content types
  572. $post->{content_type} = Trog::Utils::mime_type("www/$post->{href}") if $post->{href};
  573. $post->{video_content_type} = Trog::Utils::mime_type("www/$post->{video_href}") if $post->{video_href};
  574. $post->{audio_content_type} = Trog::Utils::mime_type("www/$post->{audio_href}") if $post->{audio_href};
  575. $post->{content_type} ||= 'text/html';
  576. $post->{is_video} = 1 if $post->{content_type} =~ m/^video\//;
  577. $post->{is_audio} = 1 if $post->{content_type} =~ m/^audio\//;
  578. $post->{is_image} = 1 if $post->{content_type} =~ m/^image\//;
  579. $post->{is_profile} = 1 if grep { $_ eq 'about' } @{ $post->{tags} };
  580. return $post;
  581. }
  582. # Browsers try and save time in the event that the same file is sent twice, so handle that.
  583. my %seen_files;
  584. sub _handle_upload ( $file, $uuid, $private = 0 ) {
  585. my $fname;
  586. if ( ref $file ne 'HASH' ) {
  587. use Data::Dumper;
  588. $file =~ s/\\/\//g;
  589. $fname = basename($file);
  590. FATAL("Did not expect bogus file before its real counterpart!") unless $seen_files{$fname};
  591. return $seen_files{$fname};
  592. }
  593. my $f = $file->{tempname};
  594. $fname = basename( $file->{filename} );
  595. my $newname = "$uuid.$file->{filename}";
  596. $newname = "private/$newname" if $private;
  597. File::Copy::move( $f, "www/assets/$newname" );
  598. # Regrettably, we have no control over the perms of the temp file that starman creates for uploads.
  599. chmod( 0755, "www/assets/$newname" );
  600. $seen_files{$fname} = "/assets/$newname";
  601. return $seen_files{$fname};
  602. }
  603. =head2 delete(@posts)
  604. Delete the following posts.
  605. Will remove all versions of said post.
  606. You should override this, it is a stub here.
  607. =cut
  608. sub delete ($self) { die 'stub' }
  609. =head2 routes() = HASH
  610. Returns the routes to each post.
  611. You should override this for performance reasons, as it's just a wrapper around get() by defualt.
  612. =cut
  613. sub routes ($self) {
  614. my %routes = map { $_->{local_href} => { method => $_->{method}, callback => \&{ $_->{callback} } } } ( $self->get( limit => 0, acls => ['admin'] ) );
  615. return %routes;
  616. }
  617. =head2 aliases() = HASH
  618. Returns the aliases for each post, indexed by aliases.
  619. You should override this for performance reasons, as it's just a wrapper around get() by defualt.
  620. =cut
  621. sub aliases ($self) {
  622. my @posts = $self->get( limit => 0, acls => ['admin'] );
  623. my %aliases;
  624. foreach my $post (@posts) {
  625. @aliases{ @{ $post->{aliases} } } = $post->{local_href};
  626. }
  627. return %aliases;
  628. }
  629. 1;