Paste: thread.cgi

#!/usr/bin/env cgi-factor
USING: arrays assocs byte-arrays calendar checksums
checksums.md5 classes.tuple continuations csv environment
formatting html.entities io io.encodings.string
io.encodings.utf8 io.monitors kernel math.parser multiline
namespaces peg.ebnf prettyprint sequences present
sequences.generalizations sorting splitting strings system
threads tools.annotations xml xml.syntax xml.writer ;
FROM: sets => diff ; 
IN: thread-cgi

: send-chunk ( string -- ) 
   [ utf8 encode length >hex print ] keep print flush ;

: terminate-chunks ( -- )
   "0\r\n\r\n" write ;

: posts-root ( -- path ) ! !!! Modify as needed.
   "resource:www/boards/" ;

: parse-cgi ( string -- assoc )
   "&" split [ "=" split ] map ;

: board-master ( -- path )
      posts-root 
      "QUERY_STRING" os-env parse-cgi "board" of
      ".csv"
   3append ;

: ?thread ( -- id/f )
   "QUERY_STRING" os-env parse-cgi "thread" of ;

:: thread-path ( id -- path )
   board-master "." id "#" "." surround replace ;

: thread-master ( -- path )
   ?thread thread-path ;

! TUPLE: post id timestamp name hash reply image sig ;
! C: <post> post
! : load-posts ( -- posts ) ! Useless?
!    thread-master utf8 file>csv [ post slots>tuple ] map ;

: special-user? ( hashcode -- string/f )
   "resource:www/tripfags.csv" utf8 file>csv at ;

DEFER: parse-post
: parse-nest ( string -- string )
   parse-post concat ;

SYMBOL: this-post
: parse-reply ( ast -- string ) 
   [ second >string ] [ concat >string ] bi
   over [ this-post get dup ] dip
   "<a href=\"#%s\">%s<script><!--
      replylink = document.createElement('a'); 
      replylink.href = '#%s'
   replylink.appendChild(document.createTextNode(\">>%s\"));
   document.getElementById('%s-replies').appendChild(replylink);
   --></script></a>" sprintf ;

: parse-yen ( ast -- string )
   2 over [ parse-nest ] change-nth concat
   "<span style=\"color:purple;\">%s</span><br/>" sprintf ;

: parse-spoiler ( ast -- string )
   >string parse-nest 
   "<span class=\"spoiler\">%s</span>" sprintf ;

: parse-code ( ast -- string )
   >string "<pre>%s</pre>" sprintf ;

: parse-quot ( ast -- string )
   >string parse-nest "<blockquote>%s</blockquote>" sprintf ;

: spoil-img ( string -- string )
   [ ] [ 1 head ] [ 1 tail* ] tri [ "(" = ] [ ")" = ] bi* and
      [ rest but-last "<img src=\"%s\" class=\"spoiler-img\" />"
        sprintf ]
      [ "<img src=\"%s\" />" sprintf ]
   if ;

: parse-imgs ( ast -- string )
   >string string>csv [ "" ]
   [ first 3 index-or-length head 
      [ spoil-img "<td>%s</td>" sprintf ] 
     map concat 
      "<div class=\"image-wrapper\">
       <table class=\"inline-images\"><tr>%s</tr></table>
       </div>"
     sprintf 
   ] if-empty ;

: parse-link ( ast -- string )
   concat dup "<a href=\"%s\" class=\"user-link\">%s</a>"
   sprintf ;

EBNF: parse-post
[=[ newln = ( "\n" | "\r" ) 
    space = ( " " | newln )
   newlnx = newln newln
            => [[ drop "<br/>" ]] 
    reply = "&gt;&gt;" [0-9]+ &(space)
            => [[ parse-reply ]]
      yen = newlnx "¥" (!("\n") .)+ &("\n")
            => [[ parse-yen ]]
     yen1 = newln "¥" (!("\n") .)+ &("\n")
            => [[ parse-yen ]]
  spoiler = "**"~ (!("**") .)+ "**"~
            => [[ parse-spoiler ]]
     code = "[code]"~ (!("[/code]") .)+ "[/code]"~
            => [[ parse-code ]]
     quot = "[quot]"~ (!("[/quot]") .)+ "[/quot]"~
            => [[ parse-quot ]]
     imgs = "[images{"~ (!("}]") .)+ "}]"~
            => [[ parse-imgs ]]
     link = ("http://" | "https://") (!(space) .)+ &(space)
            => [[ parse-link ]]
  special = ( code | quot | imgs | spoiler | reply | yen | yen1 | newlnx | link )
     else = (!(special) .)+ => [[ >string ]]
     main = ( special | else )*
]=]

: apply-markup ( string -- xml )
   html-escape "\n" 1surround parse-post concat 
   "<div>" "</div>" surround string>xml ;

:: normalize-post ( id time name topic hash body img sig
                  -- id time name topic hash body img sig )
! Lot of runtime effort, cache/memoize?
   id
      [ this-post set ] keep
   time 
      string>number seconds since-1970 >gmt
      present " GMT" append
   name 
      [ "Anonymous" ] when-empty
   topic
      [ "★" ] when-empty
   hash
      [ f ]
      [ md5 checksum-bytes >array [ >hex ] map concat
        dup special-user? 
          [ nip <XML <span class="viphash">#<-></span> XML> ]
          [ 8 head <XML <span class="hash">#<-></span> XML> ]
            ! 10 cut <XML <span class="hash">
            !   <ruby><-><rt><-></rt></ruby>
            ! </span> XML> ]
        if* ]
      if-empty
   body 
      apply-markup
   img
      [ f ] 
      [ spoil-img string>xml ]
!      [ <XML <img src=<-> align="left"/> XML> ]
      if-empty
   sig 
      [ f ] [ html-escape "\n" 1surround parse-post concat
              "<span class=\"sig\"><hr/>%s</span>" sprintf
              string>xml ]
      if-empty
   ;

:: <csv-reply> ( id time name topic hash reply img sig -- xml )
         id "#" prepend :> id-href
   id "-replies" append :> id-replies
   <XML <div class="replypost" id=<-id->>
      <div class="posthead">
         <a href=<-id-href-> class="post-id"><-id-href-></a>
         <span class="topic"><-topic-></span>
         <div class="posthead-right">
            <span class="postname"> <-name-> </span>
            <-hash->
         </div>
      </div> 
      <div class="postbody">
         <-img->
         <reply><-reply-></reply>
      </div>
      <div class="posttail">
         <i> <-time-> </i>
         <span class="sig"><-sig-></span>
         <div id=<-id-replies-> class="replies"></div>
      </div> 
   </div> XML> ;

: render-reply ( seq -- xml )
   8 ?firstn normalize-post <csv-reply> ;

INITIALIZED-SYMBOL: loaded-posts 
  [ ?thread [ thread-master utf8 file>csv ] [ f ] if ]

: render-posts ( -- string )
   loaded-posts get-global [ render-reply ] map
   [ xml>string ] map concat "\n<div id=\"thread\">\n" prepend ;

: load-new-replies ( monitor -- )
   dup next-change drop thread-master utf8 file>csv
      [ loaded-posts get-global diff [ render-reply ] map ]
      [ loaded-posts set-global ]
   bi xml>string send-chunk load-new-replies ;

: sort-ops ( -- posts )
   board-master utf8 file>csv [ third "" = ] filter
   [ second string>number ] inv-sort-by ;

: catalog-op ( post -- catalog-xml )
   [ first "/cgi-bin/board.cgi?" "QUERY_STRING" os-env 
     "&thread=" 3array concat prepend ]
   [ first thread-path utf8 file>csv 
     [ length ] [ first ] [ last ] tri
     pick 1 = 
         [ drop render-reply f ]
         [ [ render-reply ] bi@ ]
     if ] bi
   <XML 
      <div class="cat-wrap">
      <div class="cat-entry" style="position:relative;">
      <a href=<-> target="_parent"
         style="position:absolute;top:0;left:0;
         height:100%;width:95%;display:block;
         z-index:999;">
      </a>
   <p class="post-count">(<-> Posts)</p>
   <div class="op"><-></div>
   <div class="reply"><-></div>
   </div> </div> XML> ;

: render-ops ( -- string )
   sort-ops [ catalog-op ] map 
   <XML <div class="catalog"><-></div> XML>
   pprint-xml>string ;

: reload-catalog ( monitor -- )
   dup next-change 100 milliseconds sleep drop
   render-ops send-chunk reload-catalog ;

: heartbeat-loop ( -- )
   30 seconds sleep
   "<!-- =^.w.^= -->" [ send-chunk ] [ quit ] recover 
   heartbeat-loop ;

! == Script Proper:
   "Content-type: text/html; charset=utf8"
print
   "X-Content-Type-Options: nosniff"
print
   "Connection: keep-alive"
print
   "Transfer-Encoding: chunked\r\n" 
print
   <XML <head>
      <link rel="stylesheet" href="/static/style.css"/>
   </head> XML> xml>string send-chunk 
   [ heartbeat-loop ] "Heartbeat" spawn drop
   ?thread 
       [ render-posts send-chunk 
         [ thread-master f [ load-new-replies ] with-monitor ]
         with-monitors ]
       [ "\n<body id=\"cats\">" send-chunk
                   render-ops send-chunk
         [ board-master f [ reload-catalog ] with-monitor ]
         with-monitors ]
   if