! Copyright (C) 2025 Serre
! See https://factorcode.org/license.txt for BSD license.
USING: accessors assocs calendar combinators csv prettyprint
http http.server kernel formatting generalizations present
math.parser namespaces words io.sockets xml xml.syntax
sequences unicode arrays math
erinnemori-2.posts
erinnemori-2.users
erinnemori-2.markdown
erinnemori-2.utils ;
IN: erinnemori-2.xml
: erinne-common ( title meta nav body tail -- response )
<XML <html>
<head> <title> <-> </title>
<link rel="stylesheet"
href="/static/vernis.css"
/>
<link rel="icon"
href="/static/tank-putit.gif" />
<->
</head>
<body> <-> <hr/>
<-> <hr/>
<->
</body> </html> XML> xml>response ;
: refresh-header ( string -- xml )
<XML <meta http-equiv="refresh" content=<-> /> XML> ;
: back-link ( -- xml )
<XML <div class="etc-button" id="backlink">
<a href="javascript:window.history.back();">
<< Return </a> </div> XML> ;
: user-header ( -- xml )
request get
by-user? [ <XML <span> <p class="username" > User: <-> </p>
<a href="/sign-out"
class="interact" >
Sign Out? </a> </span> XML> ]
[ <XML <form method="post" action="/login" >
<label> Username: <input name="erinne-user"/> </label>
<label> Password: <input type="password"
name="erinne-pass"/> </label>
<button class="interact"> Log In </button>
<a href="/new-user" class="interact"> Sign Up </a> </form>
XML> ]
if*
<XML <div id="userbar"> <->
<span id="nav">
<a class="nav-button" href="/">Frontpage</a>
<a class="nav-button" href="/projects">Projects</a>
<a class="nav-button" href="/dilletante">Dilletantism</a>
</span>
</div> XML> ;
: >m ( string -- xml )
<XML <div class="message"><-></div> XML> ;
: >default ( string -- xml )
<XML <div class="default"><span class="default-m">
<->
</span> </div> XML> ;
: frontpage-xml ( -- xml )
<XML <div class="default">
<h1><img src="/static/sister.gif" />
<i>Erinnemori</i></h1>
<p> <b> A shared index of Projects and Interests: </b>
</p>
<div id="projects">
<img src="/static/projects.gif" />
<a href="/projects/">Projects</a> <br/>
<i> Directed pursuits, both technical and artistic. </i>
</div>
<div id="dilletantism" align="right">
<a href="/dilletante/">Dilletantism</a>
<img src="/static/dilletanteism.gif" /> <br/>
<i> Idle learning, discussion, and hobbyism. </i>
</div>
</div> XML> ;
: create-user-page ( -- xml ) <XML
<div class="default" id="userbar">
<h1><i><img src="/static/sister.gif" /> Sign up:</i></h1>
<form method="post" action="/new-user" id="new-user"> <fieldset>
<label> Username: <input required="true"
name="erinne-user"/>
</label><br/>
<small> Characters can be alphanumeric + "-_.~" <br/>
Must be under 24 characters </small> <br/>
<legend>
</legend>
<label> Password: <input type="password"
required="true"
minlength="12"
name="erinne-pass"/> </label><br/>
<small> Must be between 12 and 64 characters </small> <br/>
<label> Verify Password: <input type="password"
required="true"
name="pass-verify"/> </label><br/>
<small>
We can't send recovery e-mails,
be sure to keep your password safe. <br/>
</small>
<button> Sign up </button>
</fieldset></form> </div> XML> ;
M: object present unparse ;
: see-variables ( -- xml )
params request [ get ] bi@
remote-address get
<XML <div> PARAMS: <p> <-> </p>
REQEST: <p> <-> </p>
IP: <p> <-> </p> </div> XML> ;
: erinne-tail ( -- xml ) f ;
: validate-img ( string -- xml )
! >doesn't actually vaidate anything
dup empty? not
[ <XML <div class="image-wrapper">
<img src=<-> />
</div> XML> ]
[ drop f ] if ;
: format-resources ( resources -- xml )
[ first2 dupd
[ [ length 48 > ] [ 45 head "..." append ] 1when ] dip
<XML <tr><td><a href=<-> ><-></a></td> <td><-></td>
</tr> XML> ] map
<XML <table><-></table> XML> ;
: new-resource-form ( topic-alist -- xml )
get-session active-users get-global at
over "admin" of = [
[ "index" of ] [ "board" of ] bi
<XML <form action="/add-rsrc" method="post">
<input type="hidden" name="topic" value=<-> />
<input type="hidden" name="board" value=<-> />
<input type="text"
name="link"
placeholder="(Link to resource)"
required="true"/>
<input type="text"
name="desc"
placeholder="(Description)"
required="true"/>
<button> Add Resource </button>
</form> XML>
] [ drop "" ] if ;
: tag-format ( tag -- xml )
[ "/tag/" prepend ] keep
<XML <a href=<->><-></a> XML> ;
: reply-slot ( index -- script )
"<div id=\"%s-replies\" class=\"replies-of\"></div>"
sprintf string>xml ;
: post-tstamp ( string -- timestamp )
string>number seconds since-1970 >gmt present
" GMT" append <XML <div class="timestamp"> <-> </div> XML> ;
: post>data ( post-alist -- id id author title images body r-slot time tags )
{ [ "index" of ]
[ "index" of this-post set ]
[ "index" of ]
[ "author" of ]
[ "title/f" of [ empty? ] [ drop "★" ] 1when ]
[ "images" of validate-img ]
[ "body" of apply-markup ]
[ "date" of post-tstamp ]
[ "index" of reply-slot ]
[ "tags" of string>csv concat
[ tag-format ] map ]
} cleave ;
: post-as-op ( post-alists topic-alist -- xml )
[ first post>data [ rot ] 5 ndip ]
[ [ topic>resources* format-resources ]
[ new-resource-form ] bi
] bi* rot
<XML <div id=<-> class="post">
<div class="post-header">
<span class="author"><span><-></span></span>
<span class="title"><span><-></span></span>
<span class="post-id"><span>#<-></span></span>
</div>
<div class="post-content"> <div class="interior">
<-> <-> <-> <->
</div></div>
<div id="resources"> <-> <-> </div>
<div class="post-footer"> <-> </div>
</div> XML> ;
: post-as-reply ( post-alist -- xml )
post>data [ rot ] 5 ndip
<XML <div class="post" id=<-> >
<div class="post-header">
<span class="author"><span><-></span></span>
<span class="title"><span><-></span></span>
<span class="post-id"><span>#<-></span></span>
</div>
<div class="post-content"> <div class="interior">
<-> <-> <-> <->
</div></div>
<div class="post-footer"> <-> </div>
</div> XML> ;
: topic>thread ( board topic -- xml )
swap [ posts-in ] [ topic-data ] 2bi
[ post-as-op ] keepd
rest [ post-as-reply ] map swap prefix
<XML <div id="thread">
<div id="framing">
<img id="frame-l" src="/static/frame-l.gif" />
<img id="frame-r" src="/static/frame-l.gif"
style="transform: scaleX(-1) ;
right: 0 ; " />
</div>
<div id="thread-channel"> <-> </div>
</div> XML> ;
: new-reply-form ( board topic -- xml )
request get by-user?
[ get-session
<XML <div class="new-reply">
<form action="/new-reply" method="post">
<input type="hidden" name="board" value=<-> />
<input type="hidden" name="topic" value=<-> />
<input type="hidden" name="session" value=<->/>
<input type="text"
placeholder="Title (optional)"
name="title" /> <br/>
<textarea name="body"
required="true"
style="width: 440px ; height: 240px ;"
placeholder="Description..."></textarea> <br/>
<label for="tags"> Tags: </label>
<input type="text"
placeholder="Comma, Separated, Tags (Optional)"
name="tags" /> <br/>
<label for="images"> Image: </label>
<input type="text"
placeholder="http://example.com/example.png (Optional)"
name="images" /> <br/>
<button> Reply </button>
</form> </div> XML>
] [ 2drop "Must be logged-in to reply" >m ] if ;
: topic>title-card ( topic-alist -- xml )
{ [ "title" of ] [ topic-link* ] } cleave
[XML <div class="topic"> <b><-></b> -
<a href=<-> >View Thread</a>
</div> XML] ;
: topics>board ( topic-alists -- xml )
[ topic>title-card ] map concat
<XML <div id="index"><-></div> XML> ;
: new-topic-form ( board -- xml )
request get by-user?
[ get-session
<XML <form action="/new-topic"
method="post"
class="new-reply">
<input type="hidden" name="board" value=<-> />
<input type="hidden" name="session" value=<->/>
<label for="topic"> Create New Topic: </label>
<input type="text"
required="true"
placeholder="Topic"
name="topic" /> <br/>
<textarea name="body"
style="width: 440px ; height: 240px ;"
required="true"
placeholder="Description..."></textarea> <br/>
<label for="tags"> Tags: </label>
<input type="text"
placeholder="Comma, Separated, Tags (Optional)"
name="tags" /> <br/>
<label for="images"> Image: </label>
<input type="text"
placeholder="http://example.com/example.png (Optional)"
name="images" /> <br/>
<button> New Topic </button>
</form> XML>
] [ drop "Must be logged-in to add a new topic" >m ] if ;
: render-post-link ( post-link -- xml )
first2 swap post-as-reply
[ "location.href='" "';" surround ] dip
<XML <div onclick=<-> style="cursor:pointer;" >
<->
</div>
XML> ;
: tag-search ( tag -- xml )
! weird lingering empty tag when doing this
<tag [ render-post-link ] map
<XML <div id="thread">
<div id="framing">
<img id="frame-l" src="/static/frame-l.gif" />
<img id="frame-r" src="/static/frame-l.gif"
style="transform: scaleX(-1) ;
right: 0 ; " />
</div>
<div id="thread-channel"> <-> </div>
</div> XML> ;