Compare commits
2 Commits
4873994655
...
e0bf4848ff
| Author | SHA1 | Date |
|---|---|---|
 Steve Ayerhart
|
e0bf4848ff | |
|
Steve Ayerhart
|
69754ba545 |
|
|
@ -1 +0,0 @@
|
||||||
/bbb.db
|
|
||||||
|
|
@ -1,62 +0,0 @@
|
||||||
! Copyright (C) 2020 .
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: kernel http.server http.server.responses http.server.dispatchers furnace.actions html.forms accessors namespaces io.servers io.sockets.secure.debug sequences validators ;
|
|
||||||
USING: bonerbonerboner.services bonerbonerboner.services.slack bonerbonerboner.services.mississippis bonerbonerboner.services.platzisms bonerbonerboner.services.link-logger ;
|
|
||||||
|
|
||||||
USING: prettyprint ;
|
|
||||||
IN: bonerbonerboner.api
|
|
||||||
|
|
||||||
TUPLE: bbb < dispatcher ;
|
|
||||||
|
|
||||||
: bbb-themes ( -- themes )
|
|
||||||
{ "bbb" "bones" "float" "hockey" "rocket" "burger" "wakeywakey" "dog" "piggy" "chick" } ;
|
|
||||||
|
|
||||||
: v-valid-theme ( str -- theme )
|
|
||||||
dup bbb-themes member? [ "not a valid theme" throw ] unless ;
|
|
||||||
|
|
||||||
: validate-theme ( -- )
|
|
||||||
{
|
|
||||||
{ "theme" [ v-required v-valid-theme ] }
|
|
||||||
} validate-params ;
|
|
||||||
|
|
||||||
: <theme-action> ( -- action )
|
|
||||||
<page-action>
|
|
||||||
[ validate-theme ] >>init
|
|
||||||
{ bbb "themes" } >>template ;
|
|
||||||
|
|
||||||
: <404-theme-action> ( -- action )
|
|
||||||
<page-action>
|
|
||||||
[ "_404" "theme" set-value ] >>init
|
|
||||||
{ bbb "themes" } >>template ;
|
|
||||||
|
|
||||||
: <heartbeat-action> ( -- action )
|
|
||||||
<action> [ "bonerbonerboner" <text-content> ] >>display ;
|
|
||||||
|
|
||||||
: <bbb> ( -- responder )
|
|
||||||
bbb new-dispatcher
|
|
||||||
<404-theme-action> >>default
|
|
||||||
<heartbeat-action> "heartbeat" add-responder
|
|
||||||
<slack-event-action> "slack-events" add-responder
|
|
||||||
<theme-action> "subdomain" add-responder ;
|
|
||||||
|
|
||||||
: add-default-slack-listeners ( -- )
|
|
||||||
{
|
|
||||||
[ check-mississippi-request ]
|
|
||||||
[ check-platz ]
|
|
||||||
[ check-links ]
|
|
||||||
} slack-callbacks set-global ;
|
|
||||||
|
|
||||||
SYMBOL: current-bbb-server
|
|
||||||
|
|
||||||
: <bbb-website-server> ( -- threaded-server )
|
|
||||||
<http-server>
|
|
||||||
f >>secure
|
|
||||||
8069 >>insecure ;
|
|
||||||
|
|
||||||
: start-bbb-site ( -- )
|
|
||||||
add-default-slack-listeners
|
|
||||||
<bbb> main-responder set-global
|
|
||||||
<bbb-website-server> start-server wait-for-server ;
|
|
||||||
|
|
||||||
MAIN: start-bbb-site
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
USING: tools.deploy.config ;
|
|
||||||
H{
|
|
||||||
{ deploy-console? t }
|
|
||||||
{ deploy-io 3 }
|
|
||||||
{ deploy-reflection 5 }
|
|
||||||
{ deploy-ui? f }
|
|
||||||
{ deploy-word-defs? f }
|
|
||||||
{ deploy-threads? t }
|
|
||||||
{ "stop-after-last-window?" t }
|
|
||||||
{ deploy-math? t }
|
|
||||||
{ deploy-word-props? f }
|
|
||||||
{ deploy-c-types? f }
|
|
||||||
{ deploy-help? f }
|
|
||||||
{ deploy-name "bonerbonerboner-api" }
|
|
||||||
{ deploy-unicode? f }
|
|
||||||
}
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
vocab:bonerbonerboner/templates
|
|
||||||
|
|
@ -1,11 +0,0 @@
|
||||||
<?xml version='1.0' ?>
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0" >
|
|
||||||
<html class="@theme" lang="en" >
|
|
||||||
<head>
|
|
||||||
<title>boners</title>
|
|
||||||
<meta name="viewport" content="width=device-width, initial-scale=1"/>
|
|
||||||
<link rel="stylesheet" type="text/css" href="https://static.bonerbonerboner.com/css/bbb.css" />
|
|
||||||
</head>
|
|
||||||
<body/>
|
|
||||||
</html>
|
|
||||||
</t:chloe>
|
|
||||||
|
|
@ -1,64 +0,0 @@
|
||||||
! Copyright (C) 2020 .
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: kernel sequences http http.server.dispatchers accessors vocabs.parser furnace.actions regexp db.types db.tuples math urls strings calendar assocs arrays formatting combinators.random ;
|
|
||||||
USING: bonerbonerboner.services bonerbonerboner.services.slack ;
|
|
||||||
|
|
||||||
IN: bonerbonerboner.services.link-logger
|
|
||||||
|
|
||||||
! TODO: index url and updated date
|
|
||||||
! TODO: add slack integration
|
|
||||||
|
|
||||||
TUPLE: link id url created-by updated-by repost-count date-created date-updated ;
|
|
||||||
|
|
||||||
link "links"
|
|
||||||
{
|
|
||||||
{ "id" "id" +db-assigned-id+ }
|
|
||||||
{ "url" "url" URL }
|
|
||||||
{ "repost-count" "repost_count" INTEGER }
|
|
||||||
{ "created-by" "created_by" TEXT }
|
|
||||||
{ "updated-by" "updated_by" TEXT }
|
|
||||||
{ "date-created" "date_created" TIMESTAMP }
|
|
||||||
{ "date-updated" "date_updated" TIMESTAMP }
|
|
||||||
} define-persistent
|
|
||||||
|
|
||||||
: ensure-link-logger ( -- )
|
|
||||||
[ link ensure-table ] with-bbb-db ;
|
|
||||||
|
|
||||||
: <link> ( url who -- link )
|
|
||||||
[ f ] 2dip dup 0 now dup link boa ;
|
|
||||||
|
|
||||||
: <repost> ( link who -- link )
|
|
||||||
slack-lookup-user [ dup repost-count>> 1 + >>repost-count ] dip >>updated-by now >>date-updated ;
|
|
||||||
|
|
||||||
: add-link ( url who -- )
|
|
||||||
ensure-link-logger [ <link> insert-tuple ] with-bbb-db ;
|
|
||||||
|
|
||||||
: random-callout ( repost -- )
|
|
||||||
{
|
|
||||||
[ ]
|
|
||||||
[ created-by>> "%s already posted that" sprintf ]
|
|
||||||
[ drop "nice repost" ]
|
|
||||||
} call-random say-slack ;
|
|
||||||
|
|
||||||
: update-repost ( link who -- )
|
|
||||||
ensure-link-logger [ <repost> dup update-tuple ] with-bbb-db random-callout ;
|
|
||||||
|
|
||||||
: repost? ( url -- link/f )
|
|
||||||
ensure-link-logger link new swap >>url [ select-tuple ] with-bbb-db ;
|
|
||||||
|
|
||||||
: url-regex ( -- regexp )
|
|
||||||
R/ http[s]?:\/\/(?:[a-zA-Z]|[0-9]|[$-_@.&+]|[!*\(\),]|(?:%[0-9a-fA-F][0-9a-fA-F]))+/i ;
|
|
||||||
|
|
||||||
: strip-urls ( str -- seq )
|
|
||||||
url-regex all-matching-subseqs ;
|
|
||||||
|
|
||||||
: check-repost ( url who -- )
|
|
||||||
[ dup repost? ] dip swap [ swap update-repost drop ] [ add-link ] if* ;
|
|
||||||
|
|
||||||
: check-link ( url who -- )
|
|
||||||
check-repost ;
|
|
||||||
|
|
||||||
: check-links ( event -- )
|
|
||||||
[ "text" of strip-urls dup length ] [ "user" of ] bi <array>
|
|
||||||
[ check-link ] 2each ;
|
|
||||||
|
|
@ -1,121 +0,0 @@
|
||||||
! Copyright (C) 2020 .
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel math math.order math.parser math.functions ranges arrays sequences sequences.extras threads calendar io timers accessors random formatting combinators combinators.random http.server.responses regexp unicode peg peg.parsers assocs db.types db.tuples ;
|
|
||||||
|
|
||||||
USING: bonerbonerboner.services ;
|
|
||||||
FROM: bonerbonerboner.services.slack => slack-lookup-user say-slack ;
|
|
||||||
|
|
||||||
IN: bonerbonerboner.services.mississippis
|
|
||||||
|
|
||||||
CONSTANT: max-mississippi-count 30
|
|
||||||
CONSTANT: min-mississippi-count 1
|
|
||||||
|
|
||||||
TUPLE: mississippis id standard-mississippi? terminal requester requested-on ;
|
|
||||||
|
|
||||||
mississippis "mississippis"
|
|
||||||
{
|
|
||||||
{ "id" "id" +db-assigned-id+ }
|
|
||||||
{ "standard-mississippi?" "is_standard" BOOLEAN }
|
|
||||||
{ "terminal" "terminal" INTEGER }
|
|
||||||
{ "requester" "requester" VARCHAR }
|
|
||||||
{ "requested-on" "requested_on" TIMESTAMP }
|
|
||||||
} define-persistent
|
|
||||||
|
|
||||||
: parse-mississippi-request ( str -- standard? terminal )
|
|
||||||
>lower integer-parser " standard" token optional [ >boolean ] action 2seq parse
|
|
||||||
[ second ] [ first ] bi ;
|
|
||||||
|
|
||||||
: <mississippis> ( event -- mississippis )
|
|
||||||
[ f ] dip
|
|
||||||
[ "text" of parse-mississippi-request ]
|
|
||||||
[ "user" of slack-lookup-user ]
|
|
||||||
[ "event_ts" of string>number unix-time>timestamp ] tri
|
|
||||||
mississippis boa ;
|
|
||||||
|
|
||||||
: random-stupid-word ( -- something-stupid )
|
|
||||||
{ "balls" "fart" "SIEEEEEEEEEEGE" "hey" "HONESTLY" "fuckface" "it's too late-TOOOOO LATE" }
|
|
||||||
random ;
|
|
||||||
|
|
||||||
: random-m-word ( -- m-word )
|
|
||||||
{ "Minnesota" "Montana" "Marsupial" "Minneapolis" }
|
|
||||||
random ;
|
|
||||||
|
|
||||||
: random-no-word ( -- nope )
|
|
||||||
{ "No can doobie" "Can't do that" "I don't think so, kev" "nope" "Can't, learn the rules" }
|
|
||||||
random ;
|
|
||||||
|
|
||||||
: nonstandard-mississippi-duration ( -- duration )
|
|
||||||
.5 1.75 uniform-random-float seconds ;
|
|
||||||
|
|
||||||
: standard-mississippi-duration ( -- duration )
|
|
||||||
1 seconds ;
|
|
||||||
|
|
||||||
: nonstandard-mississippi-wait ( -- )
|
|
||||||
nonstandard-mississippi-duration sleep ;
|
|
||||||
|
|
||||||
: valid-mississippi-count? ( n -- ? )
|
|
||||||
min-mississippi-count max-mississippi-count between? ;
|
|
||||||
|
|
||||||
: announce ( str -- )
|
|
||||||
say-slack ;
|
|
||||||
|
|
||||||
: announce-sip ( sip -- )
|
|
||||||
"%d Mississippi" sprintf announce ;
|
|
||||||
|
|
||||||
: announce-fake-terminal ( terminal -- )
|
|
||||||
number>string random-m-word 2array " " join announce ;
|
|
||||||
|
|
||||||
: announce-random-stupid-word ( -- )
|
|
||||||
random-stupid-word announce ;
|
|
||||||
|
|
||||||
: announce-random-sip ( -- )
|
|
||||||
1000 random announce-sip ;
|
|
||||||
|
|
||||||
: announce-go! ( -- )
|
|
||||||
"GO!" announce ;
|
|
||||||
|
|
||||||
: announce-standard-mississippis ( terminal -- )
|
|
||||||
[1..b] [ standard-mississippi-duration sleep announce-sip ] each ;
|
|
||||||
|
|
||||||
:: announce-nonstandard-mississippi ( terminal sip -- )
|
|
||||||
{
|
|
||||||
{ .3 [ ] }
|
|
||||||
{ .1 [ announce-random-sip ] }
|
|
||||||
{ .075 [ announce-random-stupid-word ] }
|
|
||||||
{ .025 [ terminal announce-fake-terminal nonstandard-mississippi-wait ] }
|
|
||||||
{ .5 [ sip announce-sip ] }
|
|
||||||
} casep ;
|
|
||||||
|
|
||||||
: announce-nonstandard-mississippis ( terminal -- )
|
|
||||||
[
|
|
||||||
[ dup <array> ] [ 1 - [1..b] ] bi
|
|
||||||
[ nonstandard-mississippi-wait announce-nonstandard-mississippi ] 2each
|
|
||||||
]
|
|
||||||
[ announce-sip ] bi ;
|
|
||||||
|
|
||||||
: announce-mississippis ( terminal standard? -- )
|
|
||||||
[ announce-standard-mississippis ] [ announce-nonstandard-mississippis ] if ;
|
|
||||||
|
|
||||||
: mississippi-go! ( standard? terminal -- )
|
|
||||||
dup valid-mississippi-count?
|
|
||||||
[ announce-go! swap announce-mississippis ]
|
|
||||||
[ 2drop random-no-word announce ] if ;
|
|
||||||
|
|
||||||
: log-mississippi-request ( mississippi -- )
|
|
||||||
[
|
|
||||||
mississippis ensure-table
|
|
||||||
insert-tuple
|
|
||||||
] with-bbb-db ;
|
|
||||||
|
|
||||||
: is-mississippi-request? ( str -- ? )
|
|
||||||
R/ ^\d\d? (standard )?mississippis? go!?/i matches? ;
|
|
||||||
|
|
||||||
: check-mississippi-request ( event -- )
|
|
||||||
dup
|
|
||||||
"text" of is-mississippi-request?
|
|
||||||
[
|
|
||||||
<mississippis>
|
|
||||||
[ [ standard-mississippi?>> ] [ terminal>> ] bi mississippi-go! ]
|
|
||||||
[ log-mississippi-request ] bi
|
|
||||||
]
|
|
||||||
[ drop ] if ;
|
|
||||||
|
|
@ -1,61 +0,0 @@
|
||||||
! Copyright (C) 2020 .
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel regexp sequences http.server http.server.responses db db.types db.tuples unicode formatting assocs ;
|
|
||||||
USING: bonerbonerboner.services bonerbonerboner.services.slack ;
|
|
||||||
|
|
||||||
IN: bonerbonerboner.services.platzisms
|
|
||||||
|
|
||||||
TUPLE: platzism id quote ;
|
|
||||||
|
|
||||||
platzism "platzisms"
|
|
||||||
{
|
|
||||||
{ "id" "id" +db-assigned-id+ }
|
|
||||||
{ "quote" "quote" TEXT }
|
|
||||||
} define-persistent
|
|
||||||
|
|
||||||
: ensure-platzisms ( -- )
|
|
||||||
[ platzism ensure-table ] with-bbb-db ;
|
|
||||||
|
|
||||||
: <platzism> ( str -- platzism )
|
|
||||||
[ f ] dip platzism boa ;
|
|
||||||
|
|
||||||
: add-platzism ( str -- )
|
|
||||||
ensure-platzisms
|
|
||||||
[ <platzism> insert-tuple ] with-bbb-db ;
|
|
||||||
|
|
||||||
: platzism-exists? ( str -- ? )
|
|
||||||
ensure-platzisms
|
|
||||||
[ >lower "SELECT id FROM platzisms WHERE lower(quote) = '%s'" sprintf sql-query ] with-bbb-db empty? not ;
|
|
||||||
|
|
||||||
: is-platz? ( str -- ? )
|
|
||||||
R/ ^platz\?$/i matches? ;
|
|
||||||
|
|
||||||
: is-platzism? ( str -- ? )
|
|
||||||
R/ ^steve platz is currently .+/i matches? ;
|
|
||||||
|
|
||||||
: random-platzism ( -- platzism )
|
|
||||||
ensure-platzisms
|
|
||||||
"SELECT quote from platzisms ORDER BY RANDOM() LIMIT 1" [ sql-query ] with-bbb-db
|
|
||||||
dup empty? [ drop "I'm not sure what Platz is up to." ] [ first first ] if ;
|
|
||||||
|
|
||||||
: repost-callout ( -- )
|
|
||||||
"We already know Platz is doing that" say-slack ;
|
|
||||||
|
|
||||||
: confirm-platzism ( -- )
|
|
||||||
"noted" say-slack ;
|
|
||||||
|
|
||||||
: share-platzism ( -- )
|
|
||||||
random-platzism say-slack ;
|
|
||||||
|
|
||||||
: log/confirm-platzism ( str -- )
|
|
||||||
dup platzism-exists?
|
|
||||||
[ drop repost-callout ]
|
|
||||||
[
|
|
||||||
add-platzism
|
|
||||||
confirm-platzism
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: check-platz ( event -- )
|
|
||||||
"text" of
|
|
||||||
[ is-platz? [ share-platzism ] when ]
|
|
||||||
[ dup is-platzism? [ log/confirm-platzism ] [ drop ] if ] bi ;
|
|
||||||
|
|
@ -1,20 +0,0 @@
|
||||||
! Copyright (C) 2020 .
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: kernel fry db db.pools db.sqlite environment math.parser io.pathnames ;
|
|
||||||
|
|
||||||
IN: bonerbonerboner.services
|
|
||||||
|
|
||||||
CONSTANT: bbb-default-port 8069
|
|
||||||
|
|
||||||
: bbb-data-directory ( -- path )
|
|
||||||
home ".bonerbonerboner" append-path ;
|
|
||||||
|
|
||||||
: <bbb-sqlite-db> ( -- db-pool )
|
|
||||||
bbb-data-directory "bbb.db" append-path <sqlite-db> <db-pool> ;
|
|
||||||
|
|
||||||
: with-bbb-db ( quot -- )
|
|
||||||
'[ <bbb-sqlite-db> _ with-pooled-db ] call ; inline
|
|
||||||
|
|
||||||
: bbb-api-port ( -- port )
|
|
||||||
"BBB_API_PORT" os-env [ string>number ] [ bbb-default-port ] if* ;
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
! Copyright (C) 2020 .
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
|
|
||||||
USING: io.sockets.secure kernel http http.server http.server.dispatchers accessors furnace.actions namespaces http.server.responses io.servers io.sockets.secure.debug json.reader assocs combinators sequences arrays threads locals formatting json.writer urls http.client hashtables math ;
|
|
||||||
USING: prettyprint io.encodings.utf8 io io.files environment ;
|
|
||||||
|
|
||||||
IN: bonerbonerboner.services.slack
|
|
||||||
|
|
||||||
SYMBOLS: slack-callbacks ;
|
|
||||||
|
|
||||||
{ } slack-callbacks set-global
|
|
||||||
|
|
||||||
TUPLE: slack < dispatcher ;
|
|
||||||
|
|
||||||
: <bad-callback-response> ( -- response )
|
|
||||||
"400" "unrecognized event type" <trivial-response> ;
|
|
||||||
|
|
||||||
: <heartbeat-response> ( -- response )
|
|
||||||
"slack" <text-content> ;
|
|
||||||
|
|
||||||
: handle-challenge ( json -- response )
|
|
||||||
"challenge" of <text-content> ;
|
|
||||||
|
|
||||||
:: handle-slack-event ( slack-event -- response )
|
|
||||||
"bot_id" slack-event key? "subtype" slack-event key? or
|
|
||||||
[
|
|
||||||
slack-callbacks get length slack-event <array>
|
|
||||||
slack-callbacks get [ curry "Slack Callback" spawn drop ] 2each
|
|
||||||
] unless
|
|
||||||
<200> ;
|
|
||||||
|
|
||||||
: <slack-event-action> ( -- action )
|
|
||||||
<action>
|
|
||||||
[
|
|
||||||
request get post-data>> data>> json> dup
|
|
||||||
"type" of
|
|
||||||
{
|
|
||||||
{ "url_verification" [ handle-challenge ] }
|
|
||||||
{ "event_callback" [ "event" of handle-slack-event ] }
|
|
||||||
[ drop <bad-callback-response> ]
|
|
||||||
} case
|
|
||||||
] >>submit ;
|
|
||||||
|
|
||||||
: slack-lookup-user ( id -- name )
|
|
||||||
[
|
|
||||||
"https://slack.com/api/users.profile.get" >url
|
|
||||||
{ "user" "token" }
|
|
||||||
] dip
|
|
||||||
"SLACK_AUTH_TOKEN" os-env 2array zip
|
|
||||||
set-query-params
|
|
||||||
http-get swap drop json>
|
|
||||||
"profile" of "real_name" of ;
|
|
||||||
|
|
||||||
: slack-post-message ( payload -- )
|
|
||||||
>json
|
|
||||||
"SLACK_WEBHOOK_URL" os-env >url
|
|
||||||
<post-request>
|
|
||||||
http-request 2drop ;
|
|
||||||
|
|
||||||
: say-slack ( str -- )
|
|
||||||
! . flush ;
|
|
||||||
"text" associate
|
|
||||||
slack-post-message ;
|
|
||||||
|
|
@ -1,11 +0,0 @@
|
||||||
<?xml version='1.0' ?>
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0" >
|
|
||||||
<html class="@theme" lang="en" >
|
|
||||||
<head>
|
|
||||||
<title>boners</title>
|
|
||||||
<meta name="viewport" content="width=device-width, initial-sale=1"/>
|
|
||||||
<link rel="stylesheet" type="text/css" href="https://static.bonerbonerboner.com/css/bbb.css" />
|
|
||||||
</head>
|
|
||||||
<body/>
|
|
||||||
</html>
|
|
||||||
</t:chloe>
|
|
||||||
|
|
@ -1,12 +1,9 @@
|
||||||
USING: kernel http http.client http.server io.streams.byte-array io.pathnames io.encodings.binary io.encodings.string io.encodings.utf8 io.launcher accessors urls parser effects.parser words arrays sequences quotations json.reader json.writer formatting assocs namespaces present hashtables words.symbol combinators lexer calendar prettyprint.backend base64 images.png ;
|
USING: kernel http http.client http.server io.sockets io.streams.byte-array io.pathnames io.encodings.binary io.encodings.string io.encodings.utf8 io.launcher accessors urls parser effects.parser words arrays sequences quotations json.reader json.writer formatting assocs namespaces present hashtables words.symbol combinators lexer calendar prettyprint.backend base64 images.png destructors math.parser threads ;
|
||||||
USING: prettyprint ;
|
USING: prettyprint ;
|
||||||
|
|
||||||
IN: web-driver
|
IN: web-driver
|
||||||
|
|
||||||
|
SYMBOL: current-web-driver-session
|
||||||
|
|
||||||
SYMBOL: current-session-id
|
|
||||||
SYMBOL: current-remote-host
|
|
||||||
|
|
||||||
! https://www.w3.org/TR/webdriver/#elements
|
! https://www.w3.org/TR/webdriver/#elements
|
||||||
CONSTANT: web-element-identifier "element-6066-11e4-a52e-4f735466cecf"
|
CONSTANT: web-element-identifier "element-6066-11e4-a52e-4f735466cecf"
|
||||||
|
|
@ -17,20 +14,27 @@ CONSTANT: partial-link-text-location-strategy "partial link text"
|
||||||
CONSTANT: tag-name-location-strategy "tag name"
|
CONSTANT: tag-name-location-strategy "tag name"
|
||||||
CONSTANT: xpath-location-strategy "xpath"
|
CONSTANT: xpath-location-strategy "xpath"
|
||||||
|
|
||||||
TUPLE: web-driver uri session-id process ;
|
TUPLE: web-driver-session remote-url session-id capabilities ;
|
||||||
TUPLE: session-status message ready? ;
|
TUPLE: session-status message ready? ;
|
||||||
|
|
||||||
|
: current-web-driver-session> ( -- session )
|
||||||
|
current-web-driver-session get ;
|
||||||
|
: >current-web-driver-session ( session -- )
|
||||||
|
current-web-driver-session set ;
|
||||||
|
|
||||||
|
: current-session-id ( -- session-id )
|
||||||
|
current-web-driver-session> session-id>> ;
|
||||||
|
: current-remote-url ( -- remote-url )
|
||||||
|
current-web-driver-session> remote-url>> ;
|
||||||
|
|
||||||
: current-session-relative-url ( -- url )
|
: current-session-relative-url ( -- url )
|
||||||
"session" current-session-id get append-path >url ;
|
"session" current-session-id get append-path >url ;
|
||||||
|
|
||||||
: current-base-url ( -- url )
|
|
||||||
current-remote-host get >url ;
|
|
||||||
|
|
||||||
: current-session-url ( -- url )
|
: current-session-url ( -- url )
|
||||||
current-base-url current-session-relative-url derive-url ;
|
current-remote-url current-session-relative-url derive-url ;
|
||||||
|
|
||||||
: <web-driver-url> ( path -- url )
|
: <web-driver-url> ( path -- url )
|
||||||
[ current-base-url ] dip >url derive-url ;
|
[ current-remote-url ] dip >url derive-url ;
|
||||||
|
|
||||||
: <web-driver-session-url> ( path -- url )
|
: <web-driver-session-url> ( path -- url )
|
||||||
[ current-session-url present ] dip append-path >url ;
|
[ current-session-url present ] dip append-path >url ;
|
||||||
|
|
@ -81,6 +85,12 @@ TUPLE: capabilities { always-match hashtable } { first-match hashtable } ;
|
||||||
[ always-match>> ] [ first-match>> ] bi
|
[ always-match>> ] [ first-match>> ] bi
|
||||||
'H{ { "alwaysMatch" _ } { "firstMatch" _ } } 'H{ { "capabilities" _ } } ;
|
'H{ { "alwaysMatch" _ } { "firstMatch" _ } } 'H{ { "capabilities" _ } } ;
|
||||||
|
|
||||||
|
: <headless-firefox-capabilities> ( -- hash )
|
||||||
|
H{
|
||||||
|
{ "browserName" "firefox" }
|
||||||
|
{ "moz:firefoxOptions" { "args" { "-headless" } } }
|
||||||
|
} ;
|
||||||
|
|
||||||
! Sessions
|
! Sessions
|
||||||
! https://www.w3.org/TR/webdriver/#sessions
|
! https://www.w3.org/TR/webdriver/#sessions
|
||||||
|
|
||||||
|
|
@ -316,12 +326,31 @@ TUPLE: rect x y width height ;
|
||||||
: take-element-screenshot ( element -- loading-png )
|
: take-element-screenshot ( element -- loading-png )
|
||||||
"screenshot" <element-get-request> http-web-driver-request base64> binary <byte-reader> load-png ;
|
"screenshot" <element-get-request> http-web-driver-request base64> binary <byte-reader> load-png ;
|
||||||
|
|
||||||
|
! TODO: Actions
|
||||||
|
|
||||||
! TODO: handle driver processes better
|
! TODO: handle driver processes better
|
||||||
|
|
||||||
: <chrome-driver-stream> ( url capabilities -- stream )
|
: get-free-listen-port ( -- port )
|
||||||
2drop
|
<any-port-local-inet4> utf8 <server>
|
||||||
|
[ addr>> port>> ] [ dispose ] bi number>string ;
|
||||||
|
|
||||||
|
: <chrome-driver-process> ( capabilities -- process )
|
||||||
|
drop
|
||||||
"chromedriver --silent --port 4444" utf8 <process-stream> ;
|
"chromedriver --silent --port 4444" utf8 <process-stream> ;
|
||||||
|
|
||||||
: <gecko-driver-stream> ( url capabilities -- stream )
|
: <gecko-driver-process> ( host port -- process )
|
||||||
2drop
|
'{ "geckodriver" "--host" _ "--port" _ } utf8 <process-reader> ;
|
||||||
"geckodriver --port 4444" utf8 <process-stream> ;
|
|
||||||
|
: <web-driver-session> ( -- )
|
||||||
|
"127.0.0.1" get-free-listen-port
|
||||||
|
[ ":" prepend append "http://" prepend "/" append >url ]
|
||||||
|
[ <gecko-driver-process> ] 2bi
|
||||||
|
f f web-driver-session boa
|
||||||
|
>current-web-driver-session ;
|
||||||
|
|
||||||
|
! [ ready?>> ] [ status 1 seconds sleep ] do until
|
||||||
|
!
|
||||||
|
! new-session [ "sessionId" of ] [ "capabilities" of ] bi
|
||||||
|
!
|
||||||
|
! current-web-driver-session> swap >>capabilities swap >>session-id
|
||||||
|
! >current-web-driver-session ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue