diff options
Diffstat (limited to 'desk/app/boke.hoon')
| -rw-r--r-- | desk/app/boke.hoon | 1145 |
1 files changed, 1145 insertions, 0 deletions
diff --git a/desk/app/boke.hoon b/desk/app/boke.hoon new file mode 100644 index 0000000..5b3231a --- /dev/null +++ b/desk/app/boke.hoon @@ -0,0 +1,1145 @@ +/- *boke, tp=trill-post, c=tlon-channels, ch=tlon-chat, cnt=contact, pols=polls +/+ dbug, js=json, plib=trill-utils, kaji, lib=boke, ui=trill-ui, mm=mmast, sr=sortug, const=constants, wall +/= nav /web/layout/nav +/= router /web/router +|% +++ page-size 10 ++$ read-post +$: title=@t + =path + contents=content-list:tp + date=@da + tags=(set @t) + id=@ud +== ++$ read-comment +$: author=@t + date=@da + contents=content-list:tp + pa=@t + parent=@da + post=@da + title=@t +== ++$ read-boardpost +$: author=@t + op=@t + thread=@da + date=@da + title=@t + content=content-list:tp + id=@ud + tid=@ud +== ++$ versioned-state +$% state-0 +== ++$ card card:agent:gall +-- +%- agent:dbug +=| state-0 +=* state - +^- agent:gall +=< +|_ =bowl:gall ++* this . + hd ~(. +> bowl) + kaj (init:kaji bowl _state kaji-req) +:: +++ on-fail |~(* `this) +++ on-leave |~(* `this) +++ on-save !>(state) +++ on-init +^- (quip card _this) +=. state init-state:hd +:_ this init-cards:hd + +++ on-load |= old=vase +:_ this(state !<(versioned-state old)) ~ +++ on-watch +|= =(pole knot) +~& >> on-watch=pole + ?+ pole !! + [%ui ~] `this + [%http-response id=@ ~] `this + [%tv type=@t author=@t ~] `this + [%chat host=@t name=@t ~] `this + [%sse tab=@t ~] `this + == +++ on-poke +|= [=mark =vase] +?: (~(has in banned-ships:const) src.bowl) `this +|^ +?+ mark `this +%handle-http-request serve +%noun (on-poke-noun !<(* vase)) +%kaji run:handle-ui +== + ++ handle-ui + =/ fd !<(form-data:kaji vase) + =/ i input.fd + =/ tab-id (~(got by input.fd) 'tab') + =/ ui-card ~(. ui:kaji tab-id) + =/ origin (~(got by input.fd) 'origin') + |% + ++ run + ?+ action.fd `this + :: polls + %vote-poll + =/ soption (~(got by input.fd) 'option') + =/ uoption (dec:kaji soption ,[p=@p time=@da index=@ud]) + ?~ uoption (send-error 'format error') + =/ =pid:tp [p.u.uoption time.u.uoption] + =/ index index.u.uoption + =. polls (vote-poll:hd pid index) + :_ this + %- route:kaj [route:router [%kaji tab-id %redi (~(got by input.fd) 'origin')] state] + :: radio + %add-radio-chat + =/ input (~(got by input.fd) 'input') + ?: .=('' input) (send-error 'no input') + =/ stype (~(got by input.fd) 'type') + ?: .=(stype 'urb') + =/ sowner (~(got by input.fd) 'owner') + =/ sip (slaw %p sowner) + ?~ sip ~& "error-parsing-radio-owner" `this + (radio-chat u.sip input) + ?: .=(stype 'our') + =/ station (~(got by input.fd) 'name') + (bstv-chat station input) + `this + + %change-radio + =/ jon=json + [%s 'lol'] + + :_ this :_ ~ + %+ ui-fact:kaji tab-id :_ ~ + [%custom *manx jon] + %add-chat + :_ this :_ ~ + =/ input (~(get by input.fd) 'input') + ?~ input (alert:ui-card "No input, please report to site@spandrell.ch or ~docteg-mothep") + =/ parsed (text-to-content:hd u.input) + ?~ parsed (alert:ui-card "Text parsing failed, please report to site@spandrel.ch or ~docteg-mothep") + (send-message:hd u.parsed) + %add-thread + =/ is-blog ?= ^ (~(get by input.fd) 'is-blog') + =/ is-edit ?= ^ (~(get by input.fd) 'editing') + =/ try-title ?: is-blog validate-blog validate-thread + ?: ?=(%err -.try-title) (send-error +.try-title) + =/ [title=@t tags=(set @t)] +.try-title + =/ try-post (post-or-edit tags) + ?: ?=(%err -.try-post) + (send-error +.try-post) + (go-save-thread title +.try-post is-blog is-edit) + %add-reply + =/ is-blog ?= ^ (~(get by input.fd) 'is-blog') + =/ parents (dec-i:kaji i 'parents' ,[pid:tp pid:tp]) + ?~ parents (send-error 'parent cue error, please report to ~docteg-mothep or site@spandrell.ch') + =/ try-post (post-or-edit ~) + ?: ?=(%err -.try-post) + (send-error +.try-post) + (go-save-reply +.try-post -.u.parents +.u.parents is-blog) + + %del-thread + =/ is-blog ?= %~ (~(get by input.fd) 'is-blog') + =/ pid (dec-i:kaji input.fd 'pid' pid:tp) + ?~ pid (send-error 'no id to delete') + =/ ted (get:torm:tp threads u.pid) + ?~ ted (send-error 'thread-not-found') + =. feed +:(del:gorm:tp feed u.pid) + =. threads +:(del:torm:tp threads u.pid) + =/ last-reply ?~ replies.u.ted u.pid i.replies.u.ted + =. active-threads + +:(del:porm:tp active-threads last-reply) + =. feed +:(del:gorm:tp feed u.pid) + =. paths (~(del by paths) path.u.ted) + =. tags (del-in-tags:hd tags.u.ted u.pid) + :_ this + ?: is-blog + %- route:kaj [route:router [%kaji tab-id %redi '/'] state] + %- route:kaj [route:router [%kaji tab-id %redi '/board'] state] + + %del-reply + =/ pid (dec-i:kaji input.fd 'pid' pid:tp) + ?~ pid (send-error 'no id to delete') + =/ p (get:gorm:tp feed u.pid) + ?~ p (send-error 'post-not-found') + ?~ parent.u.p (send-error 'comment parent not set') + =. feed +:(del:gorm:tp feed u.pid) + =/ par (get:gorm:tp feed u.parent.u.p) + =. feed ?~ par feed + =/ nc (~(del in children.u.par) u.pid) + =/ np u.par(children nc) + (put:gorm:tp feed u.parent.u.p np) + :: branch whether it's the last reply or not as it affects the active-threads + =/ ted (get:torm:tp threads thread.u.p) + ?~ ted (send-error 'thread-not-found') + =/ nr %+ skip replies.u.ted |= p=pid:tp .=(u.pid p) + ?~ replies.u.ted (send-error 'weird') + =/ last i.replies.u.ted + =/ is-last=? .=(last u.pid) + ?. is-last + =/ nted u.ted(replies nr) + =. threads (put:torm:tp threads thread.u.p nted) + :_ this + %- route:kaj [route:router [%kaji tab-id %redi (~(got by input.fd) 'origin')] state] + :: + =/ nr t.replies.u.ted + =/ nted u.ted(replies nr) + =/ penultimo ?~ nr thread.u.p i.nr + =. threads (put:torm:tp threads thread.u.p nted) + =. active-threads +:(del:porm:tp active-threads u.pid) + =. active-threads (put:porm:tp active-threads penultimo thread.u.p) + :_ this + %- route:kaj [route:router [%kaji tab-id %redi (~(got by input.fd) 'origin')] state] + == + ++ validate-blog + =/ stitle (~(get by input.fd) 'title') + ?~ stitle :- %err 'Please enter a title for the thread' + ?: .=('' u.stitle) :- %err 'Please enter a title for the thread' + =/ stags (~(get by input.fd) 'tags') + ?~ stags :- %err 'No tags, please report to ~docteg-mothep or site@spandrell.ch' + =/ ntags (parse-tags:ui u.stags) + ?~ ntags :- %err 'Error parsing tags, please report' + =/ ttags (~(put in u.ntags) 'blog') + =. ttags (~(del in ttags) '') + [%ok u.stitle ttags] + + ++ validate-thread + =/ stitle (~(get by input.fd) 'title') + ?~ stitle :- %err 'Please enter a title for the thread' + ?: .=('' u.stitle) :- %err 'Please enter a title for the thread' + =/ sboard (~(get by input.fd) 'board') + ?~ sboard :- %err 'No board, please report' + =/ stags (~(get by input.fd) 'tags') + ?~ stags :- %err 'No tags, please report to ~docteg-mothep or site@spandrell.ch' + =/ ntags (parse-tags:ui u.stags) + ?~ ntags :- %err 'Error parsing tags, please report' + =/ board (~(get by categories:const) u.sboard) + ?~ board :- %err 'No category, please report' + =/ ttags (~(put in u.ntags) u.sboard) + =. ttags (~(del in ttags) '') + [%ok u.stitle ttags] + + ++ post-or-edit + |= ntags=(set @t) + =/ stext (~(get by input.fd) 'text') + =/ upoll find-poll + =/ cl (build-content stext upoll) + ?: ?=(%err -.cl) cl + =/ sedit (~(get by input.fd) 'editing') + ?~ sedit :- %ok + :: TODO title! + (build-post:lib +.cl ntags [src.bowl now.bowl]) + + =/ edit-pid (dec:kaji u.sedit pid:tp) + ?~ edit-pid :- %err 'Edit cue error, please report to ~docteg-mothep or site@spandrell.ch' + =/ pedit (get:gorm:tp feed u.edit-pid) + ?~ pedit :- %err 'Post to edit not found, please report to ~docteg-mothep or site@spandrell.ch' + :- %ok (edit-post:lib u.pedit +.cl ntags now.bowl) + :: + ++ build-content + |= [text=(unit @t) poll=(unit poll:pols)] ^- (maybe:sr content-list:tp) + ?~ text + ?~ poll [%err 'no content!'] + :: only poll + =/ cl=content-list:tp (insert-poll:hd ~ u.poll) [%ok cl] + ?: .=(u.text '') ?~ poll [%err 'no content!'] + =/ cl=content-list:tp (insert-poll:hd ~ u.poll) [%ok cl] + :: have text + =/ contents (tokenize:ui u.text) + ?~ contents :- %err 'Parsing error, please report to ~docteg-mothep or site@spandrell.ch' + ?~ poll [%ok contents] + =/ cl=content-list:tp + (insert-poll:hd contents u.poll) [%ok cl] + + ++ send-error + |= [text=@t] + :_ this :_ ~ + =/ =manx ;span:"{(trip text)}" + %+ ui-fact:kaji tab-id + + =/ div (~(get by input.fd) 'error-div') + :_ ~ + ?~ div + [%alert manx 1.000] + [%swap manx u.div .y] + :: + ++ go-save-thread + |= [title=@t p=post:tp is-blog=? is-edit=?] + =/ s (save-thread:hd title p is-blog is-edit) + ?: ?=(%err -.s) (send-error +.s) + =. state +.s + =/ upoll find-poll + =. polls ?~ upoll polls (save-poll:hd u.upoll) + :_ this + %- route:kaj [route:router [%kaji tab-id %board-redi p] state] + :: TODO notify mentions + :: would need an agent for remote hark tho + ++ go-save-reply + |= [p=post:tp thread=pid:tp parent=pid:tp is-blog=?] + =. p (set-parents:lib p thread parent) + =/ s (save-reply:hd p thread parent is-blog) + ?: ?=(%err -.s) (send-error +.s) + =. state +.s + =/ upoll find-poll + =. polls ?~ upoll polls (save-poll:hd u.upoll) + :_ this + ?: is-blog + %- route:kaj [route:router [%kaji tab-id %blog-redi p] state] + %- route:kaj [route:router [%kaji tab-id %board-redi p] state] + :: TODO notify ships of their replies + :: + ++ bstv-chat + |= [name=@t input=@t] + =/ tower (~(get by here.tv) name) + ?~ tower `this + =/ contents (tokenize:ui input) + =/ post (build-post:lib contents ~ [src.bowl now.bowl]) + =/ station (~(get by schedule.u.tower) started.current.u.tower) + ?~ station `this + =. chat.u.station [post chat.u.station] + =. schedule.u.tower (~(put by schedule.u.tower) started.current.u.tower u.station) + =. here.tv (~(put by here.tv) name u.tower) + :_ this + %- route:kaj [route:router [%kaji tab-id %tv-chat name post] state] + ++ radio-chat + |= [p=@p t=@t] + =/ tower (~(get by urbit.tv) p) + ?~ tower `this + `this + + :: + ++ find-poll ^- (unit poll:pols) + :: =/ wal ~(. wall src.bowl) + :: ?~ (subscription-type:wal now.bowl) ~ + =/ stitle (~(get by input.fd) 'poll-title') + ?~ stitle ~ + ?: .=('' u.stitle) ~ + =/ opts=(list @t) + =| acc=(list @t) =| i=@ud + |- + =/ key %- crip "poll-opt-{(scow %ud i)}" + =/ opt (~(get by input.fd) key) + ?~ opt (flop acc) + =/ nacc [u.opt acc] + $(i +(i), acc nacc) + ?~ opts ~ + =/ smin-bet (~(get by input.fd) 'poll-min-bet') + ?~ smin-bet ~ + :: =/ min-bet ~ + :: TODO parse this + =/ sexpiry (~(get by input.fd) 'poll-expiry') + :: ?~ sexpiry ~ + =/ expiry ?~ sexpiry (add now.bowl ~d1) + =/ parsed (rush u.sexpiry html-datetime:parsing:sr) + ?~ parsed ~& "some weird html fuckery" (add now.bowl ~d1) + u.parsed + + =/ multiple=? + =/ smultiple (~(get by input.fd) 'poll-multiple') + :: actually this doesn't get sent at all if unchecked? + ?~ smultiple .n ?: .=(u.smultiple 'on') .y .n + + %- some %- new-poll:pols :* [src.bowl now.bowl] u.stitle expiry opts multiple == + + -- + + + + :: + ++ on-poke-noun + |= a=* + ?: ?=([%data-dump *] a) (sync-dump +.a) + ?: ?=(%gib a) give-batdev + ?> .=(src.bowl our.bowl) + :: ?: ?=(%sync a) poke-tasdev + ?: ?=(%tv-fix a) tv-fix + ?: ?=(%backup a) :_ this :_ ~ dump-state:hd + ?: ?=(%restore a) :- ~ this(state restore:hd) + ?: ?=(%sync-last a) :- ~ this(state read-last:hd) + ?: ?=(%kaji a) print-kaji + ?: ?=(%kick a) kick-kaji + :: loading blog data + ?: ?=(%rblog a) %- wrap load-blog:hd + ?: ?=(%rblog2 a) %- wrap load-blog-comments:hd + :: loading tianming data + ?: ?=(%rboard a) %- wrap load-tianming + ?: ?=(%rboard2 a) %- wrap load-tianming-replies + :: ?: ?=(%count a) log + ?: ?=(%check a) check + ?: ?=(%threads a) check-threads + ?: ?=(%athreads a) check-athreads + ?: ?=(%tags a) check-tags + ?: ?=([%tag tag=@t] a) (check-tag tag.a) + :: ?: ?=(%chcom a) check-comment + :: ?: ?=(%sample a) sample + ?: ?=(%pats a) pats + ?: ?=(%feed a) check-feed + ?: ?=(%radio a) get-radio + ?: ?=(%tw a) try-tw + ?: ?=([%check-thread *] a) (check-thread +.a) + :: fixes + ?: ?=([%fix-thread *] a) (fix-thread +.a) + ?: ?=([%dedup *] a) (dedup +.a) + ?: ?=([%scrub-ded *] a) (scrub +.a) + ?: ?=([%fix-active *] a) (fix-active +.a) + + ?: ?=(%sqlite a) dump-to-sqlite + ?: ?=(%licki a) init-lick + ?: ?=(%slick a) stop-lick + ?: ?=([%lick *] a) (send-lick +.a) + `this + :: + ++ init-lick + ~& "init lick" + :_ this :_ ~ + =/ note=note-arvo [%l %spin /'licker.sock'] + [%pass /lick/init %arvo note] + ++ stop-lick + :_ this :_ ~ + =/ note=note-arvo [%l %shut /'licker.sock'] + [%pass /lick/init %arvo note] + ++ send-lick + |= a=* + :_ this :_ ~ + =/ note=note-arvo [%l %spit /'licker.sock' %noun a] + [%pass /lick/init %arvo note] + + :: ++ insert-sql + :: """ + :: INSERT INTO posts(ts,author_id, title, content, snippet, url) + :: VALUES({tsn}, {author-idn}, {title}, {content}, {snippet}, {url}); + :: """ + :: ++ insert-sql2 + :: """ + :: INSERT INTO comments(ts,user_id, content, approved, comment_type, post_id, parent_id) + :: VALUES({tsn}, {user-idn}, {content}, {approved-n}, {type}, {post-idn}, {parent-idn}); + :: """ + :: ++ insert-sql3 + :: """ + :: INSERT INTO tags(tag) + :: VALUES({tsn}, {user-idn}, {content}, {approved-n}, {type}, {post-idn}, {parent-idn}); + :: """ + ++ dump-to-sqlite + :: posts + =/ count 0 + :: =/ l (tap:gorm:tp feed) + :: =/ res + :: |- + :: ?~ l ~ + :: ?: (gte count 20) ~ + :: =/ entry i.l + :: =/ poast val.entry + :: =/ is-blog (~(has in tags.poast) 'blog') + :: ?: is-blog + :: ~& >> poast=poast + :: =. count +(count) + :: $(l t.l) + :: $(l t.l) + :: threads + =/ l (tap:torm:tp threads) + =/ res + |- + ?~ l ~ + ?: (gte count 20) ~ + =/ entry i.l + =/ ted val.entry + =/ is-blog (~(has in tags.ted) 'blog') + ?: is-blog + ~& >> ted=ted + =. count +(count) + $(l t.l) + $(l t.l) + :: TODO prov + :: =/ tv-chat + :: =/ tvs (~(got by here.tv) 'spandrell-tv') + :: =/ sta (~(got by schedule.tvs) started.current.tvs) + :: chat.sta + :: =/ data=dump-type [(tap:gorm:tp feed) (tap:torm:tp threads) active-threads paths tags tv-chat] + :: =/ vase !>((jam data)) + :: =/ =soba:clay :_ ~ [/data/site-dump/(scot %da now.bowl)/jam %ins %noun vase] + :: =/ =nori:clay [%& soba] + :: =/ =task:clay [%info %blog nori] + :: init + :: =/ note=note-arvo [%l %spit /'licker.sock' %noun 'ligma'] + + :: [%pass /lick/spit %arvo note] + `this + :: + ++ sync-dump + |= a=* + ~& dump-received=src.bowl + ?> .=(our.bowl ~batdev-docteg-mothep) + =/ data=dump-type (dump-type a) + =. feed (gas:gorm:tp *gfeed:tp feed.data) + =. threads (gas:torm:tp *threadsf threads.data) + =. active-threads at.data + =. paths paths.data + =. tags tt.data + `this + ++ give-batdev + ~& sync-req-received=src.bowl + ?> .=(our.bowl ~tasdev-docteg-mothep) + ?> .=(src.bowl ~batdev-docteg-mothep) + ~& sync-req-received=src.bowl + =/ tv-chat + =/ tvs (~(got by here.tv) 'spandrell-tv') + =/ sta (~(got by schedule.tvs) started.current.tvs) + chat.sta + ~& "tv" + =/ data=dump-type [(tap:gorm:tp feed) (tap:torm:tp threads) active-threads paths tags tv-chat] + :_ this :_ ~ + [%pass /gib %agent [~batdev-docteg-mothep %boke] %poke %noun !>([%data-dump data])] + ++ poke-tasdev + ~& "poking tasdev" + :_ this :_ ~ + [%pass /gib %agent [~tasdev-docteg-mothep %boke] %poke %noun !>(%gib)] + ++ tv-fix + =/ muh (~(got by here.tv) 'Spandrell TV') + =. here.tv (~(del by here.tv) 'Spandrell TV') + =. here.tv (~(put by here.tv) 'spandrell-tv' muh) + `this + ++ fix-thread |= a=* + =/ =pid:tp ;; pid:tp a + =/ thread (got:torm:tp threads pid) + =/ post (got:gorm:tp feed pid) + =/ fn=full-node:tp (node-to-full:plib post feed) + =/ flat (flatten-fn:plib fn) + =/ pids %+ turn flat |= p=post:tp [author.p id.p] + =/ ordered %+ sort pids |= [a=pid:tp b=pid:tp] (gth id.a id.b) + =. replies.thread ordered + =. threads (put:torm:tp threads pid thread) + `this + ++ fix-active |= a=* + =/ =pid:tp ;; pid:tp a + =. active-threads +:(del:porm:tp active-threads pid) + `this + ++ check-thread |= a=* + =/ =pid:tp ;; pid:tp a + =/ ted (get:torm:tp threads pid) + ~& >> ted=ted + `this + ++ scrub |= a=* + =/ =pid:tp ;; pid:tp a + =/ ted (got:torm:tp threads pid) + ~& >> ted=ted + =. replies.ted + =/ l replies.ted + =| nl=(list pid:tp) + |- + ?~ l (flop nl) + =/ muh i.l + =/ pst (get:gorm:tp feed muh) + ?~ pst $(l t.l) + $(l t.l, nl [muh nl]) + =. threads (put:torm:tp threads pid ted) + `this + ++ dedup |= a=* + =/ =pid:tp ;; pid:tp a + =/ ted (got:torm:tp threads pid) + ~& >> ted=ted + =. replies.ted + =/ l replies.ted + =| nl=(list pid:tp) + |- + ?~ l (flop nl) + =/ muh i.l + =/ pidset (silt t.l) + ?: (~(has in pidset) muh) $(l t.l) + $(l t.l, nl [muh nl]) + ~& new=replies.ted + `this +++ try-tw + :_ this :_ ~ + [%pass /tw-test %arvo %k %fard q.byk.bowl %tw %noun !>([%user 'spandrell4'])] + ++ get-radio + :_ this :_ ~ watch-radio-card:hd + ++ print-kaji + =/ a %+ turn ~(tap by sup.bowl) + |= [=duct [=ship =path]] + ~& > duct + ~& >>> ship + ~& >> path + duct + `this + ++ wrap + |= s=_state =. state s `this + ++ kick-kaji + :: =/ cards %+ turn ~(tap by sup.bowl) + + :: |= [=duct [=ship =path]] + :: ~& > duct + :: ~& >>> ship + :: ~& >> path + =/ paths=(list path) ~[/ui /sse/(scot %p our.bowl)] + =/ cards :_ ~ [%give %kick paths ~] + ~& kicking=cards + [cards this] + ++ check-feed + ~& %+ roll (tap:gorm:tp feed) |= [[=pid:tp =post:tp] a=(list pid:tp)] + ?. (~(has in tags.post) 'blog') a [pid a] + `this + ++ pats + ~& > paths + `this + ++ check-tags + ~& tags=tags + `this + ++ check-tag + |= t=@t + :: ~& (~(get by tags) t) + =/ pids (~(get by tags) t) + ?~ pids ~& "not found" `this + =/ a %+ turn (tap:porm:tp u.pids) |= [=pid:tp p=pid:tp] + =/ ted (get:torm:tp threads pid) + ?~ ted ~& ted-not-found=pid ~ + ~& > thread=[title.u.ted] + ~ + `this + ++ check + =/ last (pry:gorm:tp feed) + ~& > last=last + `this + ++ check-threads + =/ t %+ turn (scag 10 (tap:torm:tp threads)) |= [pid:tp thread:tp] + ~& > thread=[title path (lent replies)] ~ + `this + ++ check-athreads + =/ t %+ turn (scag 2 (tap:torm:tp threads)) |= [pid:tp thread:tp] + ~& > thread=[title (lent replies)] ~ + `this + ++ check-comment + :: =/ last (pry:orm:tp blog) + :: ?~ last `this + :: ?~ parent.val.u.last `this + :: =/ parent (get:orm:tp blog u.parent.val.u.last) + :: ~& > last=last + :: ~& >> parent=parent + `this + ++ sample + :: ~& >> %+ scag 3 %+ skim (tap:orm:tp blog) + :: |= [=id:tp =post:tp] ?=(%~ parent.post) + `this + ++ log + :: ~& %- lent (tap:orm:tp blog) + `this + ++ load-tianming + =/ j .^(json %cx /(scot %p our.bowl)/blog/(scot %da now.bowl)/data/threads/json) + =/ jjj (boardpost:de:js j) + |- + ?~ jjj state + =/ a=read-boardpost i.jjj + =/ author ?: .=((cass (trip author.a)) "spandrell") ~docteg-mothep + (add (bex 64) author.a) + =/ pid [author date.a] + =/ c (put:corm:tp *content-map:tp date.a content.a) + =| p=post:tp + =. p %= p + id date.a + author -.pid + thread pid + parent ~ + contents c + tags (silt `(list @t)`~['oldtianming']) + == + =/ s (save-thread:hd title.a p .n .n) + =. state ?: ?=(%err -.s) state +.s + $(jjj t.jjj) + + ++ load-tianming-replies + =/ j .^(json %cx /(scot %p our.bowl)/boke/(scot %da now.bowl)/data/replies/json) + =/ jjj (boardpost:de:js j) + |- + ?~ jjj state + =/ a=read-boardpost i.jjj + =/ author ?: .=((cass (trip author.a)) "spandrell") ~docteg-mothep + (add (bex 64) author.a) + =/ pid [author date.a] + =/ thread-author ?: .=((cass (trip op.a)) "spandrell") ~docteg-mothep + (add (bex 64) op.a) + =/ thread-pid [thread-author thread.a] + =/ c (put:corm:tp *content-map:tp date.a content.a) + =| p=post:tp + =. p %= p + id date.a + author author + thread thread-pid + parent `thread-pid + contents c + == + =. state + =/ s (save-reply:hd p thread-pid thread-pid .y) + ?: ?=(%err -.s) state +.s + $(jjj t.jjj) + :: + + :: =/ one (put:gorm:tp feed pid p) + :: =. feed ?~ parent-post one + :: =/ parent-pid [author.u.parent-post parent.a] + :: =/ full-parent (get:gorm:tp feed parent-pid) + :: ?~ full-parent one + :: =/ oc children.u.full-parent + :: =/ nc (~(put in oc) pid) + :: =/ np u.full-parent(children nc) + :: (put:gorm:tp one parent-pid np) + :: =. tags =/ curr (~(get by tags) 'blog-comment') + :: =/ nl ?~ curr ~[pid] (snoc u.curr pid) + :: (~(put by tags) 'blog-comment' nl) + :: =/ l (tap:torm:tp threads) + :: |- + :: ?~ l `this + :: =/ t=thread:tp +.i.l + :: ?~ replies.t $(l t.l) + :: =/ del (del:torm:tp active-threads -.i.l) + :: =. active-threads ?~ -.del threads + :: (put:torm:tp +.del -.replies.t t) + :: $(l t.l) + + + ++ serve + ^- (quip card _this) + =/ order !<(eyre-order:kaji vase) + =/ address address.req.order + ~& >> address=address + ~& > req=url.request.req.order + ?: (~(has in banned-ips:const) address) `this + :: ~& >>> malicious-request-alert=req.order `this + :_ this + %- route:kaj + [route:router [%eyre order] state] +-- +++ on-peek +|= =(pole knot) +?+ pole ~ + [%x %manx %nav sip=@t ~] + =/ sip (slav %p sip.pole) + =. bowl bowl(src sip) + :- ~ :- ~ :- %noun !> + =/ nv nav(bowl bowl) ext:nv + [%x %chads sip=@t ~] + :- ~ :- ~ :- %noun !> + =/ sip (slav %p sip.pole) + =/ wal ~(. wall sip) + ?~ (subscription-type:wal now.bowl) .n .y +== +:: ~& on-peek=pole +:: =/ blog (~(got by feeds) %blog) +:: ?+ pole ~ +:: [%x %index ~] +:: =/ posts=(list full-node:tp) +:: %+ scag page-size +:: %- flop +:: %+ roll (tap:orm:tp blog) +:: |= [i=[=id:tp =post:tp] a=(list full-node:tp)] +:: ?~ parent.post.i [(node-to-full:plib post.i blog) a] a +:: ``[%noun !>(posts)] +:: [%x %post rest=*] +:: ~& > rest=rest.pole +:: =/ p (~(get by paths) rest.pole) +:: ?~ p ~ +:: =/ poast (got:orm:tp blog id.u.p) +:: =/ fn (node-to-full:plib poast blog) +:: ``[%noun !>(fn)] +:: :: [%x %search query=@ comments=@] +:: :: =/ with-comments .=(comments '1') +:: :: ~ +:: == +++ on-agent +|= [=wire =sign:agent:gall] +|^ + ?: ?=(%kick -.sign) resub + ?: ?=([%radio ~] wire) handle-radio + ?. ?=(%fact -.sign) `this + ?: ?=(%dm p.cage.sign) (handle-dm !<(memo:c q.cage.sign)) + ?. ?=(%channel-response p.cage.sign) `this + =/ res !<(r-channels:c q.cage.sign) + ?. ?=(%post +<.res) `this + =/ =flag:tlonc ->.res + :_ this + =/ r r-post.r-channel.res + ?- -.r + %set ?~ post.r ~ (route:kaj [route:router [%kaji '' %chat-msg flag +<.u.post.r] state]) + %reply ~ :: reply-count.reply-meta.r id-reply.r + %reacts ~ :: reacts.r :: map + %essay ~ :: wtf + == + ++ handle-dm + |= m=memo:c + :: validate TOTP and set cookie if so + `this + ++ handle-radio + ?. ?=(%fact -.sign) `this + =/ e !<(radio-event q.cage.sign) + ?. ?=(%response -.e) `this + =. urbit.tv minitowers.e `this + + ++ resub + :_ this + ?+ wire ~ + [%radio ~] :~(watch-radio-card:hd) + [%chat %updates ~] :~(watch-chat-card:hd) + == + + +-- +++ on-arvo + |= [=(pole knot) =sign-arvo] + |^ + ?: ?=([%lick %soak *] sign-arvo) + ?+ [mark noun]:sign-arvo `this + [%connect ~] ((slog 'socket connected' ~) `this) + [%disconnected ~] ((slog 'socket disconnected' ~) `this) + [%error *] ((slog leaf+"socket error {(trip ;;(@t noun.sign-arvo))}" ~) `this) + [%noun *] ((slog leaf+"socket noun {(trip ;;(@t noun.sign-arvo))}" ~) `this) + == + :: + ?: ?=([%arow *] +.sign-arvo) (handle-thread +>.sign-arvo) + ?. ?=([%behn %wake *] sign-arvo) `this + ?. ?=([%backup ~] pole) `this + :_ this :_ ~ dump-state:hd + :: + ++ handle-thread + |= s=(avow:khan cage) + ?: ?=(%| -.s) ~& "thread failed" `this + =/ devase !<(* +>.s) + :: ?: ?=(%& -.p.sign-arvo) `this + `this + -- +-- +|_ =bowl:gall +:: saving to state ++$ save-res +$% [%err err=@t] + [%ok p=_state] +== +++ save-thread +|= [title=@t p=post:tp is-blog=? is-edit=?] ^- save-res + =/ post-pid [author.p id.p] + =. feed (put:gorm:tp feed post-pid p) + =/ pat ?: is-blog + (make-blogpost-path:lib id.p title) + (make-board-path:lib paths title tags.p) + =/ t ?. is-edit *thread:tp (got:torm:tp threads post-pid) + =/ snip-size ?: is-blog 500 200 + =/ snip (abbreviate-post:plib contents.p snip-size) + =. t t(title title, path pat, pid post-pid, tags tags.p, snip snip) :: TODO remove titles from posts + =. threads (put:torm:tp threads post-pid t) + =. active-threads (put:porm:tp active-threads post-pid post-pid) + =. tags (save-tags tags.p post-pid) + =. paths (~(put by paths) pat post-pid) + :- %ok state +++ save-reply +|= [p=post:tp thread=pid:tp parent=pid:tp blog=?] ^- save-res + =. p (set-parents:lib p thread parent) + =/ post-pid [author.p id.p] + =/ pop (get:torm:tp threads thread) + ?~ pop [%err 'thread op not found please report to ~docteg-mothep or site@spandrell.ch'] + =/ ppar (get:gorm:tp feed parent) + ?~ ppar [%err 'parent not found, please report to ~docteg-mothep or site@spandrell.ch'] + =. feed (put:gorm:tp feed post-pid p) + =/ npar u.ppar(children (~(put in children.u.ppar) post-pid)) + =. feed (put:gorm:tp feed parent npar) + =/ has-reply (~(has in (silt replies.u.pop)) post-pid) + =/ nr ?: has-reply replies.u.pop [post-pid replies.u.pop] + =/ npop u.pop(replies nr) + =. threads (put:torm:tp threads thread npop) + =/ replies replies.u.pop + =/ last-reply ?~ replies thread i.replies + =/ delt (del:porm:tp active-threads last-reply) + =/ mmm ?~ -.delt ~& >>> thread-not-found-under-last-reply=post-pid ~ ~ + =. active-threads +:delt + =. active-threads (put:porm:tp active-threads post-pid thread) + :- %ok state +:: +++ save-tags +|= [ntags=(set @t) =pid:tp] ^- tags-table + =/ tag-list ~(tap in ntags) + |- ^- tags-table + ?~ tag-list tags + =/ curr (~(get by tags) i.tag-list) + =/ npids ?~ curr + (put:porm:tp *pidmap pid pid) + (put:porm:tp u.curr pid pid) + =/ nmap (~(put by tags) i.tag-list npids) + $(tag-list t.tag-list, tags nmap) + +++ del-in-tags +|= [ntags=(set @t) =pid:tp] ^+ tags + =/ tag-list ~(tap in ntags) + |- ^+ tags + ?~ tag-list tags + =/ curr (~(get by tags) i.tag-list) + =/ npids ?~ curr ~ +:(del:porm:tp u.curr pid) + =/ nmap (~(put by tags) i.tag-list npids) + $(tag-list t.tag-list, tags nmap) + +:: polls + +++ save-poll + |= p=poll:pols ^+ polls + (~(put by polls) [author.p time.p] p) + +++ insert-poll + |= [c=content-list:tp =poll:pols] ^+ c + =/ ref=block:tp :- %ref :+ %polls src.bowl + /(scot %p author.poll)/(scot %da time.poll) + (snoc c ref) + +++ vote-poll + |= [=pid:tp option=@ud] + =/ upoll (~(get by polls) pid) + ?~ upoll polls + =/ =poll:pols (add-vote u.upoll option) + (~(put by polls) pid poll) +++ add-vote + |= [=poll:pols option=@ud] ^+ poll + ?: ?=(%exc -.votes.poll) + =. p.votes.poll + (~(put by p.votes.poll) src.bowl option) + poll + :: + =. p.votes.poll + =/ curr (~(get by p.votes.poll) option) + =/ nmap=(map @p (set @ud)) + ?~ curr + %- malt ~[[src.bowl (silt ~[option])]] + :: + =/ my-votes=(unit (set @ud)) (~(get by u.curr) src.bowl) + ?~ my-votes + (~(put by u.curr) src.bowl `(set @ud)`(silt ~[option])) + (~(put by u.curr) src.bowl `(set @ud)`(~(put in u.my-votes) option)) + + (~(put by p.votes.poll) option nmap) + poll + :: + +:: +++ dump-state ^- card + :: TODO prov + =/ tv-chat + =/ tvs (~(got by here.tv) 'spandrell-tv') + =/ sta (~(got by schedule.tvs) started.current.tvs) + chat.sta + =/ data=dump-type [(tap:gorm:tp feed) (tap:torm:tp threads) active-threads paths tags tv-chat] + =/ vase !>((jam data)) + =/ =soba:clay :_ ~ [/data/site-dump/(scot %da now.bowl)/jam %ins %noun vase] + =/ =nori:clay [%& soba] + =/ =task:clay [%info %blog nori] + =/ note=note-arvo [%c task] + [%pass /dump/[dap.bowl] %arvo note] ++$ dump-type + $: feed=(list feed-pair) + threads=(list thread-pair) + at=pidmap + paths=pathmap + tt=tags-table + tv-chat=(list post:tp) + == + ++$ feed-pair [pid:tp post:tp] ++$ thread-pair [pid:tp thread:tp] +++ read-last ^+ state + ~& > "restoring" + =/ bp /(scot %p our.bowl)/blog/(scot %da now.bowl) + =/ f .^((list path) %ct (weld bp /data/site-dump)) + ?~ f state + =/ filename (rear f) + ~& [f filename] + =/ j .^(@ %cx (weld bp filename)) + ~& read-file=(end [0 100] j) + =/ cued (cue j) + =/ data ;;(dump-type cued) + ~& >>> lengths=[(lent feed.data) (lent threads.data)] + =/ tvs (~(got by here.tv) 'spandrell-tv') + =/ sta (~(got by schedule.tvs) started.current.tvs) + =. chat.sta tv-chat.data + =. schedule.tvs (~(put by schedule.tvs) started.current.tvs sta) + =. here.tv (~(put by here.tv) 'spandrell-tv' tvs) + %= state + feed (gas:gorm:tp *gfeed:tp feed.data) + threads (gas:torm:tp *threadsf threads.data) + active-threads at.data + paths paths.data + tags tt.data + == +++ restore ^+ state + ~& > "restoring" + =/ j .^(@ %cx /(scot %p our.bowl)/blog/(scot %da now.bowl)/data/site-dump/jam) + ~& read-file=(end [0 100] j) + =/ cued (cue j) + =/ data ;;(dump-type cued) + ~& >>> lengths=[(lent feed.data) (lent threads.data)] + =/ tvs (~(got by here.tv) 'spandrell-tv') + =/ sta (~(got by schedule.tvs) started.current.tvs) + =. chat.sta tv-chat.data + =. schedule.tvs (~(put by schedule.tvs) started.current.tvs sta) + =. here.tv (~(put by here.tv) 'spandrell-tv' tvs) + %= state + feed (gas:gorm:tp *gfeed:tp feed.data) + threads (gas:torm:tp *threadsf threads.data) + active-threads at.data + paths paths.data + tags tt.data + == +:: Cards +++ watch-radio-card ^- card +[%pass /radio %agent [~docteg-mothep %tower] %watch /towers] +++ watch-chat-card ^- card +[%pass /chat/updates %agent [our.bowl %channels] %watch /chat/(scot %p our.bowl)/chat] +++ watch-dms-card ^- card +[%pass /dm-root %agent [our.bowl %chat] %watch /] +++ watch-cards ^- (list card) +:~ watch-radio-card + watch-chat-card +== +++ root-path-card ^- card + [%pass /mmm %arvo %e %connect [~ /] dap.bowl] +++ init-cards ^- (list card) +:~ watch-radio-card + watch-chat-card + watch-dms-card + root-path-card + schedule-backup-card +== +++ schedule-backup-card ^- card + [%pass /backup %arvo %b %wait (add now.bowl ~h6)] + +++ init-state ^+ state +=. tv init-tv +:: =. state load-blog +:: =. state load-blog-comments +state +++ init-tv ^+ tv +=/ starting=@da now.bowl +=/ sta=tv-station :* + 'Dune Month!' + 'https://hydrogen.finnem.net/hls/live.m3u8' + starting + ~ + ~ + chat-welcome-post^~ + ~ +== +=/ schedule %- malt :_ ~ [starting sta] +=/ =bstv ['Spandrell TV' ~docteg-mothep ['Dune Month!' starting] schedule] +=. here.tv (~(put by here.tv) 'spandrell-tv' bstv) +tv + +++ chat-welcome-post ^- post:tp +=/ contents (tokenize:ui 'Welcome to Spandrell TV! Make yourself cozy') +(build-post:lib contents ~ [~docteg-mothep now.bowl]) +++ load-blog + =/ j .^(json %cx /(scot %p our.bowl)/blog/(scot %da now.bowl)/data/posts/json) + =/ jjj (poast:de:js j) + |- + ?~ jjj state + =/ a=read-post i.jjj + =/ pid [~docteg-mothep date.a] + =/ c (put:corm:tp *content-map:tp date.a contents.a) + =/ tgs (~(put in tags.a) 'blog') + =| p=post:tp + =. p %= p + id date.a + author -.pid + thread pid + contents c + tags tgs + == + =/ s (save-thread title.a p .y .n) + =. state ?: ?=(%err -.s) state +.s + $(jjj t.jjj) + +++ load-blog-comments + =/ j .^(json %cx /(scot %p our.bowl)/boke/(scot %da now.bowl)/data/comments/json) + =/ jj %+ sort (comment:de:js j) |= [a=read-comment b=read-comment] + (lth date.a date.b) + |- + ?~ jj state + =/ a=read-comment i.jj + =/ c (put:corm:tp *content-map:tp date.a contents.a) + =/ author ?: .=((cass (trip author.a)) "spandrell") ~docteg-mothep + (add (bex 64) author.a) + =/ pa ?: .=((cass (trip pa.a)) "spandrell") ~docteg-mothep + (add (bex 64) pa.a) + =/ pid [author date.a] + =/ ppid [pa parent.a] + =/ parent-post (get:gorm:tp feed ppid) + =/ parent=(unit pid:tp) ?~ parent-post ~& > no-parent=[author.a date.a pa.a parent.a title.a] ~ + `ppid + =/ op [~docteg-mothep post.a] + =| p=post:tp + =. p %= p + id date.a + author `@p`author + contents c + tags (sy ~['blog-comment']) + == + =. state ?~ parent state + =/ s (save-reply p op u.parent .y) + ?: ?=(%err -.s) state +.s + $(jj t.jj) + + +++ hi bowl +:: cards +:: ++ send-dm +:: |= who=@p +:: =/ input %- crip "Show me what you got" +:: =/ parsed (text-to-content input) +:: ~& parsed=parsed +:: ?~ parsed (alert-card:kaj "Text parsing failed") +:: =/ content=story:c +:: :_ ~ :- %inline :_ ~ u.parsed +:: =/ id [our.bowl now.bowl] +:: =/ =memo:c [content our.bowl now.bowl] +:: =/ delta [%add memo ~ ~] +:: =/ diff [id delta] +:: =/ a [who diff] +:: :* %pass +:: /send +:: %agent +:: [our.bowl %chat] +:: %poke +:: %chat-dm-action +:: !> a +:: == + +++ send-message +|= input=inline:c +=/ content=story:c +:_ ~ :- %inline :_ ~ input +=/ =memo:c [content src.bowl now.bowl] +=/ =kind-data:c [%chat ~] +=/ =essay:c [memo kind-data] +=/ cp=c-post:c [%add essay] +=/ cc=c-channel:c [%post cp] +=/ =nest:c [%chat our.bowl %chat] +=/ a=c-channels:c [%channel nest cc] +:* %pass + /send + %agent + [our.bowl %channels] + %poke + %channel-action + !> a +== + ++ text-to-content + %+ curr rush + |^ ;~ pose + (cook |=(=@t [%link t t]) turl) + text + == + ++ turl + =- (sear - text) + |= t=cord + ^- (unit cord) + ?~((rush t aurf:de-purl:html) ~ `t) + :: +text: text message body + :: + ++ text + (cook crip (plus next)) + -- +-- |