Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asylum
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
2
Issues
2
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
a-guile-mind
asylum
Commits
8a47f885
Commit
8a47f885
authored
Jan 31, 2018
by
amirouche
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
wip sign up form
parent
885be357
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
194 additions
and
16 deletions
+194
-16
main.css
src/static/main.css
+48
-0
web.scm
src/web.scm
+117
-16
validate.scm
src/web/validate.scm
+29
-0
No files found.
src/static/main.css
View file @
8a47f885
...
@@ -116,6 +116,54 @@ a:hover {
...
@@ -116,6 +116,54 @@ a:hover {
text-decoration
:
underline
;
text-decoration
:
underline
;
}
}
form
p
{
margin
:
0px
;
}
form
>
div
.form-item.error
{
color
:
rgb
(
200
,
10
,
10
);
}
form
>
div
.form-item
>
p
:first-child
{
display
:
flex
;
padding
:
10px
50px
;
margin-bottom
:
0px
;
padding-bottom
:
0px
;
}
form
>
div
.form-item
>
p
:first-child
>
label
{
margin-right
:
10px
;
min-width
:
200px
;
text-align
:
right
;
}
form
>
div
.form-item
>
p
.error
{
padding
:
5px
50px
;
margin
:
0px
;
font-size
:
0.7em
;
text-align
:
right
;
line-height
:
1em
;
}
form
input
[
type
=
"text"
],
form
input
[
type
=
"password"
]
{
width
:
100%
;
border
:
1px
solid
hsla
(
0
,
0%
,
70%
,
1
);
border-radius
:
2px
;
background
:
white
;
}
form
.error
input
[
type
=
"text"
],
form
.error
input
[
type
=
"password"
]
{
box-shadow
:
0px
0px
2px
rgb
(
200
,
10
,
10
);
border
:
1px
solid
rgb
(
200
,
10
,
10
);
}
form
>
div
.form-item
>
p
.form-control
{
display
:
flex
;
justify-content
:
right
;
}
#navigation
{
#navigation
{
display
:
flex
;
display
:
flex
;
border-top
:
1px
solid
black
;
border-top
:
1px
solid
black
;
...
...
src/web.scm
View file @
8a47f885
...
@@ -31,6 +31,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
...
@@ -31,6 +31,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(
use-modules
(
web
html
))
(
use-modules
(
web
html
))
(
use-modules
(
web
mime-types
))
(
use-modules
(
web
mime-types
))
(
use-modules
(
web
static
))
(
use-modules
(
web
static
))
(
use-modules
(
web
validate
))
(
use-modules
(
web
lorem-ipsum
))
(
use-modules
(
web
lorem-ipsum
))
(
setlocale
LC_ALL
""
)
(
setlocale
LC_ALL
""
)
...
@@ -50,14 +51,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
...
@@ -50,14 +51,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(
div
(
@
(
id
"wrapper"
))
(
div
(
@
(
id
"wrapper"
))
(
div
(
@
(
id
"container"
)
(
div
(
@
(
id
"container"
)
(
class
,
class
))
(
class
,
class
))
(
form
(
@
(
id
"navigation"
))
(
input
(
@
(
id
"query"
)
(
name
"query"
)
(
type
"text"
)
(
autofocus
#t
)
(
value
"!overview"
)))
(
input
(
@
(
type
"submit"
)
(
value
"submit"
))))
,
body
))
,
body
))
(
div
(
@
(
id
"footer"
)))))))
(
div
(
@
(
id
"footer"
)))))))
...
@@ -115,20 +108,128 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
...
@@ -115,20 +108,128 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(
define
(
random-item
uid
)
(
define
(
random-item
uid
)
((
list-ref
%items
(
random
(
length
%items
)))
uid
))
((
list-ref
%items
(
random
(
length
%items
)))
uid
))
(
define
(
overview
)
(
define
(
request-query
request
)
(
render-html
(
and=>
((
compose
uri-query
request-uri
)
request
)
decode
))
(
template
"overview"
`
((
div
(
@
(
id
"overview-intro"
))
(
define
(
query->maybe-response
query
)
,
(
lorem-ipsum
100
))
(
cond
,
(
map
random-item
(
iota
10
))))))
((
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
)
'
()))
(
define
(
alist->class
alist
)
"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"
)))
(
template
"login"
`
(
form
(
@
(
method
"POST"
))
(
h2
"Sign up"
)
(
div
(
@
(
class
,
(
alist->class
`
((
"form-item"
.
#t
)
(
"error"
.
,
login-error
)))))
(
p
(
label
"login"
)
(
input
(
@
(
name
"login"
)
(
type
"text"
))))
,
(
maybe-error
login-error
))
(
div
(
@
(
class
,
(
alist->class
`
((
"form-item"
.
#t
)
(
"error"
.
,
password-error
)))))
(
p
(
label
"password"
)
(
input
(
@
(
name
"password"
)
(
type
"password"
)))))
(
div
(
@
(
class
,
(
alist->class
`
((
"form-item"
.
#t
)
(
"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
))))))
(
define
(
handler
request
body
)
(
define
(
handler
request
body
)
(
match
(
cons
(
request-method
request
)
(
request-path-components
request
))
(
match
(
cons
(
request-method
request
)
(
request-path-components
request
))
((
'GET
)
(
overview
))
(
'
(
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
))
((
'GET
"static"
path
...
)
(
render-static-asset
path
))
((
'GET
"static"
path
...
)
(
render-static-asset
path
))
(
_
(
not-found
(
uri-path
(
request-uri
request
))))))
(
_
(
not-found
(
uri-path
(
request-uri
request
))))))
(
define-public
(
main
_
)
(
define-public
(
main
_
)
(
format
#t
"Server running @ http://localhost:8080\n"
)
(
format
#t
"Server running @ http://localhost:8080\n"
)
(
run-server
handler
))
(
run-server
handler
))
src/web/validate.scm
0 → 100644
View file @
8a47f885
(
define-module
(
web
validate
))
(
use-modules
((
srfi
srfi-1
)))
(
define-public
(
validate
spec
alist
)
"Validate ALIST based using SPEC
SPEC must be an association list that maps keys to validation
procedures. Validation procedure must take a single parameter that
will be the associated value in ALIST based on equal?. The validation
procedure must return an error message as string if the value is
invalid"
(
fold
(
lambda
(
validator
errors
)
(
let
((
error
((
cdr
validator
)
(
assoc-ref
alist
(
car
validator
)))))
(
if
(
string?
error
)
(
cons
(
cons
(
car
validator
)
error
)
errors
)
errors
)))
'
()
spec
))
(
define-public
(
make-valiador
.
validators
)
(
lambda
(
value
)
(
let
loop
((
validators
validators
))
(
unless
(
null?
validators
)
(
let
((
out
((
car
validators
)
value
)))
(
if
(
string=?
out
)
out
(
loop
(
cdr
validators
))))))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment