#! /usr/bin/env guile
!#

;;  -*-  indent-tabs-mode:nil; coding: utf-8 -*-
;;  Copyright (C) 2013,2014,2015
;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
;;  Artanis is free software: you can redistribute it and/or modify
;;  it under the terms of the GNU General Public License and GNU
;;  Lesser General Public License published by the Free Software
;;  Foundation, either version 3 of the License, or (at your option)
;;  any later version.

;;  Artanis 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 and GNU Lesser General Public License
;;  for more details.

;;  You should have received a copy of the GNU General Public License
;;  and GNU Lesser General Public License along with this program.
;;  If not, see <http://www.gnu.org/licenses/>.

(use-modules (artanis artanis) (artanis utils) (artanis session))
;; exclude *.html static file to be handled by default static-page-emitter
;; we need to handle foo.html in rule test-18, this can avoid the conflict.
(init-server)

(define mmr "123")

;; 1
(get "/mmr/:id1/to/:id2"
  (lambda (rc)
    (let ((id1 (params rc "id1"))
          (id2 (params rc "id2")))
      (response-emit (format #f "~a: Send from ~a to ~a~%" mmr id1 id2)))))

;; 2
(get "/hello.scm"
  (lambda (rc)
    (response-emit "hello world!")))

;; 3
(get "/test"
  (lambda (rc)
    (let ((a 123))
      (tpl->response "my.tpl" (the-environment)))))

;; 4
;; simple cache test (for dynamic content)
(get "/new" #:cache #t
     (lambda (rc)
       (:cache rc "hello world")))

;; 4.1
;; cache in auth should be private
(get "/pauth" #:auth `(basic ,(lambda (rc u p) #t)) #:cache '(public "./test.scm")
     (lambda (rc)
       (:cache rc)))

;; test database (here we use mysql/mariaDB for an example)
;; there's a table for testing:
;; CREATE TABLE Persons
;; (
;; PersonID int,
;; LastName varchar(255),
;; FirstName varchar(255),
;; Address varchar(255),
;; City varchar(255)
;; );

;; And insert some data:

;; insert into Persons
;; (PersonID,Lastname,Firstname,Address,City)
;; values (1,"lei","mu","adsf","sz");

;; Add this person for testing SQL-injection:
;; insert into Persons (PersonID,Lastname,Firstname,Address, City)
;; values (2,"ada","wang","secret","classified")

(define (result->html r)
  (if r
      (call-with-output-string
        (lambda (port)
          (for-each (lambda (e) (format port "<p>~a: ~a</p>" (car e) (cdr e))) r)))
      "no result"))

;; 5
(get "/raw-sql"
  #:raw-sql "select * from Persons where Lastname='lei'"
  (lambda (rc)
    (let ((r (:raw-sql rc 'top)))
      (result->html r))))

;; 6
;; curl localhost:3000/conn/lei
(get "/conn/:name"
  #:conn #t
  (lambda (rc)
    (let* ((name (params rc "name"))
           (r (:conn rc (->sql select * from 'Persons (where #:Lastname name)))))
      (result->html (DB-get-top-row r)))))

;; 7
;; curl "localhost:3000/conn/lei;select * from Persons;"
(get "/fucked/:name"
  #:conn #t
  (lambda (rc)
    (let* ((name (uri-decode (params rc "name")))
           (r (:conn rc (->sql select * from 'Persons (where #:Lastname name)))))
      (result->html (DB-get-top-row r)))))

;; 8
;; curl localhost:3000/conn+str/lei
(get "/conn[+]str/:name"
  #:conn #t #:str "select * from Persons where Lastname=${:name}"
  (lambda (rc)
    (let ((r (:conn rc (:str rc))))
      (result->html (DB-get-top-row r)))))

;; 9
;; various format tests
(get "/json" #:mime 'json
     (lambda (rc)
       (let ((j (scm->json-string '(("name" "nala") ("age" "15")))))
         (:mime rc j))))

;; 9.1
;; JSONP test
(get "/jsonp/:callback" #:mime 'jsonp
     (lambda (rc)
       (:mime rc (scm->json-string '(("name" "nala") ("age" "15"))) #:jsonp (params rc "callback"))))

;; 10
(get "/csv" #:mime 'csv
     (lambda (rc)
       (:mime rc '(("a" "1") ("b" "2")))))

;; 11
(get "/xml" #:mime 'xml
     (lambda (rc)
       (:mime rc '(*TOP* (WEIGHT (@ (unit "pound")) (NET (@ (certified "certified")) "67") (GROSS "95"))))))

;; 12
(get "/sxml" #:mime 'sxml
     (lambda (rc)
       (:mime rc '((a 1) (b 2)))))

;; 13
;; cookies test
(get "/cookie" #:cookies '(names cc)
     (lambda (rc)
       (:cookies-set! rc 'cc "sid" "123321")
       (:cookies-ref rc 'cc "sid")))

;; 14
(get "/cookie/:expires" #:cookies '(names cc)
     (lambda (rc)
       (:cookies-set! rc 'cc "sid" "123321")
       (:cookies-setattr! rc 'cc #:expires (string->number (params rc "expires")))
       "ok"))

;; 15
;; test for naive basic-auth
(get "/bauth" #:auth `(basic ,(lambda (rc u p) (and (string=? u "mmr") (string=? p "123"))))
     (lambda (rc)
       (if (:auth rc)
           "auth ok"
           (throw-auth-needed))))

;; 16
;; test for more complicated auth
(post "/auth" #:auth '(table user "user" "passwd") #:session #t
      (lambda (rc)
        (cond
         ((:session rc 'check) "auth ok (session)")
         ((:auth rc) (:session rc 'spawn))
         (else (redirect-to rc "/login?login_failed=true")))))

;; 16.1
;; test for login successful
(get "/enter" #:session #t
     (lambda (rc)
       (cond
        ((:session rc 'check) "yes login!")
        (else (redirect-to rc "/login?login_failed=true")))))

;; 16.2
;; test for session-set! success
(get "/session-set" #:session #t
     (lambda (rc)
       (cond
         ((:session rc 'check) (session-set! (get-sid-from-client-cookie rc "sid") "some-key" "some-value") "Session variable has been set")
        (else (redirect-to rc "/login?login_failed=true")))))

;; 16.3
;; test for session-ref success
(get "/session-get" #:session #t
     (lambda (rc)
       (cond
         ((:session rc 'check)
          (let ((sess-var (session-ref (get-sid-from-client-cookie rc "sid") "some-key")))
            (string-append "Got session variable " sess-var)))
        (else (redirect-to rc "/login?login_failed=true")))))

;; 17
(get "/login"
  (lambda (rc)
    (let ((blog-title "test auth")
          (footer "<p>Powered by GNU Artanis</p>")
          (failed (params rc "login_failed")))
      (tpl->response "login.tpl" (the-environment)))))

;; 18
;; to support dot as the delimiter of key-bindings in rule
(get "/pkg/:name\\.:format"
  (lambda (rc)
    (format #f "~a.~a" (params rc "name") (params rc "format"))))

(get "/echo" #:websocket '(proto echo)
     (lambda (rc)
       (:websocket rc 'payload)))

(get "/robot" #:websocket '(proto echo) named-pipe-subscribe)

(get "/welcome/:whom/:what" #:websocket 'send-only
     (lambda (rc)
       (:websocket rc 'send (params rc "whom") (params rc "what"))
       "ok"))

(get "/lpc/set/:what" #:lpc #t
     (lambda (rc)
       (:lpc rc 'set "test" (params rc "what"))))

(get "/lpc/get/" #:lpc #t
     (lambda (rc)
       (:lpc rc 'get "test")))

(run #:use-db? #t #:dbd 'mysql #:db-username "root" #:db-passwd "123" #:debug #t)

;;(run)
