! Copyright (C) 2025 Serre
! See https://factorcode.org/license.txt for BSD license.
USING: accessors assocs http http.server monadics math
http.server.dispatchers kernel namespaces xml.syntax
sequences xml combinators arrays math.parser unicode strings
http.server.static io.sockets.secure io.servers 
   erinnemori-2.posts ! -- Post and topic abstractions
   erinnemori-2.users ! -- User management 
   erinnemori-2.logic ! -- Intermediate form processing
   erinnemori-2.utils ! -- Random utility words
   erinnemori-2.xml ; ! -- HTML Fragments
IN: erinnemori-2

SINGLETON: frontpage
M: frontpage call-responder* ( p resp -- req )
   2drop 
      "Erinne-Mori" f 
      user-header
      frontpage-xml
      erinne-tail
   erinne-common ;

SINGLETON: new-user
M: new-user call-responder* ( p resp -- req )
   2drop post-request?
      [ process-new-user new-user>req ]
      [ "Creating User..." f f 
        create-user-page erinne-tail
        erinne-common
      ]
   if ;

SINGLETON: log-in
M: log-in call-responder* 2drop process-login ;

SINGLETON: sign-out
M: sign-out call-responder* ( p resp -- req )
   2drop
      "Logging Out!" 
      "1;url=/" refresh-header 
      f "Logging out." >default f
   erinne-common 
   "NONE" "erinne-session" <cookie> put-cookie ;

TUPLE: board name ;
C: >b board
M: board call-responder* ( p resp -- req )
   name>> swap over
      [ f user-header ] 2dip
      process-board 
   erinne-common ;

SINGLETON: new-topic
M: new-topic call-responder* ( p resp -- req )
   2drop
      "New topic created!"
      process-topic
      f pick >default f 
   erinne-common ;

SINGLETON: new-reply
M: new-reply call-responder* ( p resp -- req )
   2drop
      "Reply sent!"
      process-reply
      f pick >default f 
   erinne-common ;

SINGLETON: view-tag
M: view-tag call-responder* ( p resp -- req )
   drop ?first [ "" ] unless*
      [ "Viewing Tag" f ] dip
         [ "Posts tagged: " prepend 
           <XML <span class="etc-button"> <-> </span> XML> ]
         [ tag-search ] bi
      back-link
   erinne-common ;

SINGLETON: add-rsrc
M: add-rsrc call-responder* ( p resp -- req )
   2drop
      "Resource Added!"
      process-rsrc
      f pick >default f 
   erinne-common ;

! ==  Core Dispatcher
: (<erinnemori>) ( -- dispatcher )
   t development? set
   <dispatcher> { 
      { frontpage ""          }
      {  new-user "new-user"  }
      {    log-in "login"     }
      {  sign-out "sign-out"  }
      { new-topic "new-topic" }
      { new-reply "new-reply" }
      {  view-tag "tag"       }
      {  add-rsrc "add-rsrc"  }
   } [ first2 add-responder ] each
   ! -- Boards:
   { {   "projects" "projects"   }
     { "dilletante" "dilletante" }
   } [ first2 [ >b ] dip
     add-responder ] each
   ! -- Other:
      "resource:www-data/static" <static> "static"
   add-responder
   ;

: <erinnemori>* ( -- server )
   (<erinnemori>) main-responder set-global 
   8080 httpd ;