! Copyright (C) 2025 Serre
! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs checksums checksums.sha csv
erinnemori-2.utils http http.server io.directories
io.encodings.utf8 io.files io.streams.string kernel math
math.parser monadics namespaces present random sequences ;
IN: erinnemori-2.users

CONSTANT: keyvalues 
   { "index" "name" "salt" "pass" }
CONSTANT: keyspath "resource:/www-data/users/"
: keyspile ( -- entries ) 
   keyspath qualified-directory-files keyvalues zip-pile ; 

: name-ok? ( string -- E-string )
   { { "Invalid characters in name." 
       [ alphanumeric? ] }
     { "Name is too long." 
       [ length 24 < ] }
     { "Name already in use."
       [ "name" keyspile pAt* not ] }
   } validate ;
  
: pass-ok? ( string -- E-string )
   { { "Password must be longer than 12 characters"
       [ length 12 > ] }
     { "Password can't be longer than 64 characters"
       [ length 64 < ] } } validate ;

: (<user>) ( name pass -- )
   [ random-32 present ] dip over append
      sha-256 checksum-bytes >array [ >hex ] map concat
   keyspile length present [ -roll ] keep 
   keyspath ".csv" surround 
   [ touch-file ] keep [ 4array ] dip
   utf8 [ write-row ] with-file-writer ;

: <user> ( name pass verify -- E-Error/User )
   [ = ] 2guard
   [ [ [ dupd (<user>) ] ] 2dip
        [ name-ok? <$> ] 
        [ pass-ok? <*> ] bi* ]
   [ 2drop "Passwords do not match" left ] if ;

: process-new-user ( -- E-Error/User )
   params get [ "erinne-user" of ]
              [ "erinne-pass" of ]
              [ "pass-verify" of ] tri
   <user> ;

INITIALIZED-SYMBOL: active-users [ V{ } ]

: by-user? ( request -- user/f ) 
   "erinne-session" get-cookie
   dup [ value>> string>number 
         active-users get-global at ] when ;

: get-session ( -- session-id/f )
   request get "erinne-session" get-cookie
   dup [ value>> string>number ] when ;

: bind-session ( user session-id -- )
   swap 2array [ prefix ] curry 
   [ active-users ] dip change-global ;

: deactivate-session ( session-id -- )
   active-users delete-at ;

:: correct-password? ( user pass -- user/f )
   keyspile "name" user pfilter* 
   [   [ "pass" of ]
       [ "salt" of ] bi 
   [ pass ] dip append
      sha-256 checksum-bytes 
      >array [ >hex ] map concat
   = [ user ] [ f ] if
   ] [ f ] if* ;

: login ( user pass -- cookie/f )
   correct-password? 
   [ [ 64 random-bits ] with-secure-random
     [ bind-session ] keep 
     number>string "erinne-session" <cookie>
   ] [ f ] if* ;