web.scm 8.78 KB
Newer Older
amirouche's avatar
amirouche committed
1 2
#!/bin/sh
# -*- scheme -*-
amirouche's avatar
amirouche committed
3
exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
amirouche's avatar
amirouche committed
4 5
!#
;;; Copyright © 2014       David Thompson <davet@gnu.org>
6
;;; Copyright © 2015-2018  Amirouche Boubekki <amirouche@hypermove.net>
amirouche's avatar
amirouche committed
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
(define-module (web))

;; stdlib
(use-modules (ice-9 match))
(use-modules (web request))
(use-modules (web server))
(use-modules (web uri))

;; local
29 30
(use-modules (web decode))
(use-modules (web helpers))
amirouche's avatar
amirouche committed
31
(use-modules (web html))
32 33
(use-modules (web mime-types))
(use-modules (web static))
amirouche's avatar
amirouche committed
34
(use-modules (web validate))
35
(use-modules (web lorem-ipsum))
amirouche's avatar
amirouche committed
36 37 38 39 40

(setlocale LC_ALL "")

;;;

41
(define (template class body)
amirouche's avatar
amirouche committed
42 43 44 45
  `((doctype "html")
    (html
     (head
      (meta (@ (charset "utf-8")))
amirouche's avatar
amirouche committed
46
      (title "presence mockup")
amirouche's avatar
amirouche committed
47 48 49
      (link (@ (rel "stylesheet") (href "/static/normalize.css")))
      (link (@ (rel "stylesheet") (href "/static/main.css"))))
     (body
amirouche's avatar
amirouche committed
50 51
      (div (@ (id "header")))
      (div (@ (id "wrapper"))
52 53
           (div (@ (id "container")
                   (class ,class))
amirouche's avatar
amirouche committed
54 55
                ,body))
      (div (@ (id "footer")))))))
amirouche's avatar
amirouche committed
56

amirouche's avatar
amirouche committed
57 58 59 60
(define (random-tag uid)
  (let ((tag (lorem-ipsum 1)))
    `(span (@ (class "tag"))
           ,tag)))
61

amirouche's avatar
amirouche committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
(define (random-tags)
  (map random-tag (iota (+ 1 (random 3)))))

(define (random-post uid)
  `(a (@ (class "overview-item post")
         (href ,(string-append "/item/"
                               (number->string uid)
                               "/random-item-on-presence/")))
      (h2 ,(lorem-ipsum 5))
      (p (@ (class "overview-item-description"))
         "Published yesterday in " ,(random-tags))))

(define (random-message uid)
  `(a (@ (class "overview-item message")
         (href ,(string-append "/item/"
                               (number->string uid)
                               "/random-message-on-presence/")))
      (p ,(lorem-ipsum 20))
      (p (@ (class "overview-item-description"))
         "Published yesterday in " ,(random-tags))))

(define (random-link uid)
  `(a (@ (class "overview-item link")
         (href ,(string-append "/item/"
                               (number->string uid)
                               "/random-link-on-presence/")))
      (p ,(lorem-ipsum 7))
      (p (@ (class "overview-link-url")) "http://example.com/spam/egg/guile/win/")
      (p (@ (class "overview-item-description"))
         "Published yesterday in " ,(random-tags))))

(define (random-commit uid)
  `(a (@ (class "overview-item commit")
         (href ,(string-append "/commit/"
                               (number->string uid)
                               "/")))
      (p (code "1337decafbad42") " " ,(lorem-ipsum 7))
      (p (@ (class "overview-item-description"))
         "Published yesterday in presence")))


(define %items (list random-post
                     random-message
                     random-link
                     random-commit))

(define (random-item uid)
  ((list-ref %items (random (length %items))) uid))

amirouche's avatar
amirouche committed
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
(define (request-query request)
  (and=> ((compose uri-query request-uri) request) decode))

(define (query->maybe-response query)
  (cond
   ((not query) (values #f #f))
   ((null? query) (values #f #f))
   ((string=? (car query) "/login") (redirect "/login"))
   ((string=? (car query) "/signup") (redirect "/signup"))))

(define (index request)
  (let ((query (assoc-ref (request-query request) "query")))
    (call-with-values (lambda () (query->maybe-response query))
      (lambda (header body)
        (if header
            (values header body)
            (render-html
             (template "overview"
                       `((form (@ (id "navigation"))
                               (input (@ (id "query")
                                         (name "query")
                                         (type "text")
                                         (autofocus #t)))
                               (input (@ (type "submit")
                                         (value "submit"))))
                         (div (@ (id "overview-intro"))
                              ,(lorem-ipsum 100))
                         ,(map random-item (iota 10))))))))))

(define sxml->response render-html)

(define (login/get request)
  (sxml->response
   (template "login"
             `(form (@ (method "POST"))
               (h2 "Log in")
               (p (label "login")
                  (input (@ (name "login")
                            (type "text"))))
               (p (label "password")
                  (input (@ (name "password")
                            (type "password"))))
               (p (@ (class "form-control"))
                  (input (@ (type "submit")
                            (value "submit"))))))))

(define (login/post request body)
  ...)

(define (maybe-error error)
  (if error
      `(p (@ (class "error")) ,error)
      '()))

amirouche's avatar
amirouche committed
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
(define (make-value value)
  (match value
    ((? string? string) string)
    ((? symbol? symbol) (symbol->string symbol))))

(define (make-style alist)
  (let loop ((alist alist)
             (out ""))
    (if (null? alist)
        (string-append out ";")
        (loop (cdr alist)
              (string-append out
                             "; "
                             (symbol->string (caar alist))
                             ": "
                             (make-value (cdar alist)))))))

amirouche's avatar
amirouche committed
182
(define (make-class alist)
amirouche's avatar
amirouche committed
183 184 185 186 187 188 189 190 191 192 193 194 195
  "Create html class attribute with an ALIST"
  (let loop ((alist alist)
             (out ""))
    (if (null? alist)
        out
        (if (cdar alist)
            (loop (cdr alist) (string-append (caar alist) " " out))
            (loop (cdr alist) out)))))

(define (signup/template errors)
  (let ((login-error (assoc-ref errors "login"))
        (password-error (assoc-ref errors "password"))
        (confirmation-error (assoc-ref errors "confirmation")))
amirouche's avatar
amirouche committed
196 197 198
    (template "signup"
              `(form (@ (method "POST")
                        (style ,(make-style `((border . "1px solid black")))))
amirouche's avatar
amirouche committed
199
                     (h2 "Sign up")
amirouche's avatar
amirouche committed
200
                     (div (@ (class ,(make-class `(("form-item" . #t)
amirouche's avatar
amirouche committed
201 202 203 204 205
                                                     ("error" . ,login-error)))))
                          (p (label "login")
                             (input (@ (name "login")
                                       (type "text"))))
                          ,(maybe-error login-error))
amirouche's avatar
amirouche committed
206
                     (div (@ (class ,(make-class `(("form-item" . #t)
amirouche's avatar
amirouche committed
207 208 209 210
                                                     ("error" . ,password-error)))))
                          (p (label "password")
                             (input (@ (name "password")
                                       (type "password")))))
amirouche's avatar
amirouche committed
211
                     (div (@ (class ,(make-class `(("form-item" . #t)
amirouche's avatar
amirouche committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
                                                     ("error" . ,confirmation-error)))))
                          (p (label "confirmation")
                             (input (@ (name "confirmation")
                                       (type "password")))))
                     (div (@ (class "form-item"))
                          (p (@ (class "form-control"))
                             (input (@ (type "submit")
                                       (value "submit")))))))))

(define (signup/get request)
  (sxml->response (signup/template '())))

(define (login-valid? login)
  (and (eq? (string-length (car login)) 0)
       "Password must be at least one character"))

(define (password-valid? password)
  #t) ;; TODO

(define %signup `(("login" . ,login-valid?)
                  ("password" . ,password-valid?)))

(define (signup/post request body)
  (let ((form (decode body)))
    (let ((errors (pk 'errors (validate %signup form))))
      (if (null? errors)
          (redirect "/")
          (sxml->response (signup/template errors))))))
240

amirouche's avatar
amirouche committed
241
(define (handler request body)
242
  (match (cons (request-method request) (request-path-components request))
amirouche's avatar
amirouche committed
243 244 245 246 247
    ('(GET) (index request))
    ('(GET "login") (login/get request))
    ('(POST "login") (login/post request post))
    ('(GET "signup") (signup/get request))
    ('(POST "signup") (signup/post request body))
248
    (('GET "static" path ...) (render-static-asset path))
249
    (_ (not-found (uri-path (request-uri request))))))
amirouche's avatar
amirouche committed
250

amirouche's avatar
amirouche committed
251
(define-public (main _)
252
  (format #t "Server running @ http://localhost:8080\n")
amirouche's avatar
amirouche committed
253
  (run-server handler))