syndicate-lang
/
syndicate-ssh
forked from syndicate-lang/marketplace-ssh-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

auth-method syntactic sugar

This commit is contained in:
Tony Garnock-Jones 2021-06-21 14:56:12 +02:00
parent 2fc82642ea
commit 24908f58a9
1 changed files with 19 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
syndicate-ssh/new-server.rkt
View File

@ -73,38 +73,26 @@
(log-error "Invalid peer identification string ~v" remote-identification) (log-error "Invalid peer identification string ~v" remote-identification)
(stop-actor-system)])]) (stop-actor-system)])])
(assert (SshAuthenticationMethodAcceptable (SshAuthMethod-none))) (define-syntax-rule (auth-method m p x)
(during (Observe (:pattern (SshAuthenticationAcceptable (begin
(SshAuthMethod-none) (assert (SshAuthenticationMethodAcceptable m))
(SshAuthRequest-none ,(DLit $username)) (during (Observe (:pattern (SshAuthenticationAcceptable m ,(DLit $r) ,_)) _)
,_)) (match (parse-SshAuthRequest r)
_) [p (assert (SshAuthenticationAcceptable m r x))]
(assert (SshAuthenticationAcceptable (SshAuthMethod-none) [_ (assert (SshAuthenticationAcceptable m r #f))]))))
(SshAuthRequest-none username)
(equal? username "guest"))))
(assert (SshAuthenticationMethodAcceptable (SshAuthMethod-password))) (auth-method (SshAuthMethod-none)
(during (Observe (:pattern (SshAuthenticationAcceptable (SshAuthRequest-none username)
(SshAuthMethod-password) (equal? username "guest"))
(SshAuthRequest-password ,(DLit $username) ,(DLit $password)) (auth-method (SshAuthMethod-password)
,_)) (SshAuthRequest-password username password)
_) (and (equal? username "user")
(assert (SshAuthenticationAcceptable (SshAuthMethod-password) (equal? password "password")))
(SshAuthRequest-password username password) (auth-method (SshAuthMethod-publickey)
(and (equal? username "user") (SshAuthRequest-publickey username key)
(equal? password "password"))))) (and (equal? username "tonyg")
(equal? (->preserve key)
(assert (SshAuthenticationMethodAcceptable (SshAuthMethod-publickey))) (public-key->pieces test-user-public))))
(during (Observe (:pattern (SshAuthenticationAcceptable
(SshAuthMethod-publickey)
(SshAuthRequest-publickey ,(DLit $username) ,(DLit $key))
,_))
_)
(assert (SshAuthenticationAcceptable
(SshAuthMethod-publickey)
(SshAuthRequest-publickey username key)
(and (equal? username "tonyg")
(equal? key (public-key->pieces test-user-public))))))
(during (SshAuthenticatedUser $user-name #"ssh-connection") (during (SshAuthenticatedUser $user-name #"ssh-connection")
(run-repl-instance conn-ds user-name)) (run-repl-instance conn-ds user-name))