730 lines
27 KiB
Racket
730 lines
27 KiB
Racket
#lang racket/base
|
|
|
|
; Notepad application
|
|
(require
|
|
"templates.rkt"
|
|
"../webcontainer/weblets.rkt"
|
|
"../webcontainer/weblet-parameter.rkt"
|
|
"../notepad/notepad.rkt"
|
|
"../notepad/user.rkt"
|
|
"../notepad/notes.rkt"
|
|
"../../configuration.rkt"
|
|
web-server/http/redirect
|
|
web-server/http/request-structs
|
|
net/cookies/server
|
|
net/uri-codec
|
|
)
|
|
|
|
(provide
|
|
pages:notepad:page-list
|
|
pages:notepad:page-show
|
|
pages:notepad:page-edit
|
|
pages:notepad:page-delete
|
|
pages:notepad:preview
|
|
pages:notepad:media-list
|
|
pages:notepad:media-show
|
|
pages:notepad:media-new
|
|
pages:notepad:media-edit
|
|
pages:notepad:media-delete
|
|
pages:notepad:user-list
|
|
pages:notepad:user-show
|
|
pages:notepad:user-login
|
|
pages:notepad:user-logout
|
|
pages:notepad:user-edit
|
|
)
|
|
|
|
; Notepad
|
|
(define notepad (make-notepad configuration:notepad:path))
|
|
|
|
; Secured : either protocol is https or dev mode is active
|
|
(define (check-secured? param)
|
|
(or configuration:notepad:dev?
|
|
(eq? 'https (weblet-parameter-protocol param))))
|
|
|
|
; Cookie management
|
|
; Cookie key
|
|
(define *cookie-key* "notepad")
|
|
; User from weblet parameter
|
|
(define (get-user param)
|
|
(define cookie (weblet-parameter-cookie-ref param *cookie-key*))
|
|
; Precondition: check-secured? must be #t
|
|
(and (check-secured? param)
|
|
cookie (get-user-by-usercookie-value (string->bytes/utf-8 cookie))))
|
|
|
|
; Error pages
|
|
; Type to code + title + message
|
|
(define *error-types*
|
|
(make-immutable-hash
|
|
'((not-found . (404 "Not found" "Sorry, there is nothing here."))
|
|
(unauthorized . (401 "Unauthorized" "Sorry, you can't go there."))
|
|
(method-not-allowed . (405 "Not allowed" "Sorry, this method is not allowed."))
|
|
)))
|
|
; As page
|
|
(define (pages:notepad:error param error-type)
|
|
(define err (hash-ref *error-types* error-type))
|
|
((pages:template
|
|
#:error-code (car err)
|
|
#:author (number->string (car err))
|
|
#:title (cadr err)
|
|
#:content `(article ,(caddr err))
|
|
)
|
|
param))
|
|
; As result for pages:adaptable-template
|
|
(define (notepad:error error-type)
|
|
(define err (hash-ref *error-types* error-type))
|
|
(make-immutable-hash
|
|
`((error-code . ,(car err))
|
|
(author . ,(number->string (car err)))
|
|
(title . ,(cadr err))
|
|
(content . (article ,(caddr err)))
|
|
)))
|
|
|
|
; Notepad pages
|
|
|
|
; Link to a note with a given name
|
|
(define (note-link type name . args)
|
|
(string-append
|
|
(case type
|
|
((show) "/notes/show/")
|
|
((edit) "/notes/edit/")
|
|
((delete) "/notes/delete/")
|
|
(else ""))
|
|
(uri-encode name)
|
|
(apply string-append args)))
|
|
|
|
; /notes/list
|
|
; Lists all the pages of the notepad.
|
|
(define pages:notepad:page-list
|
|
(pages:template
|
|
#:title "Pages du bloc-note."
|
|
#:author "feuforeve.fr"
|
|
#:content
|
|
(lambda (param)
|
|
(define connected-usr (get-user param))
|
|
(define notes (if connected-usr (get-all-notes) (get-public-notes)))
|
|
`(article
|
|
,@(if (null? notes)
|
|
'("Pas de notes.")
|
|
(map
|
|
(lambda (n)
|
|
`(div (a ((href ,(note-link 'show (note-name n))))
|
|
,(if (note-public? n) "" "🔒︎ ")
|
|
,(note-title n))))
|
|
notes))
|
|
,@(if connected-usr
|
|
'((hr)
|
|
(a ((href "/notes/edit")) "Ajouter une note"))
|
|
'(""))
|
|
))
|
|
))
|
|
|
|
; /notes/show/xxx
|
|
; Show a given page of the notepad. A page is stored under a scribble-like format.
|
|
; If the page does not exists and user is logged in, redirect to the /notes/edit/xxx page.
|
|
(define (pages:notepad:page-show param)
|
|
(define connected-usr (get-user param))
|
|
(define page (weblet-parameter-ref param 'page #f))
|
|
(define note (get-note-by-name page))
|
|
(cond
|
|
( (and note (or (note-public? note) connected-usr))
|
|
( (pages:template
|
|
#:title (note-title note)
|
|
#:author (note-author note)
|
|
#:date (note-date note)
|
|
#:content
|
|
`(article
|
|
,@(format-note note)
|
|
,@(if connected-usr
|
|
`((hr)
|
|
(a ((href ,(note-link 'edit page))) "Éditer") " — "
|
|
(a ((href ,(note-link 'delete page))) "Supprimer"))
|
|
'())
|
|
))
|
|
param))
|
|
( note
|
|
; Note exists, but is private and user cannot edit it => not authorized
|
|
(pages:notepad:error param 'unauthorized))
|
|
( connected-usr
|
|
; Page does not exists, but user can edit => redirect to page creation
|
|
(redirect-to
|
|
(note-link 'edit page)
|
|
see-other))
|
|
( #t
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /notes/edit/xxx
|
|
; Edit an existing page, or create a new page with a given title. User must be logged in.
|
|
; Get => Form to edit page
|
|
; Post => Save page
|
|
(define (pages:notepad:page-edit param)
|
|
(define connected-usr (get-user param))
|
|
(define method (weblet-parameter-method param))
|
|
(define page (weblet-parameter-ref param 'page #f))
|
|
(define note (get-note-by-name page))
|
|
(define err? (equal? "t" (weblet-parameter-ref param 'error #f)))
|
|
(cond
|
|
( (and connected-usr (eq? method 'get))
|
|
; User connected, get method : read the page
|
|
(define title (or (and note (note-title note)) ""))
|
|
(define content (or (and note (note-content note)) ""))
|
|
(define page-name (or page "SansNom"))
|
|
(define public? (and note (note-public? note)))
|
|
( (pages:template
|
|
#:title (string-append "Édition de la note '" page-name "'")
|
|
#:author (user-name connected-usr)
|
|
#:scripts '("/scripts/notepad.js")
|
|
#:content
|
|
; Display the page as a form
|
|
`(article
|
|
,(if err?
|
|
'(p "Erreur: le nom de la page ne peut être vide.")
|
|
"")
|
|
(form ((action ,(note-link 'edit page-name))
|
|
(method "post"))
|
|
(label ((for "pagename")) "Nom (URL)") " "
|
|
(input ((id "pagename")(name "pagename")(type "text")(value ,page-name))) (br)
|
|
(label ((for "pagetitle")) "Titre") " "
|
|
(input ((id "pagetitle")(name "pagetitle")(type "text")(value ,title))) (br)
|
|
(label ((for "pagepublic")) "Publique")
|
|
(input ((id "pagepublic")(name "pagepublic")(type "checkbox")(value "on")
|
|
,@(if public? '((checked "true")) '()))) (br)
|
|
(textarea ((rows "10")(cols "80")(id "pagecontent")(name "pagecontent"))
|
|
,content) (br)
|
|
(input ((type "submit")
|
|
(value "Sauver et quitter l'édition")))
|
|
(input ((type "submit")(formaction ,(note-link 'edit page-name "?continue=t"))
|
|
(value "Sauver et continuer l'édition")))
|
|
(input ((type "button")(onclick ,(string-append "window.location.href='" (note-link 'show page-name) "';"))
|
|
(value "Annuler les modifications")))
|
|
)
|
|
(hr)
|
|
(section
|
|
(h2 "Aperçu")
|
|
(button ((onclick "notepadPreview();")) "Afficher l'aperçu")
|
|
(button ((onclick "notepadClearPreview();")) "Effacer l'aperçu")
|
|
(hr)
|
|
(div ((id "preview")) ))
|
|
(hr)
|
|
(section
|
|
(h2 "Syntaxe")
|
|
"Le bloc-note utilise une syntaxe proche de celle de " (a ((href "https://docs.racket-lang.org/scribble/index.html")) "Scribble") ". " (br)
|
|
"Pour introduire un passage à la ligne, il faut sauter une ligne. " (br)
|
|
,@(map
|
|
(lambda (x)
|
|
`(div (code "@" ,(car x) ,(if (cadr x) (string-append "[" (cadr x) "]") "")
|
|
"{" ,(caddr x) "}") " " ,@(cadddr x)))
|
|
'(("link" "to" "desc" ("Un lien vers l'addresse " (code "to") " intitulé " (code "desc") "."))
|
|
("image" "path" "alt" ("Une image située à l'addresse " (code "path") " avec le texte alternatif " (code "alt") "."))
|
|
("strong" #f "text" ("Affiche le texte " (code "text") " en gras."))
|
|
("str" #f "text" ("Synonyme de " (code "strong") "."))
|
|
("emphase" #f "text" ("Affiche le texte " (code "text") " en italique."))
|
|
("emp" #f "text" ("Synonyme de " (code "emphase") "."))
|
|
("section" #f "title" ("Démarre une nouvelle section de niveau 1 intitulée " (code "title") "."))
|
|
("subsection" #f "title" ("Démarre une nouvelle section de niveau 2 intitulée " (code "title") "."))
|
|
("subsubsection" #f "title" ("Démarre une nouvelle section de niveau 3 intitulée " (code "title") "."))
|
|
("paragraph" "justify" "text" ("Démarre un paragraphe contenant " (code "text") " avec la justification " (code "justify")
|
|
" (optionnelle, valeurs possibles: " (code "left") ", " (code "right") " ou " (code "center") "). "))
|
|
("para" #f "text" ("Synonyme de " (code "paragraph") "."))
|
|
))
|
|
)
|
|
))
|
|
param))
|
|
( (and page connected-usr (eq? method 'post))
|
|
(define continue? (equal? "t" (weblet-parameter-ref param 'continue #f)))
|
|
(define page-name (weblet-parameter-ref param 'pagename #f))
|
|
(define new-note-title (weblet-parameter-ref param 'pagetitle #f))
|
|
(define new-note-content (weblet-parameter-ref param 'pagecontent #f))
|
|
(define new-note-name (or (and (not (equal? "" page-name)) page-name)
|
|
page))
|
|
(define new-note-public? (equal? "on" (weblet-parameter-ref param 'pagepublic #f)))
|
|
; Check validity
|
|
(cond
|
|
( (and new-note-name (not (equal? new-note-name "")))
|
|
; Save page
|
|
(update-note note
|
|
#:name new-note-name
|
|
#:title new-note-title
|
|
#:content new-note-content
|
|
#:author connected-usr
|
|
#:public? new-note-public?)
|
|
; Redirect
|
|
(redirect-to
|
|
(note-link (if continue? 'edit 'show) new-note-name)
|
|
see-other))
|
|
( #t
|
|
; Error: redirect to edit
|
|
(redirect-to
|
|
(note-link 'edit page "?error=t")
|
|
see-other))))
|
|
( page
|
|
; Edition is not allowed
|
|
(pages:notepad:error param 'unauthorized))
|
|
( #t
|
|
; No such page
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /notes/delete/xxx
|
|
; Remove an existing page. User must be logged in.
|
|
; Get => ask confirmation
|
|
; Post => remove
|
|
(define (pages:notepad:page-delete param)
|
|
(define connected-usr (get-user param))
|
|
(define method (weblet-parameter-method param))
|
|
(define page (weblet-parameter-ref param 'page #f))
|
|
(define note (get-note-by-name page))
|
|
(cond
|
|
( (and note connected-usr (eq? method 'get))
|
|
; Method get => ask for confirmation
|
|
( (pages:template
|
|
#:title (string-append "Suppression de la page " page)
|
|
#:author (user-name connected-usr)
|
|
#:content
|
|
`(article
|
|
(form ((action ,(note-link 'delete page))
|
|
(method "post"))
|
|
(h3 "Supprimer la page " ,page " ? ")
|
|
"Cette action est irréversible." (br)
|
|
(input ((type "submit")
|
|
(value "Oui, supprimer la page")))
|
|
(input ((type "submit")(formaction ,(note-link 'show page))
|
|
(formmethod "get")(value "Non, garder la page")))
|
|
)))
|
|
param))
|
|
( (and note connected-usr (eq? method 'post))
|
|
; Method post => remove
|
|
(remove-note note)
|
|
; Redirect
|
|
(redirect-to
|
|
"/notes/list"
|
|
see-other))
|
|
( note
|
|
; Unauthorized
|
|
(pages:notepad:error param 'unauthorized))
|
|
( #t
|
|
; No such page
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /notes/preview
|
|
; Format and return the content
|
|
; Used on the edition page to preview the content before saving it.
|
|
(define pages:notepad:preview
|
|
(html-page-weblet
|
|
#:error-code 200
|
|
#:body
|
|
(lambda (param)
|
|
(define connected-usr (get-user param))
|
|
(define content (weblet-parameter-ref param 'pagecontent #f))
|
|
(if (and connected-usr content)
|
|
`(article
|
|
,@(format-note-content content))
|
|
""))))
|
|
|
|
|
|
; Media
|
|
|
|
; Link to a media with a given name
|
|
(define (media-link type name . args)
|
|
(string-append
|
|
(case type
|
|
((get) "/media/get/")
|
|
((show) "/media/show/")
|
|
((edit) "/media/edit/")
|
|
((delete) "/media/delete/")
|
|
(else ""))
|
|
(uri-encode name)
|
|
(apply string-append args)))
|
|
|
|
; /media/list
|
|
; Lists all medias of the notepad.
|
|
(define pages:notepad:media-list
|
|
(pages:template
|
|
#:title "Fichiers du bloc-note."
|
|
#:author "feuforeve.fr"
|
|
#:content
|
|
(lambda (param)
|
|
(define connected-usr (get-user param))
|
|
(define files (notepad-list-media notepad))
|
|
`(article
|
|
,@(if (null? files)
|
|
'("Pas de fichiers.")
|
|
(map
|
|
(lambda (x)
|
|
`(div (a ((href ,(media-link 'show x))) ,x)))
|
|
files))
|
|
,@(if connected-usr
|
|
'((hr)
|
|
(a ((href "/media/new")) "Ajouter un fichier"))
|
|
'(""))
|
|
))
|
|
))
|
|
|
|
; /media/show/xxx
|
|
; Show a given media of the notepad.
|
|
(define (pages:notepad:media-show param)
|
|
(define connected-usr (get-user param))
|
|
(define media (weblet-parameter-ref param 'media #f))
|
|
(define direct-link (media-link 'get media))
|
|
(cond
|
|
( (notepad-has-media? notepad media)
|
|
( (pages:template
|
|
#:title (string-append "Fichier: " media)
|
|
#:author "feuforeve.fr"
|
|
#:content
|
|
`(article
|
|
,@(case (notepad-media-type notepad media)
|
|
( (image)
|
|
`((a ((href ,direct-link)) (img ((src ,direct-link)(class "image-preview"))))(br)))
|
|
( else
|
|
'()))
|
|
(a ((href ,direct-link)) "Lien vers le fichier")
|
|
,@(if connected-usr
|
|
`((hr)
|
|
(a ((href ,(media-link 'edit media))) "Éditer") " — "
|
|
(a ((href ,(media-link 'delete media))) "Supprimer"))
|
|
'())
|
|
))
|
|
param))
|
|
( #t
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /media/get/xxx
|
|
; Get a given media of the notepad. Direct link.
|
|
; Managed at the webcontainer level.
|
|
|
|
; /media/new
|
|
; Add a media. User must be logged in.
|
|
; Get => Form to add a media
|
|
; Post => Process the upload, and show the media
|
|
(define (pages:notepad:media-new param)
|
|
(define connected-usr (get-user param))
|
|
(define method (weblet-parameter-method param))
|
|
(define failed? (equal? "t" (weblet-parameter-ref param 'error #f)))
|
|
(cond
|
|
( (and connected-usr (eq? method 'get))
|
|
; User connected, get method : new media form
|
|
( (pages:template
|
|
#:title "Ajouter un fichier"
|
|
#:author (user-name connected-usr)
|
|
#:content
|
|
; Display the page as a form
|
|
`(article
|
|
,@(if failed?
|
|
'("Erreur lors de l'ajout du fichier." (br))
|
|
'())
|
|
(form ((action "/media/new")
|
|
(method "post")
|
|
(enctype "multipart/form-data"))
|
|
(label ((for "filename")) "Fichier à ajouter") (br)
|
|
(input ((id "filename")(name "filename")(type "file"))) (br)
|
|
(input ((type "submit")
|
|
(value "Ajouter le fichier")))
|
|
)))
|
|
param))
|
|
( (and connected-usr (eq? method 'post))
|
|
(define filename (weblet-parameter-ref param 'filename #f))
|
|
(define in (and filename (weblet-parameter-file-port-ref param 'filename)))
|
|
; Save file
|
|
(cond
|
|
( (and filename in)
|
|
(notepad-new-media notepad filename in)
|
|
; Redirect
|
|
(redirect-to
|
|
(media-link 'show filename)
|
|
see-other))
|
|
( #t
|
|
; Redirect: upload failed
|
|
(redirect-to
|
|
"/media/new?error=t"
|
|
see-other))))
|
|
( #t
|
|
; Not allowed
|
|
(pages:notepad:error param 'unauthorized))))
|
|
|
|
; /media/edit/xxx
|
|
; Edit a media (move it). User must be logged in.
|
|
; Get => Form to edit a media
|
|
; Post => Process the upload, and show the media
|
|
(define (pages:notepad:media-edit param)
|
|
(define connected-usr (get-user param))
|
|
(define method (weblet-parameter-method param))
|
|
(define media (weblet-parameter-ref param 'media #f))
|
|
(define has-media? (notepad-has-media? notepad media))
|
|
(define failed? (equal? "t" (weblet-parameter-ref param 'error #f)))
|
|
(cond
|
|
( (and has-media? connected-usr (eq? method 'get))
|
|
; User connected, get method : edit media form
|
|
( (pages:template
|
|
#:title "Éditer un fichier"
|
|
#:author (user-name connected-usr)
|
|
#:content
|
|
; Display the page as a form
|
|
`(article
|
|
,@(if failed?
|
|
'("Erreur lors du renommage du fichier. Le nom doit être valide." (br))
|
|
'())
|
|
(form ((action ,(media-link 'edit media))
|
|
(method "post"))
|
|
(label ((for "filename")) "Nom du fichier") " "
|
|
(input ((id "filename")(name "filename")(type "text")(value ,media))) (br)
|
|
(input ((type "submit")
|
|
(value "Renommer le fichier")))
|
|
)))
|
|
param))
|
|
( (and has-media? connected-usr (eq? method 'post))
|
|
(define filename (weblet-parameter-ref param 'filename #f))
|
|
(cond
|
|
( (and filename (not (equal? filename "")) (not (equal? filename media)))
|
|
; Move file
|
|
(notepad-move-media notepad media filename)
|
|
; Redirectuser-check-password
|
|
(redirect-to
|
|
(media-link 'show filename)
|
|
see-other))
|
|
( #t
|
|
; Redirect: operation failed
|
|
(redirect-to
|
|
(media-link 'edit media "?error=t")
|
|
see-other))))
|
|
( has-media?
|
|
; Not allowed
|
|
(pages:notepad:error param 'unauthorized))
|
|
( #t
|
|
; Not found
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /media/delete/xxx
|
|
; Remove an existing media. User must be logged in.
|
|
; Get => ask confirmation
|
|
; Post => remove
|
|
(define (pages:notepad:media-delete param)
|
|
(define connected-usr (get-user param))
|
|
(define method (weblet-parameter-method param))
|
|
(define media (weblet-parameter-ref param 'media #f))
|
|
(define has-media? (notepad-has-media? notepad media))
|
|
(cond
|
|
( (and has-media? connected-usr (eq? method 'get))
|
|
; Method get => ask for confirmation
|
|
( (pages:template
|
|
#:title (string-append "Suppression du fichier " media)
|
|
#:author (user-name connected-usr)
|
|
#:content
|
|
`(article
|
|
(form ((action ,(media-link 'delete media))
|
|
(method "post"))
|
|
(h3 "Supprimer le fichier " ,media " ? ")
|
|
"Cette action est irréversible." (br)
|
|
(input ((type "submit")
|
|
(value "Oui, supprimer le fichier")))
|
|
(input ((type "submit")(formaction ,(media-link 'show media))
|
|
(formmethod "get")(value "Non, garder le fichier")))
|
|
)))
|
|
param))
|
|
( (and has-media? connected-usr (eq? method 'post))
|
|
; Method post => remove
|
|
(notepad-delete-media notepad media)
|
|
(redirect-to
|
|
"/media/list"
|
|
see-other))
|
|
( has-media?
|
|
; Unauthorized
|
|
(pages:notepad:error param 'unauthorized))
|
|
( #t
|
|
; No such page
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; User
|
|
; Link to a user with a given name
|
|
(define (user-link type name . args)
|
|
(string-append
|
|
(case type
|
|
((show) "/user/show/")
|
|
((edit) "/user/edit/")
|
|
((login) "/user/login/")
|
|
(else ""))
|
|
(uri-encode name)
|
|
(apply string-append args)))
|
|
|
|
; /user/list
|
|
; Lists all the users of the notepad.
|
|
(define pages:notepad:user-list
|
|
(pages:template
|
|
#:title "Utilisateurs du bloc-note."
|
|
#:author "feuforeve.fr"
|
|
#:content
|
|
(lambda (param)
|
|
(define users (get-all-users))
|
|
(if (null? users)
|
|
'(article "Pas d'utilisateurs.")
|
|
`(article
|
|
,@(map
|
|
(lambda (u)
|
|
`(div (a ((href ,(user-link 'show (user-name u)))) ,(user-pseudo u))))
|
|
users))))
|
|
))
|
|
|
|
; /user/show/xxx
|
|
; Show the page of user xxx.
|
|
(define pages:notepad:user-show
|
|
(pages:adaptable-template
|
|
(lambda (param)
|
|
(define usr (get-user-by-name (weblet-parameter-ref param 'name #f)))
|
|
(define connected-usr (get-user param))
|
|
(define edition-possible? (same-user? usr connected-usr))
|
|
(cond
|
|
(usr
|
|
(make-immutable-hash
|
|
`((author . ,(user-name usr))
|
|
(title . ,(string-append "À propos de " (user-pseudo usr)))
|
|
(content . (article
|
|
,(cond
|
|
( edition-possible?
|
|
`(form ((action ,(user-link 'edit (user-name usr)))
|
|
(method "post"))
|
|
(label ((for "pseudo")) "Pseudo") " "
|
|
(input ((name "pseudo")(id "pseudo")(type "text")(value ,(user-pseudo usr)))) (br)
|
|
(label ((for "about")) "Présentation") (br)
|
|
(textarea ((rows "5")(cols "40")(id "about")(name "about"))
|
|
,(user-about usr)) (br)
|
|
(input ((type "submit")(value "Mettre à jour")))
|
|
))
|
|
(#t
|
|
(user-about usr)
|
|
))
|
|
(hr)
|
|
,(cond
|
|
( (and (check-secured? param) (not connected-usr))
|
|
`(p (a ((href ,(user-link 'login (user-name usr))))
|
|
"Se connecter en tant que " ,(user-pseudo usr))))
|
|
( edition-possible?
|
|
`(p (a ((href ,(string-append "/user/logout")))
|
|
"Se déconnecter")))
|
|
( #t
|
|
""))
|
|
)))))
|
|
(#t
|
|
(notepad:error 'not-found))))))
|
|
|
|
; /user/login/xxx
|
|
; Login page for user xxx.
|
|
; Method GET -> show the page, with a form if user is not logged in. Show an error and a link to the logout page if user is already logged in.
|
|
; Method POST -> redirect to the page in case of failure, redirect to user-show in case of success
|
|
(define (pages:notepad:user-login param)
|
|
; Because of the behaviour, we cannot directly use a template
|
|
(define usr (get-user param))
|
|
(define method (weblet-parameter-method param))
|
|
(define secured? (check-secured? param))
|
|
(cond
|
|
( (and secured? usr (eq? method 'get))
|
|
(pages:notepad:user-login:already-connected usr param))
|
|
( (and secured? (eq? method 'get))
|
|
(pages:notepad:user-login:login-form param))
|
|
( (and secured? (eq? method 'post))
|
|
(pages:notepad:user-login:sent-form param))
|
|
( (eq? method 'get)
|
|
; redirect to https
|
|
(redirect-to-https-weblet param))
|
|
(#t
|
|
(pages:notepad:error param 'method-not-allowed))))
|
|
; Already connected
|
|
(define (pages:notepad:user-login:already-connected usr param)
|
|
((pages:template
|
|
#:title "Déjà connecté."
|
|
#:author (user-name usr)
|
|
#:content
|
|
`(article
|
|
"Déjà connecté en tant que " ,(user-name usr) ". " (br)
|
|
(a ((href "/user/logout")) "Se déconnecter")))
|
|
param))
|
|
; login form
|
|
(define pages:notepad:user-login:login-form
|
|
(pages:adaptable-template
|
|
(lambda (param)
|
|
(define usr (get-user-by-name (weblet-parameter-ref param 'name #f)))
|
|
(define incorrect (weblet-parameter-ref param 'incorrect))
|
|
(cond
|
|
(usr
|
|
(make-immutable-hash
|
|
`((author . ,(user-name usr))
|
|
(title . "Connexion")
|
|
(content . (article
|
|
,(if (equal? incorrect "t")
|
|
"Vous n'avez pas dit le mot magique."
|
|
"")
|
|
(form ((action ,(user-link 'login (user-name usr)))
|
|
(method "post"))
|
|
(label ((for "pass")) "Mot de passe") " "
|
|
(input ((id "pass")(name "pass")(type "password")(required "true"))) (br)
|
|
(input ((type "submit")(value "Se connecter")))
|
|
)
|
|
)))))
|
|
(#t
|
|
(notepad:error 'not-found))))))
|
|
; Process login
|
|
(define (pages:notepad:user-login:sent-form param)
|
|
(define usr (get-user-by-name (weblet-parameter-ref param 'name #f)))
|
|
(define pass (weblet-parameter-ref param 'pass #f))
|
|
(cond
|
|
( (user-check-password usr pass)
|
|
; Password OK, set cookie and redirect to /user/show/xxx
|
|
(define usercookie (new-usercookie usr))
|
|
(redirect-to
|
|
(user-link 'show (user-name usr))
|
|
see-other
|
|
#:headers (list
|
|
(make-header
|
|
#"Set-Cookie"
|
|
(cookie->set-cookie-header
|
|
(make-cookie
|
|
*cookie-key*
|
|
(usercookie-value usercookie)
|
|
#:expires (seconds->date (usercookie-expires usercookie))
|
|
#:domain (weblet-parameter-host param)
|
|
#:path "/"
|
|
#:secure? (not configuration:notepad:dev?)
|
|
#:http-only? #t))))
|
|
))
|
|
( usr
|
|
; KO, redirect to /user/login/xxx?incorrect=t
|
|
(redirect-to
|
|
(user-link 'login (user-name usr) "?incorrect=t")
|
|
see-other))
|
|
(#t
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /user/edit/xxx
|
|
; Edit page for the user xxx. Must be logged in as user xxx.
|
|
; Post only, as it is used to update the /user/show/xxx
|
|
(define (pages:notepad:user-edit param)
|
|
(define usr (get-user-by-name (weblet-parameter-ref param 'name #f)))
|
|
(define connected-usr (get-user param))
|
|
(define edition-possible? (same-user? usr connected-usr))
|
|
(define method (weblet-parameter-method param))
|
|
(cond
|
|
( (and edition-possible?
|
|
(eq? method 'post))
|
|
(define pseudo (weblet-parameter-ref param 'pseudo (user-pseudo usr)))
|
|
(define about (weblet-parameter-ref param 'about (user-about usr)))
|
|
(update-user-info usr #:pseudo pseudo #:about about)
|
|
(redirect-to
|
|
(user-link 'show (user-name usr))
|
|
see-other))
|
|
(#t
|
|
(pages:notepad:error param 'not-found))))
|
|
|
|
; /user/logout
|
|
; Logout page.
|
|
(define (pages:notepad:user-logout param)
|
|
(define cookie (weblet-parameter-cookie-ref param *cookie-key*))
|
|
(and cookie (remove-usercookie-by-value (string->bytes/utf-8 cookie)))
|
|
(redirect-to
|
|
"/user/list"
|
|
see-other
|
|
#:headers (list
|
|
(make-header
|
|
#"Set-Cookie"
|
|
(clear-cookie-header
|
|
*cookie-key*
|
|
#:domain (weblet-parameter-host param)
|
|
#:path "/")))
|
|
))
|