Implement a hierarchy between notes. A table tracks the parent-child relation, and the hierarchy is displayed in the note listing.

src/notepad/hierarchy.rkt

@@ -0,0 +1,96 @@
+#lang racket/base
+
+(require
+  "stored-objects.rkt")
+
+(provide
+  ; Accessors
+  hierarchy-parent-of hierarchy-children-of hierarchy-path
+  ; Creation/update
+  update-hierarchy
+  ; Removal
+  delete-from-hierarchy
+  ; Init repo
+  hierarchy-init-repository
+  )
+
+; Hierarchy table between notes
+; A hierarchy is the relation parent <> child
+; The hierarchy must be a partial order
+; When moving the hierarchy, a check is done to verify there's no loop
+; Notes with no parent are at the top of a hierarchy
+
+; Structure
+(stored-class notepadhierarchy
+  (parent : integer?) ; Id of the parent note
+  (child : integer?) ; Id of the child note
+  )
+
+; Repo initialization
+(define (hierarchy-init-repository repo)
+  (init-repository repo
+    notepadhierarchy))
+
+; Create or update a hierarchy relation, and return it, or return #f if the new hierarchy cannot be created or updated
+(define (update-hierarchy
+          #:parent parent
+          #:child child)
+  (if (hierarchy-can-be-child-of? parent child)
+      ; Find if a hierarchy already exists for the given child
+      (let* ((hierarchies (find-instances notepadhierarchy `((child . ,child))))
+             (hierarchy
+                (if (null? hierarchies)
+                    (instanciate notepadhierarchy)
+                    (car hierarchies))))
+        (set-notepadhierarchy-parent! hierarchy parent)
+        (set-notepadhierarchy-child! hierarchy child)
+        (save-instance hierarchy)
+        hierarchy)
+      #f))
+
+; Check if a note can be a child of given note
+(define (hierarchy-can-be-child-of? parent child)
+  (or (not parent) ; OK if parent does not exist
+      (and
+        (not (eq? parent child)) ; parent and child must be different
+        (hierarchy-can-be-child-of? (hierarchy-parent-of parent) child)))) ; child can be a child of its grand-parent
+
+; Get the parent of a given item
+(define (hierarchy-parent-of elem)
+  (define hierarchies (find-instances notepadhierarchy `((child . ,elem))))
+  (and (not (null? hierarchies))
+       (notepadhierarchy-parent (car hierarchies))))
+
+; Get the children of a given item
+(define (hierarchy-children-of elem)
+  (define hierarchies (find-instances notepadhierarchy `((parent . ,elem))))
+  (map notepadhierarchy-child hierarchies))
+
+; Get the path of a given item
+; The path is the list of item + its ancestors, from the first ancestor. So the first item of the returned list has no parent.
+(define (hierarchy-path elem (children '()))
+  (define current (cons elem children))
+  (define parent (hierarchy-parent-of elem))
+  (if parent
+      (hierarchy-path parent current)
+      current))
+
+; Remove an element in the hierarchy
+(define (delete-from-hierarchy elem)
+  ; Retrive the associated hierarchy
+  (define hierarchies (find-instances notepadhierarchy `((child . ,elem))))
+  (define hierarchy (and (not (null? hierarchies)) (car hierarchies)))
+  ; Attach all the children of elem to its parent if it exists, or else remove all the relations
+  (define children (find-instances notepadhierarchy `((parent . ,elem))))
+  (define parent (and hierarchy (notepadhierarchy-parent hierarchy)))
+  (map
+    (lambda (x)
+      (if parent
+        (begin
+          (set-notepadhierarchy-parent! x parent)
+          (save-instance x))
+        (delete-instance x)))
+      children)
+  ; Remove the hierarchy if it exists
+  (when hierarchy
+    (delete-instance hierarchy)))

src/notepad/notepad.rkt

@@ -13,6 +13,7 @@
   "notes.rkt"
   "media.rkt"
   "user.rkt"
+  "hierarchy.rkt"
   "stored-objects.rkt"
   )
 
@@ -26,7 +27,7 @@
 ; - a table of cookies, to manage edition of notepad
 ; - a table of notes
 ; - a table of media
-; - a table of parent/child relations for notes and media
+; - a table of parent/child relations for notes
 
 ; Notepad structure
 (struct notepad
@@ -41,6 +42,7 @@
   (user-init-repository repo)
   (note-init-repository repo)
   (media-init-repository repo)
+  (hierarchy-init-repository repo)
   (notepad
     dir
     repo))

src/notepad/notes.rkt

@@ -3,6 +3,8 @@
 (require
   "stored-objects.rkt"
   "user.rkt"
+  "../collection/tree.rkt"
+  "hierarchy.rkt"
   )
 
 (provide
@@ -11,6 +13,7 @@
   ; Operations
   new-note update-note remove-note
   get-note-by-name get-all-notes get-public-notes
+  note-list->tree get-parent-note-id note-id
   ; Init repo
   note-init-repository
   )
@@ -81,8 +84,10 @@
           #:content content
           #:licence (licence #f)
           #:public? (public? #f)
+          #:parent-id (parent-id #f)
           )
   (within-transaction (class-repository notepadnote)
+    (define parent-valid? (and parent-id (has-instance-with-id notepadnote parent-id)))
     (define new-nt (or nt (instanciate notepadnote)))
     (set-notepadnote-name! new-nt name)
     (set-notepadnote-title! new-nt title)
@@ -92,11 +97,16 @@
     (set-notepadnote-licence! new-nt licence)
     (set-notepadnote-public! new-nt public?)
     (save-instance new-nt)
+    ; Update hierarchy
+    (when parent-valid?
+      (update-hierarchy #:parent parent-id #:child (instance-identifier new-nt)))
     new-nt))
 
 ; Remove a note
 (define (remove-note nt)
   (within-transaction (class-repository notepadnote)
+    ; Update hierarchy
+    (delete-from-hierarchy (instance-identifier nt))
     ; Remove note
     (delete-instance nt)))
 
@@ -113,3 +123,22 @@
 ; Get all public notes
 (define (get-public-notes)
   (find-instances notepadnote '((public . #t))))
+
+; Convert a list of note instances into a tree
+(define (note-list->tree notes)
+  (define tr (make-tree))
+  (for-each
+    (lambda (x)
+      (tree-set! tr
+        (hierarchy-path (instance-identifier x))
+        x))
+    notes)
+  tr)
+
+; Get the id of the parent of a note
+(define (get-parent-note-id n)
+  (hierarchy-parent-of (instance-identifier n)))
+
+; Get the identifier of a note
+(define (note-id n)
+  (instance-identifier n))

src/pages/notepad.rkt

@@ -9,6 +9,7 @@
   "../notepad/user.rkt"
   "../notepad/notes.rkt"
   "../notepad/media.rkt"
+  "../collection/tree.rkt"
   "../../configuration.rkt"
   web-server/http/redirect
   web-server/http/request-structs
@@ -111,14 +112,25 @@
     (lambda (param)
       (define connected-usr (get-user param))
       (define notes (if connected-usr (get-all-notes) (get-public-notes)))
+      ; Get the notes as a tree
+      (define note-tree (note-list->tree notes))
+      ;
       `(article
-        ,@(if (null? notes)
-              '("Pas de note.")
-              (map
-                (lambda (n)
-                `(div (a ((href ,(note-link 'show (note-name n))))
-                         ,(displayed-name (note-title n) (note-public? n)))))
-                notes))
+        ,(if (null? notes)
+              "Pas de note."
+              (tree-fold
+                note-tree
+                (lambda (n children)
+                  (if n
+                    (append
+                      `(div
+                         ((class "notepad-page-list-entry"))
+                         (a ((href ,(note-link 'show (note-name n))))
+                            ,(displayed-name (note-title n) (note-public? n))))
+                      (reverse children))
+                    (append
+                      '(div)
+                      (reverse children))))))
         ,@(if connected-usr
               '((hr)
                 (a ((href "/notes/edit")) "Ajouter une note"))
@@ -196,6 +208,8 @@
                   (label ((for "pagepublic")) "Publique")
                   (input ((id "pagepublic")(name "pagepublic")(type "checkbox")(value "on")
                           ,@(if public? '((checked "true")) '()))) (br)
+                  (label ((for "pageparent")) "Parent") " "
+                  ,(pages:notepad:page-edit:parent-combobox note)
                   (textarea ((rows "10")(cols "80")(id "pagecontent")(name "pagecontent"))
                     ,content) (br)
                   (input ((type "submit")
@@ -250,6 +264,9 @@
       (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)))
+      (define new-note-parent-raw (weblet-parameter-ref param 'pageparent #f))
+      (define new-note-parent-id (and new-note-parent-raw (not (equal? "none" new-note-parent-raw))
+                                      (string->number new-note-parent-raw 10 'number-or-false)))
       ; Check validity
       (cond
         ( (and new-note-name (not (equal? new-note-name "")))
@@ -259,7 +276,8 @@
             #:title new-note-title
             #:content new-note-content
             #:author connected-usr
-            #:public? new-note-public?)
+            #:public? new-note-public?
+            #:parent-id new-note-parent-id)
           ; Redirect
           (redirect-to
             (note-link (if continue? 'edit 'show) new-note-name)
@@ -276,6 +294,31 @@
       ; No such page
       (pages:notepad:error param 'not-found))))
 
+; Combobox for selecting the parent page
+(define (pages:notepad:page-edit:parent-combobox note)
+  (define parent-note-id (get-parent-note-id note))
+  `(select
+    ((id "pageparent")
+     (name "pageparent"))
+    (option
+      ,(append
+        '((value "none"))
+        (if (not parent-note-id)
+            '((selected "true"))
+            '()))
+      "-- Sans Parent --")
+    ,@(map
+        (lambda (n)
+          `(option
+            ,(append
+              `((value ,(number->string (note-id n))))
+              (if (and parent-note-id (eq? parent-note-id (note-id n)))
+                  '((selected "true"))
+                  '()))
+            ,(note-title n)))
+        (get-all-notes))
+    ))
+
 ; /notes/delete/xxx
 ; Remove an existing page. User must be logged in.
 ; Get => ask confirmation

static/css/feuforeve.css

@@ -219,3 +219,7 @@ details > p {
   padding-left: 1.5ex;
   padding-right: 1.5ex;
 }
+
+.notepad-page-list-entry {
+  margin-left: 1ex;
+}