urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-01 14:42:02 +03:00
Code Issues Packages Projects Releases Wiki Activity
d98c59e73a
shrub/pkg/arvo/sys/zuse.hoon
fang d98c59e73a
zuse: lift moves out of +able
2020-12-08 01:47:06 +01:00

7793 lines
273 KiB
Plaintext
Raw Blame History

:: /sys/zuse
:: %reference/1
:: %zuse: arvo library
::
:: %zuse is two nested cores: the first for models
:: (data structures), the second for engines (functions
:: or classes).
::
:: each of these stages is split into cores for each of
:: arvo's eight major vanes (kernel modules). these are:
::
:: - %ames: networking (rhymes with "games")
:: - %behn: scheduling ("bane")
:: - %clay: revision control ("play")
:: - %dill: console ("pill")
:: - %eyre: http server ("fair")
:: - %gall: application ("ball")
:: - %iris: http client ("virus")
:: - %jael: security ("jail")
::
:: with %zuse in your core, the engines of any vane are
:: available at `engine:vane`. the models (molds) are
:: available at `mold:^vane`.
::
:: every model or engine in %zuse is attached to some
:: vane, but any vane can use it (in its namespace),
:: as can any normal user-level code.
::
:: it's important to keep %zuse minimal. models and
:: engines not used outside a vane should stay inside
:: that vane.
~% %zuse ..part ~
=>
:: :: ::
:::: :: :: (1) models
:: :: ::
|%
:: # %misc
::
:: miscellaneous systems types
::+|
:: +capped-queue: a +qeu with a maximum number of entries
::
++ capped-queue
|$ [item-type]
$: queue=(qeu item-type)
size=@ud
max-size=_64
==
:: +clock: polymorphic cache type for use with the clock replacement algorithm
::
:: The +by-clock core wraps interface arms for manipulating a mapping from
:: :key-type to :val-type. Detailed docs for this type can be found there.
::
++ clock
|$ :: key-type: mold of keys
:: val-type: mold of values
::
[key-type val-type]
$: lookup=(map key-type [val=val-type fresh=@ud])
queue=(qeu key-type)
size=@ud
max-size=_2.048
depth=_1
==
::
+$ deco ?(~ %bl %br %un) :: text decoration
+$ json :: normal json value
$@ ~ :: null
$% [%a p=(list json)] :: array
[%b p=?] :: boolean
[%o p=(map @t json)] :: object
[%n p=@ta] :: number
[%s p=@t] :: string
== ::
+$ life @ud :: ship key revision
+$ rift @ud :: ship continuity
+$ mime (pair mite octs) :: mimetyped data
+$ octs (pair @ud @) :: octet-stream
+$ sock (pair ship ship) :: outgoing [our his]
+$ stub (list (pair stye (list @c))) :: styled unicode
+$ stye (pair (set deco) (pair tint tint)) :: decos/bg/fg
+$ styl %+ pair (unit deco) :: cascading style
(pair (unit tint) (unit tint)) ::
+$ styx (list $@(@t (pair styl styx))) :: styled text
+$ tint $@ ?(%r %g %b %c %m %y %k %w %~) :: text color
[r=@uxD g=@uxD b=@uxD] :: 24bit true color
+$ turf (list @t) :: domain, tld first
:: ::::
:::: ++ethereum-types :: eth surs for jael
:: ::::
++ ethereum-types
|%
:: ethereum address, 20 bytes.
::
++ address @ux
:: event location
::
+$ event-id [block=@ud log=@ud]
::
++ events (set event-id)
--
:: ::::
:::: ++azimuth-types :: az surs for jael
:: ::::
++ azimuth-types
=, ethereum-types
|%
++ point
$: :: ownership
::
$= own
$: owner=address
management-proxy=address
voting-proxy=address
transfer-proxy=address
==
::
:: networking
::
$= net
%- unit
$: =life
=pass
continuity-number=@ud
sponsor=[has=? who=@p]
escape=(unit @p)
==
::
:: spawning
::
$= kid
%- unit
$: spawn-proxy=address
spawned=(set @p) ::TODO sparse range, pile, see old jael ++py
==
==
::
+$ dnses [pri=@t sec=@t ter=@t]
::
++ diff-azimuth
$% [%point who=@p dif=diff-point]
[%dns dnses]
==
::
++ diff-point
$% [%full new=point] ::
[%owner new=address] :: OwnerChanged
[%activated who=@p] :: Activated
[%spawned who=@p] :: Spawned
[%keys =life =pass] :: ChangedKeys
[%continuity new=@ud] :: BrokeContinuity
[%sponsor new=[has=? who=@p]] :: EscapeAcc/LostSpons
[%escape new=(unit @p)] :: EscapeReq/Can
[%management-proxy new=address] :: ChangedManagementPro
[%voting-proxy new=address] :: ChangedVotingProxy
[%spawn-proxy new=address] :: ChangedSpawnProxy
[%transfer-proxy new=address] :: ChangedTransferProxy
==
--
:: +vane-task: general tasks shared across vanes
::
+$ vane-task
$~ [%born ~]
$% :: i/o device replaced (reset state)
::
[%born ~]
:: error report
::
[%crud p=@tas q=(list tank)]
:: boot completed (XX legacy)
::
[%init ~]
:: trim state (in response to memory pressure)
::
[%trim p=@ud]
:: kernel upgraded
::
[%vega ~]
:: receive message via %ames
::
:: TODO: move .vane from $plea to here
::
[%plea =ship =plea:ames]
==
:: ::::
:::: ++http ::
:: ::::
:: http: shared representations of http concepts
::
++ http ^?
|%
:: +header-list: an ordered list of http headers
::
+$ header-list
(list [key=@t value=@t])
:: +method: exhaustive list of http verbs
::
+$ method
$? %'CONNECT'
%'DELETE'
%'GET'
%'HEAD'
%'OPTIONS'
%'POST'
%'PUT'
%'TRACE'
==
:: +request: a single http request
::
+$ request
$: :: method: http method
::
method=method
:: url: the url requested
::
:: The url is not escaped. There is no escape.
::
url=@t
:: header-list: headers to pass with this request
::
=header-list
:: body: optionally, data to send with this request
::
body=(unit octs)
==
:: +response-header: the status code and header list on an http request
::
:: We separate these away from the body data because we may not wait for
:: the entire body before we send a %progress to the caller.
::
+$ response-header
$: :: status: http status code
::
status-code=@ud
:: headers: http headers
::
headers=header-list
==
:: +http-event: packetized http
::
:: Urbit treats Earth's HTTP servers as pipes, where Urbit sends or
:: receives one or more %http-events. The first of these will always be a
:: %start or an %error, and the last will always be %cancel or will have
:: :complete set to %.y to finish the connection.
::
:: Calculation of control headers such as 'Content-Length' or
:: 'Transfer-Encoding' should be performed at a higher level; this structure
:: is merely for what gets sent to or received from Earth.
::
+$ http-event
$% :: %start: the first packet in a response
::
$: %start
:: response-header: first event information
::
=response-header
:: data: data to pass to the pipe
::
data=(unit octs)
:: whether this completes the request
::
complete=?
==
:: %continue: every subsequent packet
::
$: %continue
:: data: data to pass to the pipe
::
data=(unit octs)
:: complete: whether this completes the request
::
complete=?
==
:: %cancel: represents unsuccessful termination
::
[%cancel ~]
==
:: +get-header: returns the value for :header, if it exists in :header-list
::
++ get-header
|= [header=@t =header-list]
^- (unit @t)
::
?~ header-list
~
::
?: =(key.i.header-list header)
`value.i.header-list
::
$(header-list t.header-list)
:: +set-header: sets the value of an item in the header list
::
:: This adds to the end if it doesn't exist.
::
++ set-header
|= [header=@t value=@t =header-list]
^- ^header-list
::
?~ header-list
:: we didn't encounter the value, add it to the end
::
[[header value] ~]
::
?: =(key.i.header-list header)
[[header value] t.header-list]
::
[i.header-list $(header-list t.header-list)]
:: +delete-header: removes the first instance of a header from the list
::
++ delete-header
|= [header=@t =header-list]
^- ^header-list
::
?~ header-list
~
:: if we see it in the list, remove it
::
?: =(key.i.header-list header)
t.header-list
::
[i.header-list $(header-list t.header-list)]
:: +unpack-header: parse header field values
::
++ unpack-header
|^ |= value=@t
^- (unit (list (map @t @t)))
(rust (cass (trip value)) values)
::
++ values
%+ more
(ifix [. .]:(star ;~(pose ace (just '\09'))) com)
pairs
::
++ pairs
%+ cook
~(gas by *(map @t @t))
%+ most (ifix [. .]:(star ace) mic)
;~(plug token ;~(pose ;~(pfix tis value) (easy '')))
::
++ value
;~(pose token quoted-string)
::
++ token :: 7230 token
%+ cook crip
::NOTE this is ptok:de-purl:html, but can't access that here
%- plus
;~ pose
aln zap hax buc cen pam soq tar lus
hep dot ket cab tic bar sig
==
::
++ quoted-string :: 7230 quoted string
%+ cook crip
%+ ifix [. .]:;~(less (jest '\\"') doq)
%- star
;~ pose
;~(pfix bas ;~(pose (just '\09') ace prn))
;~(pose (just '\09') ;~(less (mask "\22\5c\7f") (shim 0x20 0xff)))
==
--
:: +simple-payload: a simple, one event response used for generators
::
+$ simple-payload
$: :: response-header: status code, etc
::
=response-header
:: data: the data returned as the body
::
data=(unit octs)
==
--
:: ::::
:::: ++ames :: (1a) network
:: ::::
++ ames ^?
|%
:: $task: job for ames
::
:: Messaging Tasks
::
:: %hear: packet from unix
:: %hole: report that packet handling crashed
:: %heed: track peer's responsiveness; gives %clog if slow
:: %jilt: stop tracking peer's responsiveness
:: %plea: request to send message
::
:: System and Lifecycle Tasks
::
:: %born: process restart notification
:: %crud: crash report
:: %init: vane boot
:: %sift: limit verbosity to .ships
:: %spew: set verbosity toggles
:: %trim: release memory
:: %vega: kernel reload notification
::
+$ task
$% [%hear =lane =blob]
[%hole =lane =blob]
[%heed =ship]
[%jilt =ship]
$>(%plea vane-task)
::
$>(%born vane-task)
$>(%crud vane-task)
$>(%init vane-task)
[%sift ships=(list ship)]
[%spew veb=(list verb)]
[%stir arg=@t]
$>(%trim vane-task)
$>(%vega vane-task)
==
:: $gift: effect from ames
::
:: Messaging Gifts
::
:: %boon: response message from remote ship
:: %clog: notify vane that %boon's to peer are backing up locally
:: %done: notify vane that peer (n)acked our message
:: %lost: notify vane that we crashed on %boon
:: %send: packet to unix
::
:: System and Lifecycle Gifts
::
:: %turf: domain report, relayed from jael
::
+$ gift
$% [%boon payload=*]
[%clog =ship]
[%done error=(unit error)]
[%lost ~]
[%send =lane =blob]
::
[%turf turfs=(list turf)]
==
::
:::: :: (1a2)
::
++ acru $_ ^? :: asym cryptosuite
|% :: opaque object
++ as ^? :: asym ops
|% ++ seal |~([a=pass b=@] *@) :: encrypt to a
++ sign |~(a=@ *@) :: certify as us
++ sure |~(a=@ *(unit @)) :: authenticate from us
++ tear |~([a=pass b=@] *(unit @)) :: accept from a
-- ::as ::
++ de |~([a=@ b=@] *(unit @)) :: symmetric de, soft
++ dy |~([a=@ b=@] *@) :: symmetric de, hard
++ en |~([a=@ b=@] *@) :: symmetric en
++ ex ^? :: export
|% ++ fig *@uvH :: fingerprint
++ pac *@uvG :: default passcode
++ pub *pass :: public key
++ sec *ring :: private key
-- ::ex ::
++ nu ^? :: reconstructors
|% ++ pit |~([a=@ b=@] ^?(..nu)) :: from [width seed]
++ nol |~(a=ring ^?(..nu)) :: from ring
++ com |~(a=pass ^?(..nu)) :: from pass
-- ::nu ::
-- ::acru ::
:: $address: opaque atomic transport address to or from unix
::
+$ address @uxaddress
:: $verb: verbosity flag for ames
::
+$ verb ?(%snd %rcv %odd %msg %ges %for %rot)
:: $blob: raw atom to or from unix, representing a packet
::
+$ blob @uxblob
:: $error: tagged diagnostic trace
::
+$ error [tag=@tas =tang]
:: $lane: ship transport address; either opaque $address or galaxy
::
:: The runtime knows how to look up galaxies, so we don't need to
:: know their transport addresses.
::
+$ lane (each @pC address)
:: $plea: application-level message, as a %pass
::
:: vane: destination vane on remote ship
:: path: internal route on the receiving ship
:: payload: semantic message contents
::
+$ plea [vane=@tas =path payload=*]
::
:: +| %atomics
::
+$ bone @udbone
+$ fragment @uwfragment
+$ fragment-num @udfragmentnum
+$ message-blob @udmessageblob
+$ message-num @udmessagenum
+$ public-key @uwpublickey
+$ symmetric-key @uwsymmetrickey
::
:: +| %kinetics
:: $ack: positive ack, nack packet, or nack trace
::
+$ ack
$% [%ok ~]
[%nack ~]
[%naxplanation =error]
==
::
:: +| %statics
:: $ship-state: all we know about a peer
::
:: %alien: no PKI data, so enqueue actions to perform once we learn it
:: %known: we know their life and public keys, so we have a channel
::
+$ ship-state
$% [%alien alien-agenda]
[%known peer-state]
==
:: $alien-agenda: what to do when we learn a peer's life and keys
::
:: messages: pleas local vanes have asked us to send
:: packets: packets we've tried to send
:: heeds: local tracking requests; passed through into $peer-state
::
+$ alien-agenda
$: messages=(list [=duct =plea])
packets=(set =blob)
heeds=(set duct)
==
:: $peer-state: state for a peer with known life and keys
::
:: route: transport-layer destination for packets to peer
:: qos: quality of service; connection status to peer
:: ossuary: bone<->duct mapper
:: snd: per-bone message pumps to send messages as fragments
:: rcv: per-bone message sinks to assemble messages from fragments
:: nax: unprocessed nacks (negative acknowledgments)
:: Each value is ~ when we've received the ack packet but not a
:: nack-trace, or an error when we've received a nack-trace but
:: not the ack packet.
::
:: When we hear a nack packet or an explanation, if there's no
:: entry in .nax, we make a new entry. Otherwise, if this new
:: information completes the packet+nack-trace, we remove the
:: entry and emit a nack to the local vane that asked us to send
:: the message.
:: heeds: listeners for %clog notifications
::
+$ peer-state
$: $: =symmetric-key
=life
=public-key
sponsor=ship
==
route=(unit [direct=? =lane])
=qos
=ossuary
snd=(map bone message-pump-state)
rcv=(map bone message-sink-state)
nax=(set [=bone =message-num])
heeds=(set duct)
==
:: $qos: quality of service; how is our connection to a peer doing?
::
:: .last-contact: last time we heard from peer, or if %unborn, when
:: we first started tracking time
::
+$ qos
$~ [%unborn *@da]
[?(%live %dead %unborn) last-contact=@da]
:: $ossuary: bone<->duct bijection and .next-bone to map to a duct
::
:: The first bone is 0. They increment by 4, since each flow includes
:: a bit for each message determining forward vs. backward and a
:: second bit for whether the message is on the normal flow or the
:: associated diagnostic flow (for naxplanations).
::
:: The least significant bit of a $bone is:
:: 1 if "forward", i.e. we send %plea's on this flow, or
:: 0 if "backward", i.e. we receive %plea's on this flow.
::
:: The second-least significant bit is 1 if the bone is a
:: naxplanation bone, and 0 otherwise. Only naxplanation
:: messages can be sent on a naxplanation bone, as %boon's.
::
+$ ossuary
$: =next=bone
by-duct=(map duct bone)
by-bone=(map bone duct)
==
:: $message-pump-state: persistent state for |message-pump
::
:: Messages queue up in |message-pump's .unsent-messages until they
:: can be packetized and fed into |packet-pump for sending. When we
:: pop a message off .unsent-messages, we push as many fragments as
:: we can into |packet-pump, which sends every packet it eats.
:: Packets rejected by |packet-pump are placed in .unsent-fragments.
::
:: When we hear a packet ack, we send it to |packet-pump to be
:: removed from its queue of unacked packets.
::
:: When we hear a message ack (positive or negative), we treat that
:: as though all fragments have been acked. If this message is not
:: .current, then this ack is for a future message and .current has
:: not yet been acked, so we place the ack in .queued-message-acks.
::
:: If we hear a message ack before we've sent all the fragments for
:: that message, clear .unsent-fragments and have |packet-pump delete
:: all sent fragments from the message. If this early message ack was
:: positive, print it out because it indicates the peer is not
:: behaving properly.
::
:: If the ack is for the current message, have |packet-pump delete
:: all packets from the message, give the message ack back
:: to the client vane, increment .current, and check if this next
:: message is in .queued-message-acks. If it is, emit the message
:: (n)ack, increment .current, and check the next message. Repeat
:: until .current is not fully acked.
::
:: The following equation is always true:
:: .next - .current == number of messages in flight
::
:: At the end of a task, |message-pump sends a %halt task to
:: |packet-pump, which can trigger a timer to be set or cleared based
:: on congestion control calculations. When the timer fires, it will
:: generally cause a packet to be re-sent.
::
:: Message sequence numbers start at 1 so that the first message will
:: be greater than .last-acked.message-sink-state on the receiver.
::
:: current: sequence number of earliest message sent or being sent
:: next: sequence number of next message to send
:: unsent-messages: messages to be sent after current message
:: unsent-fragments: fragments of current message waiting for sending
:: queued-message-acks: future message acks to be applied after current
:: packet-pump-state: state of corresponding |packet-pump
::
+$ message-pump-state
$: current=_`message-num`1
next=_`message-num`1
unsent-messages=(qeu message-blob)
unsent-fragments=(list static-fragment)
queued-message-acks=(map message-num ack)
=packet-pump-state
==
+$ static-fragment
$: =message-num
num-fragments=fragment-num
=fragment-num
=fragment
==
:: $packet-pump-state: persistent state for |packet-pump
::
:: next-wake: last timer we've set, or null
:: live: packets in flight; sent but not yet acked
:: metrics: congestion control information
::
+$ packet-pump-state
$: next-wake=(unit @da)
live=(tree [live-packet-key live-packet-val])
metrics=pump-metrics
==
:: $pump-metrics: congestion control state for a |packet-pump
::
:: This is an Ames adaptation of TCP's Reno congestion control
:: algorithm. The information signals and their responses are
:: identical to those of the "NewReno" variant of Reno; the
:: implementation differs because Ames acknowledgments differ from
:: TCP's, because this code uses functional data structures, and
:: because TCP's sequence numbers reset when a peer becomes
:: unresponsive, whereas Ames sequence numbers only change when a
:: ship breaches.
::
:: A deviation from Reno is +fast-resend-after-ack, which re-sends
:: timed-out packets when a peer starts responding again after a
:: period of unresponsiveness.
::
:: If .skips reaches 3, we perform a fast retransmit and fast
:: recovery. This corresponds to Reno's handling of "three duplicate
:: acks".
::
:: rto: retransmission timeout
:: rtt: roundtrip time estimate, low-passed using EWMA
:: rttvar: mean deviation of .rtt, also low-passed with EWMA
:: num-live: how many packets sent, awaiting ack
:: ssthresh: slow-start threshold
:: cwnd: congestion window; max unacked packets
::
+$ pump-metrics
$: rto=_~s1
rtt=_~s1
rttvar=_~s1
ssthresh=_10.000
cwnd=_1
num-live=@ud
counter=@ud
==
+$ live-packet
$: key=live-packet-key
val=live-packet-val
==
+$ live-packet-key
$: =message-num
=fragment-num
==
+$ live-packet-val
$: packet-state
num-fragments=fragment-num
=fragment
==
+$ packet-state
$: last-sent=@da
retries=@ud
skips=@ud
==
:: $message-sink-state: state of |message-sink to assemble messages
::
:: last-acked: highest $message-num we've fully acknowledged
:: last-heard: highest $message-num we've heard all fragments on
:: pending-vane-ack: heard but not processed by local vane
:: live-messages: partially received messages
::
+$ message-sink-state
$: last-acked=message-num
last-heard=message-num
pending-vane-ack=(qeu [=message-num message=*])
live-messages=(map message-num partial-rcv-message)
nax=(set message-num)
==
:: $partial-rcv-message: message for which we've received some fragments
::
:: num-fragments: total number of fragments in this message
:: num-received: how many fragments we've received so far
:: fragments: fragments we've received, eventually producing a $message
::
+$ partial-rcv-message
$: num-fragments=fragment-num
num-received=fragment-num
fragments=(map fragment-num fragment)
==
::
-- ::ames
:: ::::
:::: ++behn :: (1b) timekeeping
:: ::::
++ behn ^?
|%
+$ gift :: out result <-$
$% [%doze p=(unit @da)] :: next alarm
[%wake error=(unit tang)] :: wakeup or failed
[%meta p=vase]
[%heck syn=sign-arvo] :: response to %huck
==
+$ task :: in request ->$
$~ [%vega ~] ::
$% $>(%born vane-task) :: new unix process
$>(%crud vane-task) :: error with trace
[%rest p=@da] :: cancel alarm
[%drip p=vase] :: give in next event
[%huck syn=sign-arvo] :: give back
$>(%trim vane-task) :: trim state
$>(%vega vane-task) :: report upgrade
[%wait p=@da] :: set alarm
[%wake ~] :: timer activate
==
-- ::behn
:: ::::
:::: ++clay :: (1c) versioning
:: ::::
++ clay ^?
|%
+$ gift :: out result <-$
$% [%boon payload=*] :: ames response
[%croz rus=(map desk [r=regs w=regs])] :: rules for group
[%cruz cez=(map @ta crew)] :: permission groups
[%dirk p=@tas] :: mark mount dirty
[%ergo p=@tas q=mode] :: version update
[%hill p=(list @tas)] :: mount points
[%done error=(unit error:ames)] :: ames message (n)ack
[%mere p=(each (set path) (pair term tang))] :: merge result
[%note p=@tD q=tank] :: debug message
[%ogre p=@tas] :: delete mount point
[%rule red=dict wit=dict] :: node r+w permissions
[%writ p=riot] :: response
[%wris p=[%da p=@da] q=(set (pair care path))] :: many changes
== ::
+$ task :: in request ->$
$~ [%vega ~] ::
$% [%boat ~] :: pier rebooted
[%cred nom=@ta cew=crew] :: set permission group
[%crew ~] :: permission groups
[%crow nom=@ta] :: group usage
$>(%crud vane-task) :: error with trace
[%drop des=desk] :: cancel pending merge
[%info des=desk dit=nori] :: internal edit
$>(%init vane-task) :: report install
[%into des=desk all=? fis=mode] :: external edit
$: %merg :: merge desks
des=desk :: target
her=@p dem=desk cas=case :: source
how=germ :: method
== ::
[%mont pot=term bem=beam] :: mount to unix
[%dirk des=desk] :: mark mount dirty
[%ogre pot=$@(desk beam)] :: delete mount point
[%park des=desk yok=yoki ran=rang] :: synchronous commit
[%perm des=desk pax=path rit=rite] :: change permissions
[%pork ~] :: resume commit
$>(%trim vane-task) :: trim state
$>(%vega vane-task) :: report upgrade
[%warp wer=ship rif=riff] :: internal file req
[%werp who=ship wer=ship rif=riff-any] :: external file req
$>(%plea vane-task) :: ames request
== ::
::
:::: :: (1c2)
::
+$ aeon @ud :: version number
+$ ankh :: fs node (new)
$~ [~ ~]
$: fil=(unit [p=lobe q=cage]) :: file
dir=(map @ta ankh) :: folders
== ::
+$ beam [[p=ship q=desk r=case] s=path] :: global name
+$ beak [p=ship q=desk r=case] :: path prefix
+$ blob :: fs blob
$% [%delta p=lobe q=[p=mark q=lobe] r=page] :: delta on q
[%direct p=lobe q=page] :: immediate
== ::
:: +cable: a reference to something on the filesystem
:: face: the face to wrap around the imported file
:: file-path: location in clay
+$ cable
$: face=(unit term)
file-path=term
==
+$ care ?(%a %b %c %d %p %r %s %t %u %v %w %x %y %z) :: clay submode
+$ case :: ship desk case spur
$% [%da p=@da] :: date
[%tas p=@tas] :: label
[%ud p=@ud] :: number
== ::
+$ cass [ud=@ud da=@da] :: cases for revision
+$ crew (set ship) :: permissions group
+$ dict [src=path rul=real] :: effective permission
+$ dome :: project state
$: ank=ankh :: state
let=@ud :: top id
hit=(map @ud tako) :: changes by id
lab=(map @tas @ud) :: labels
== ::
+$ germ :: merge style
$? %init :: new desk
%fine :: fast forward
%meet :: orthogonal files
%mate :: orthogonal changes
%meld :: force merge
%only-this :: ours with parents
%only-that :: hers with parents
%take-this :: ours unless absent
%take-that :: hers unless absent
%meet-this :: ours if conflict
%meet-that :: hers if conflict
== ::
+$ lobe @uvI :: blob ref
+$ maki [p=@ta q=@ta r=@ta s=path] ::
+$ miso :: ankh delta
$% [%del ~] :: delete
[%ins p=cage] :: insert
[%dif p=cage] :: mutate from diff
[%mut p=cage] :: mutate from raw
== ::
+$ misu :: computed delta
$% [%del ~] :: delete
[%ins p=cage] :: insert
[%dif p=lobe q=cage] :: mutate from diff
== ::
+$ mizu [p=@u q=(map @ud tako) r=rang] :: new state
+$ moar [p=@ud q=@ud] :: normal change range
+$ moat [from=case to=case =path] :: change range
+$ mode (list [path (unit mime)]) :: external files
+$ mood [=care =case =path] :: request in desk
+$ mool [=case paths=(set (pair care path))] :: requests in desk
+$ nori :: repository action
$% [%& p=soba] :: delta
[%| p=@tas] :: label
== ::
+$ nuri :: repository action
$% [%& p=suba] :: delta
[%| p=@tas] :: label
== ::
+$ open $-(path vase) :: get prelude
+$ page (cask *) :: untyped cage
+$ plop blob :: unvalidated blob
+$ rang :: repository
$: hut=(map tako yaki) :: changes
lat=(map lobe blob) :: data
== ::
+$ rant :: response to request
$: p=[p=care q=case r=desk] :: clade release book
q=path :: spur
r=cage :: data
== ::
+$ rave :: general request
$% [%sing =mood] :: single request
[%next =mood] :: await next version
[%mult =mool] :: next version of any
[%many track=? =moat] :: track range
== ::
+$ real :: resolved permissions
$: mod=?(%black %white) ::
who=(pair (set ship) (map @ta crew)) ::
== ::
+$ regs (map path rule) :: rules for paths
+$ riff [p=desk q=(unit rave)] :: request+desist
+$ riff-any
$% [%1 =riff]
==
+$ rite :: new permissions
$% [%r red=(unit rule)] :: for read
[%w wit=(unit rule)] :: for write
[%rw red=(unit rule) wit=(unit rule)] :: for read and write
== ::
+$ riot (unit rant) :: response+complete
+$ rule [mod=?(%black %white) who=(set whom)] :: node permission
+$ rump [p=care q=case r=@tas s=path] :: relative path
+$ saba [p=ship q=@tas r=moar s=dome] :: patch+merge
+$ soba (list [p=path q=miso]) :: delta
+$ suba (list [p=path q=misu]) :: delta
+$ tako @ :: yaki ref
+$ toro [p=@ta q=nori] :: general change
++ unce :: change part
|* a=mold ::
$% [%& p=@ud] :: skip[copy]
[%| p=(list a) q=(list a)] :: p -> q[chunk]
== ::
++ urge |*(a=mold (list (unce a))) :: list change
+$ whom (each ship @ta) :: ship or named crew
+$ yoki (each yuki yaki) :: commit
+$ yuki :: proto-commit
$: p=(list tako) :: parents
q=(map path (each page lobe)) :: namespace
== ::
+$ yaki :: commit
$: p=(list tako) :: parents
q=(map path lobe) :: namespace
r=tako :: self-reference
t=@da :: date
== ::
::
:: +page-to-lobe: hash a page to get a lobe.
::
++ page-to-lobe |=(page (shax (jam +<)))
::
:: +make-yaki: make commit out of a list of parents, content, and date.
::
++ make-yaki
|= [p=(list tako) q=(map path lobe) t=@da]
^- yaki
=+ ^= has
%^ cat 7 (sham [%yaki (roll p add) q t])
(sham [%tako (roll p add) q t])
[p q has t]
:: $pile: preprocessed hoon source file
::
:: /- sur-file :: surface imports from /sur
:: /+ lib-file :: library imports from /lib
:: /= face /path :: imports built hoon file at path
:: /* face %mark /path :: unbuilt file imports, as mark
::
+$ pile
$: sur=(list taut)
lib=(list taut)
raw=(list [face=term =path])
bar=(list [face=term =mark =path])
=hoon
==
:: $taut: file import from /lib or /sur
::
+$ taut [face=(unit term) pax=term]
:: $mars: mark conversion request
:: $tube: mark conversion gate
::
+$ mars [a=mark b=mark]
+$ tube $-(vase vase)
:: $dais: processed mark core
::
+$ dais
$_ ^|
|_ sam=vase
++ bunt sam
++ diff |~(new=_sam *vase)
++ form *mark
++ join |~([a=vase b=vase] *(unit (unit vase)))
++ mash
|~ [a=[ship desk diff=vase] b=[ship desk diff=vase]]
*(unit vase)
++ pact |~(diff=vase sam)
++ vale |~(noun sam)
++ volt |~(noun sam)
--
::
++ get-fit
|= [bek=beak pre=@tas pax=@tas]
^- (unit path)
=/ paz (segments pax)
|- ^- (unit path)
?~ paz
~
=/ puz=path (snoc `path`[pre i.paz] %hoon)
=+ .^(=arch cy+[(scot %p p.bek) q.bek (scot r.bek) puz])
?^ fil.arch
`puz
$(paz t.paz)
:: +segments: compute all paths from :path-part, replacing some `/`s with `-`s
::
:: For example, when passed a :path-part of 'foo-bar-baz',
:: the product will contain:
:: ```
:: dojo> (segments 'foo-bar-baz')
:: ~[/foo-bar-baz /foo-bar/baz /foo/bar-baz /foo/bar/baz]
:: ```
::
++ segments
|= suffix=@tas
^- (list path)
=/ parser
(most hep (cook crip ;~(plug low (star ;~(pose low nud)))))
=/ torn=(list @tas) (fall (rush suffix parser) ~[suffix])
%- flop
|- ^- (list (list @tas))
?< ?=(~ torn)
?: ?=([@ ~] torn)
~[torn]
%- zing
%+ turn $(torn t.torn)
|= s=(list @tas)
^- (list (list @tas))
?> ?=(^ s)
~[[i.torn s] [(crip "{(trip i.torn)}-{(trip i.s)}") t.s]]
-- ::clay
:: ::::
:::: ++dill :: (1d) console
:: ::::
++ dill ^?
|%
+$ gift :: out result <-$
$% [%bbye ~] :: reset prompt
[%blit p=(list blit)] :: terminal output
[%burl p=@t] :: activate url
[%logo ~] :: logout
[%meld ~] :: unify memory
[%pack ~] :: compact memory
[%trim p=@ud] :: trim kernel state
== ::
+$ task :: in request ->$
$~ [%vega ~] ::
$% [%belt p=belt] :: terminal input
[%blew p=blew] :: terminal config
[%boot lit=? p=*] :: weird %dill boot
[%crop p=@ud] :: trim kernel state
$>(%crud vane-task) :: error with trace
[%flee session=~] :: unwatch session
[%flog p=flog] :: wrapped error
[%flow p=@tas q=(list gill:gall)] :: terminal config
[%hail ~] :: terminal refresh
[%heft ~] :: memory report
[%hook ~] :: this term hung up
[%harm ~] :: all terms hung up
$>(%init vane-task) :: after gall ready
[%meld ~] :: unify memory
[%noop ~] :: no operation
[%pack ~] :: compact memory
[%talk p=tank] ::
[%text p=tape] ::
[%view session=~] :: watch session blits
$>(%trim vane-task) :: trim state
$>(%vega vane-task) :: report upgrade
[%verb ~] :: verbose mode
[%knob tag=term level=?(%hush %soft %loud)] :: error verbosity
== ::
::
:::: :: (1d2)
::
+$ blew [p=@ud q=@ud] :: columns rows
+$ belt :: old belt
$% [%aro p=?(%d %l %r %u)] :: arrow key
[%bac ~] :: true backspace
[%ctl p=@c] :: control-key
[%del ~] :: true delete
[%met p=@c] :: meta-key
[%ret ~] :: return
[%txt p=(list @c)] :: utf32 text
== ::
+$ blit :: old blit
$% [%bel ~] :: make a noise
[%clr ~] :: clear the screen
[%hop p=@ud] :: set cursor position
[%klr p=stub] :: set styled line
[%lin p=(list @c)] :: set current line
[%mor ~] :: newline
[%sag p=path q=*] :: save to jamfile
[%sav p=path q=@] :: save to file
[%url p=@t] :: activate url
== ::
+$ dill-belt :: new belt
$% [%aro p=?(%d %l %r %u)] :: arrow key
[%bac ~] :: true backspace
[%cru p=@tas q=(list tank)] :: echo error
[%ctl p=@] :: control-key
[%del ~] :: true delete
[%hey ~] :: refresh
[%met p=@] :: meta-key
[%ret ~] :: return
[%rez p=@ud q=@ud] :: resize, cols, rows
[%txt p=(list @c)] :: utf32 text
[%yow p=gill:gall] :: connect to app
== ::
+$ dill-blit :: new blit
$% [%bel ~] :: make a noise
[%clr ~] :: clear the screen
[%hop p=@ud] :: set cursor position
[%klr p=stub] :: styled text
[%mor p=(list dill-blit)] :: multiple blits
[%pom p=stub] :: styled prompt
[%pro p=(list @c)] :: show as cursor+line
[%qit ~] :: close console
[%out p=(list @c)] :: send output line
[%sag p=path q=*] :: save to jamfile
[%sav p=path q=@] :: save to file
[%url p=@t] :: activate url
== ::
+$ flog :: sent to %dill
$% [%crop p=@ud] :: trim kernel state
[%crud p=@tas q=(list tank)] ::
[%heft ~] ::
[%meld ~] :: unify memory
[%pack ~] :: compact memory
[%text p=tape] ::
[%verb ~] :: verbose mode
== ::
-- ::dill
:: ::::
:::: ++eyre :: (1e) http-server
:: ::::
++ eyre ^?
|%
+$ gift
$% :: set-config: configures the external http server
::
:: TODO: We need to actually return a (map (unit @t) http-config)
:: so we can apply configurations on a per-site basis
::
[%set-config =http-config]
:: response: response to an event from earth
::
[%response =http-event:http]
:: response to a %connect or %serve
::
:: :accepted is whether :binding was valid. Duplicate bindings are
:: not allowed.
::
[%bound accepted=? =binding]
==
::
+$ task
$~ [%vega ~]
$% :: event failure notification
::
$>(%crud vane-task)
:: initializes ourselves with an identity
::
$>(%init vane-task)
:: new unix process
::
$>(%born vane-task)
:: trim state (in response to memory pressure)
::
$>(%trim vane-task)
:: report upgrade
::
$>(%vega vane-task)
:: notifies us of the ports of our live http servers
::
[%live insecure=@ud secure=(unit @ud)]
:: update http configuration
::
[%rule =http-rule]
:: starts handling an inbound http request
::
[%request secure=? =address =request:http]
:: starts handling an backdoor http request
::
[%request-local secure=? =address =request:http]
:: cancels a previous request
::
[%cancel-request ~]
:: connects a binding to an app
::
[%connect =binding app=term]
:: connects a binding to a generator
::
[%serve =binding =generator]
:: disconnects a binding
::
:: This must be called with the same duct that made the binding in
:: the first place.
::
[%disconnect =binding]
:: notifies us that web login code changed
::
[%code-changed ~]
:: start responding positively to cors requests from origin
::
[%approve-origin =origin]
:: start responding negatively to cors requests from origin
::
[%reject-origin =origin]
==
:: +origin: request origin as specified in an Origin header
::
+$ origin @torigin
:: +cors-registry: origins categorized by approval status
::
+$ cors-registry
$: requests=(set origin)
approved=(set origin)
rejected=(set origin)
==
:: +outstanding-connection: open http connections not fully complete:
::
:: This refers to outstanding connections where the connection to
:: outside is opened and we are currently waiting on an app to
:: produce the results.
::
+$ outstanding-connection
$: :: action: the action that had matched
::
=action
:: inbound-request: the original request which caused this connection
::
=inbound-request
:: response-header: set when we get our first %start
::
response-header=(unit response-header:http)
:: bytes-sent: the total bytes sent in response
::
bytes-sent=@ud
==
:: +authentication-state: state used in the login system
::
+$ authentication-state
$: :: sessions: a mapping of session cookies to session information
::
sessions=(map @uv session)
==
:: +session: server side data about a session
::
+$ session
$: :: expiry-time: when this session expires
::
:: We check this server side, too, so we aren't relying on the browser
:: to properly handle cookie expiration as a security mechanism.
::
expiry-time=@da
:: channels: channels opened by this session
::
channels=(set @t)
::
:: TODO: We should add a system for individual capabilities; we should
:: mint some sort of long lived cookie for mobile apps which only has
:: access to a single application path.
==
:: channel-state: state used in the channel system
::
+$ channel-state
$: :: session: mapping between an arbitrary key to a channel
::
session=(map @t channel)
:: by-duct: mapping from ducts to session key
::
duct-to-key=(map duct @t)
==
:: +timer: a reference to a timer so we can cancel or update it.
::
+$ timer
$: :: date: time when the timer will fire
::
date=@da
:: duct: duct that set the timer so we can cancel
::
=duct
==
:: channel-event: unacknowledged channel event, vaseless sign
::
+$ channel-event
$% $>(%poke-ack sign:agent:gall)
$>(%watch-ack sign:agent:gall)
$>(%kick sign:agent:gall)
[%fact =mark =noun]
==
:: channel: connection to the browser
::
:: Channels are the main method where a webpage communicates with Gall
:: apps. Subscriptions and pokes are issues with PUT requests on a path,
:: while GET requests on that same path open a persistent EventSource
:: channel.
::
:: The EventSource API is a sequence number based API that browser provide
:: which allow the server to push individual events to the browser over a
:: connection held open. In case of reconnection, the browser will send a
:: 'Last-Event-Id: ' header to the server; the server then resends all
:: events since then.
::
+$ channel
$: :: channel-state: expiration time or the duct currently listening
::
:: For each channel, there is at most one open EventSource
:: connection. A 400 is issues on duplicate attempts to connect to the
:: same channel. When an EventSource isn't connected, we set a timer
:: to reap the subscriptions. This timer shouldn't be too short
:: because the
::
state=(each timer duct)
:: next-id: next sequence number to use
::
next-id=@ud
:: last-ack: time of last client ack
::
:: used for clog calculations, in combination with :unacked
::
last-ack=@da
:: events: unacknowledged events
::
:: We keep track of all events where we haven't received a
:: 'Last-Event-Id: ' response from the client or a per-poke {'ack':
:: ...} call. When there's an active EventSource connection on this
:: channel, we send the event but we still add it to events because we
:: can't assume it got received until we get an acknowledgment.
::
events=(qeu [id=@ud request-id=@ud =channel-event])
:: unacked: unacknowledged event counts by request-id
::
:: used for clog calculations, in combination with :last-ack
::
unacked=(map @ud @ud)
:: subscriptions: gall subscriptions by request-id
::
:: We maintain a list of subscriptions so if a channel times out, we
:: can cancel all the subscriptions we've made.
::
subscriptions=(map @ud [ship=@p app=term =path duc=duct])
:: heartbeat: sse heartbeat timer
::
heartbeat=(unit timer)
==
:: +binding: A rule to match a path.
::
:: A +binding is a system unique mapping for a path to match. A +binding
:: must be system unique because we don't want two handlers for a path;
:: what happens if there are two different actions for [~ /]?
::
+$ binding
$: :: site: the site to match.
::
:: A ~ will match the Urbit's identity site (your.urbit.org). Any
:: other value will match a domain literal.
::
site=(unit @t)
:: path: matches this prefix path
::
:: /~myapp will match /~myapp or /~myapp/longer/path
::
path=(list @t)
==
:: +action: the action to take when a binding matches an incoming request
::
+$ action
$% :: dispatch to a generator
::
[%gen =generator]
:: dispatch to an application
::
[%app app=term]
:: internal authentication page
::
[%authentication ~]
:: internal logout page
::
[%logout ~]
:: gall channel system
::
[%channel ~]
:: gall scry endpoint
::
[%scry ~]
:: respond with the default file not found page
::
[%four-oh-four ~]
==
:: +generator: a generator on the local ship that handles requests
::
:: This refers to a generator on the local ship, run with a set of
:: arguments. Since http requests are time sensitive, we require that the
:: generator be on the current ship.
::
+$ generator
$: :: desk: desk on current ship that contains the generator
::
=desk
:: path: path on :desk to the generator's hoon file
::
path=(list @t)
:: args: arguments passed to the gate
::
args=*
==
:: +http-config: full http-server configuration
::
+$ http-config
$: :: secure: PEM-encoded RSA private key and cert or cert chain
::
secure=(unit [key=wain cert=wain])
:: proxy: reverse TCP proxy HTTP(s)
::
proxy=_|
:: log: keep HTTP(s) access logs
::
log=?
:: redirect: send 301 redirects to upgrade HTTP to HTTPS
::
:: Note: requires certificate.
::
redirect=?
==
:: +http-rule: update configuration
::
+$ http-rule
$% :: %cert: set or clear certificate and keypair
::
[%cert cert=(unit [key=wain cert=wain])]
:: %turf: add or remove established dns binding
::
[%turf action=?(%put %del) =turf]
==
:: +address: client IP address
::
+$ address
$% [%ipv4 @if]
[%ipv6 @is]
:: [%ames @p]
==
:: +inbound-request: +http-request and metadata
::
+$ inbound-request
$: :: authenticated: has a valid session cookie
::
authenticated=?
:: secure: whether this request was encrypted (https)
::
secure=?
:: address: the source address of this request
::
=address
:: request: the http-request itself
::
=request:http
==
::
+$ cred :: credential
$: hut=hart :: client host
aut=(jug @tas @t) :: client identities
orx=oryx :: CSRF secret
acl=(unit @t) :: accept-language
cip=(each @if @is) :: client IP
cum=(map @tas *) :: custom dirt
== ::
+$ epic :: FCGI parameters
$: qix=(map @t @t) :: query
ced=cred :: client credentials
bem=beam :: original path
== ::
::
+$ hart [p=? q=(unit @ud) r=host] :: http sec+port+host
+$ hate [p=purl q=@p r=moth] :: semi-cooked request
+$ hiss [p=purl q=moth] :: outbound request
+$ host (each turf @if) :: http host
+$ hoke %+ each [%localhost ~] :: local host
?(%.0.0.0.0 %.127.0.0.1) ::
+$ httq :: raw http request
$: p=meth :: method
q=@t :: unparsed url
r=(list [p=@t q=@t]) :: headers
s=(unit octs) :: body
== ::
+$ httr [p=@ud q=mess r=(unit octs)] :: raw http response
+$ math (map @t (list @t)) :: semiparsed headers
+$ mess (list [p=@t q=@t]) :: raw http headers
+$ meth :: http methods
$? %conn :: CONNECT
%delt :: DELETE
%get :: GET
%head :: HEAD
%opts :: OPTIONS
%post :: POST
%put :: PUT
%trac :: TRACE
== ::
+$ moth [p=meth q=math r=(unit octs)] :: http operation
+$ oryx @t :: CSRF secret
+$ pork [p=(unit @ta) q=(list @t)] :: fully parsed url
:: +prox: proxy notification
::
:: Used on both the proxy (ward) and upstream sides for
:: sending/receiving proxied-request notifications.
::
+$ prox
$: :: por: tcp port
::
por=@ud
:: sek: secure?
::
sek=?
:: non: authentication nonce
::
non=@uvJ
==
+$ purf (pair purl (unit @t)) :: url with fragment
+$ purl [p=hart q=pork r=quay] :: parsed url
+$ quay (list [p=@t q=@t]) :: parsed url query
++ quer |-($@(~ [p=@t q=@t t=$])) :: query tree
+$ quri :: request-uri
$% [%& p=purl] :: absolute
[%| p=pork q=quay] :: relative
== ::
:: +reserved: check if an ipv4 address is in a reserved range
::
++ reserved
|= a=@if
^- ?
=/ b (flop (rip 3 a))
:: 0.0.0.0/8 (software)
::
?. ?=([@ @ @ @ ~] b) &
?| :: 10.0.0.0/8 (private)
::
=(10 i.b)
:: 100.64.0.0/10 (carrier-grade NAT)
::
&(=(100 i.b) (gte i.t.b 64) (lte i.t.b 127))
:: 127.0.0.0/8 (localhost)
::
=(127 i.b)
:: 169.254.0.0/16 (link-local)
::
&(=(169 i.b) =(254 i.t.b))
:: 172.16.0.0/12 (private)
::
&(=(172 i.b) (gte i.t.b 16) (lte i.t.b 31))
:: 192.0.0.0/24 (protocol assignment)
::
&(=(192 i.b) =(0 i.t.b) =(0 i.t.t.b))
:: 192.0.2.0/24 (documentation)
::
&(=(192 i.b) =(0 i.t.b) =(2 i.t.t.b))
:: 192.18.0.0/15 (reserved, benchmark)
::
&(=(192 i.b) |(=(18 i.t.b) =(19 i.t.b)))
:: 192.51.100.0/24 (documentation)
::
&(=(192 i.b) =(51 i.t.b) =(100 i.t.t.b))
:: 192.88.99.0/24 (reserved, ex-anycast)
::
&(=(192 i.b) =(88 i.t.b) =(99 i.t.t.b))
:: 192.168.0.0/16 (private)
::
&(=(192 i.b) =(168 i.t.b))
:: 203.0.113/24 (documentation)
::
&(=(203 i.b) =(0 i.t.b) =(113 i.t.t.b))
:: 224.0.0.0/8 (multicast)
:: 240.0.0.0/4 (reserved, future)
:: 255.255.255.255/32 (broadcast)
::
(gte i.b 224)
==
:: +ipa: parse ip address
::
++ ipa
;~(pose (stag %ipv4 ip4) (stag %ipv6 ip6))
:: +ip4: parse ipv4 address
::
++ ip4
=+ byt=(ape:ag ted:ab)
(bass 256 ;~(plug byt (stun [3 3] ;~(pfix dot byt))))
:: +ip6: parse ipv6 address
::
++ ip6
%+ bass 0x1.0000
%+ sear
|= hexts=(list $@(@ [~ %zeros]))
^- (unit (list @))
:: not every list of hextets is an ipv6 address
::
=/ legit=?
=+ l=(lent hexts)
=+ c=|=(a=* ?=([~ %zeros] a))
?| &((lth l 8) ?=([* ~] (skim hexts c)))
&(=(8 l) !(lien hexts c))
==
?. legit ~
%- some
:: expand zeros
::
%- zing
%+ turn hexts
|= hext=$@(@ [~ %zeros])
?@ hext [hext]~
(reap (sub 9 (lent hexts)) 0)
:: parse hextets, producing cell for shorthand zeroes
::
|^ %+ cook
|= [a=(list @) b=(list [~ %zeros]) c=(list @)]
:(welp a b c)
;~ plug
(more col het)
(stun [0 1] cel)
(more col het)
==
++ cel (cold `%zeros ;~(plug col col))
++ het (bass 16 (stun [1 4] six:ab))
--
::
+$ rout [p=(list host) q=path r=oryx s=path] :: http route (new)
+$ user knot :: username
-- ::eyre
:: ::::
:::: ++gall :: (1g) extensions
:: ::::
++ gall ^?
|%
+$ gift :: outgoing result
$% [%boon payload=*] :: ames response
[%done error=(unit error:ames)] :: ames message (n)ack
[%onto p=(each suss tang)] :: about agent
[%unto p=sign:agent] ::
== ::
+$ task :: incoming request
$~ [%vega ~] ::
$% [%conf dap=term] :: start agent
[%deal p=sock q=term r=deal] :: full transmission
[%goad force=? agent=(unit dude)] :: rebuild agent(s)
[%sear =ship] :: clear pending queues
[%fade dap=term style=?(%slay %idle %jolt)] :: put app to sleep
$>(%init vane-task) :: set owner
$>(%trim vane-task) :: trim state
$>(%vega vane-task) :: report upgrade
$>(%plea vane-task) :: network request
== ::
+$ bitt (map duct (pair ship path)) :: incoming subs
+$ boat :: outgoing subs
%+ map [=wire =ship =term] ::
[acked=? =path] ::
+$ bowl :: standard app state
$: $: our=ship :: host
src=ship :: guest
dap=term :: agent
== ::
$: wex=boat :: outgoing subs
sup=bitt :: incoming subs
== ::
$: act=@ud :: change number
eny=@uvJ :: entropy
now=@da :: current time
byk=beak :: load source
== == ::
+$ dude term :: server identity
+$ gill (pair ship term) :: general contact
+$ scar :: opaque duct
$: p=@ud :: bone sequence
q=(map duct bone) :: by duct
r=(map bone duct) :: by bone
== ::
+$ suss (trel dude @tas @da) :: config report
+$ well (pair desk term) ::
+$ neat
$% [%arvo =note-arvo]
[%agent [=ship name=term] =deal]
==
+$ deal
$% [%raw-poke =mark =noun]
task:agent
==
::
:: +agent: app core
::
++ agent
=< form
|%
+$ step (quip card form)
+$ card (wind note gift)
+$ note
$% [%arvo =note-arvo]
[%agent [=ship name=term] =task]
==
+$ task
$% [%watch =path]
[%watch-as =mark =path]
[%leave ~]
[%poke =cage]
[%poke-as =mark =cage]
==
+$ gift
$% [%fact paths=(list path) =cage]
[%kick paths=(list path) ship=(unit ship)]
[%watch-ack p=(unit tang)]
[%poke-ack p=(unit tang)]
==
+$ sign
$% [%poke-ack p=(unit tang)]
[%watch-ack p=(unit tang)]
[%fact =cage]
[%kick ~]
==
++ form
$_ ^|
|_ bowl
++ on-init
*(quip card _^|(..on-init))
::
++ on-save
*vase
::
++ on-load
|~ old-state=vase
*(quip card _^|(..on-init))
::
++ on-poke
|~ [mark vase]
*(quip card _^|(..on-init))
::
++ on-watch
|~ path
*(quip card _^|(..on-init))
::
++ on-leave
|~ path
*(quip card _^|(..on-init))
::
++ on-peek
|~ path
*(unit (unit cage))
::
++ on-agent
|~ [wire sign]
*(quip card _^|(..on-init))
::
++ on-arvo
|~ [wire sign-arvo]
*(quip card _^|(..on-init))
::
++ on-fail
|~ [term tang]
*(quip card _^|(..on-init))
--
--
-- ::gall
:: %iris http-client interface
::
++ iris ^?
|%
:: +gift: effects the client can emit
::
+$ gift
$% :: %request: outbound http-request to earth
::
:: TODO: id is sort of wrong for this interface; the duct should
:: be enough to identify which request we're talking about?
::
[%request id=@ud request=request:http]
:: %cancel-request: tell earth to cancel a previous %request
::
[%cancel-request id=@ud]
:: %response: response to the caller
::
[%http-response =client-response]
==
::
+$ task
$~ [%vega ~]
$% :: event failure notification
::
$>(%crud vane-task)
:: system started up; reset open connections
::
$>(%born vane-task)
:: trim state (in response to memory pressure)
::
$>(%trim vane-task)
:: report upgrade
::
$>(%vega vane-task)
:: fetches a remote resource
::
[%request =request:http =outbound-config]
:: cancels a previous fetch
::
[%cancel-request ~]
:: receives http data from outside
::
[%receive id=@ud =http-event:http]
==
:: +client-response: one or more client responses given to the caller
::
+$ client-response
$% :: periodically sent as an update on the duct that sent %fetch
::
$: %progress
:: http-response-header: full transaction header
::
:: In case of a redirect chain, this is the target of the
:: final redirect.
::
=response-header:http
:: bytes-read: bytes fetched so far
::
bytes-read=@ud
:: expected-size: the total size if response had a content-length
::
expected-size=(unit @ud)
:: incremental: data received since the last %http-progress
::
incremental=(unit octs)
==
:: final response of a download, parsed as mime-data if successful
::
[%finished =response-header:http full-file=(unit mime-data)]
:: canceled by the runtime system
::
[%cancel ~]
==
:: mime-data: externally received but unvalidated mimed data
::
+$ mime-data
[type=@t data=octs]
:: +outbound-config: configuration for outbound http requests
::
+$ outbound-config
$: :: number of times to follow a 300 redirect before erroring
::
:: Common values for this will be 3 (the limit most browsers use), 5
:: (the limit recommended by the http standard), or 0 (let the
:: requester deal with 300 redirects).
::
redirects=_5
:: number of times to retry before failing
::
:: When we retry, we'll automatically try to use the 'Range' header
:: to resume the download where we left off if we have the
:: 'Accept-Range: bytes' in the original response.
::
retries=_3
==
:: +to-httr: adapts to old eyre interface
::
++ to-httr
|= [header=response-header:http full-file=(unit mime-data)]
^- httr:eyre
::
=/ data=(unit octs)
?~(full-file ~ `data.u.full-file)
::
[status-code.header headers.header data]
--
:: ::::
:::: ++jael :: (1h) security
:: ::::
++ jael ^?
|%
+$ public-keys-result
$% [%full points=(map ship point)]
[%diff who=ship =diff:point]
[%breach who=ship]
==
:: ::
+$ gift :: out result <-$
$% [%done error=(unit error:ames)] :: ames message (n)ack
[%boon payload=*] :: ames response
[%private-keys =life vein=(map life ring)] :: private keys
[%public-keys =public-keys-result] :: ethereum changes
[%turf turf=(list turf)] :: domains
== ::
:: +seed: private boot parameters
::
+$ seed [who=ship lyf=life key=ring sig=(unit oath:pki)]
::
+$ task :: in request ->$
$~ [%vega ~] ::
$% [%dawn dawn-event] :: boot from keys
[%fake =ship] :: fake boot
[%listen whos=(set ship) =source] :: set ethereum source
::TODO %next for generating/putting new private key
[%meet =ship =life =pass] :: met after breach
[%moon =ship =udiff:point] :: register moon keys
[%nuke whos=(set ship)] :: cancel tracker from
[%private-keys ~] :: sub to privates
[%public-keys ships=(set ship)] :: sub to publics
[%rekey =life =ring] :: update private keys
$>(%trim vane-task) :: trim state
[%turf ~] :: view domains
$>(%vega vane-task) :: report upgrade
$>(%plea vane-task) :: ames request
[%step ~] :: reset web login code
== ::
::
+$ dawn-event
$: =seed
spon=(list [=ship point:azimuth-types])
czar=(map ship [=rift =life =pass])
turf=(list turf)
bloq=@ud
node=(unit purl:eyre)
==
::
++ block
=< block
|%
+$ hash @uxblockhash
+$ number @udblocknumber
+$ id [=hash =number]
+$ block [=id =parent=hash]
--
::
:: Azimuth points form a groupoid, where the objects are all the
:: possible values of +point and the arrows are the possible values
:: of (list point-diff). Composition of arrows is concatenation,
:: and you can apply the diffs to a +point with +apply.
::
:: It's simplest to consider +point as the coproduct of three
:: groupoids, Rift, Keys, and Sponsor. Recall that the coproduct
:: of monoids is the free monoid (Kleene star) of the coproduct of
:: the underlying sets of the monoids. The construction for
:: groupoids is similar. Thus, the objects of the coproduct are
:: the product of the objects of the underlying groupoids. The
:: arrows are a list of a sum of the diff types of the underlying
:: groupoids. Given an arrow=(list diff), you can project to the
:: underlying arrows with +skim filtering on the head of each diff.
::
:: The identity element is ~. Clearly, composing this with any
:: +diff gives the original +diff. Since this is a category,
:: +compose must be associative (true, because concatenation is
:: associative). This is a groupoid, so we must further have that
:: every +point-diff has an inverse. These are given by the
:: +inverse operation.
::
++ point
=< point
|%
+$ point
$: =rift
=life
keys=(map life [crypto-suite=@ud =pass])
sponsor=(unit @p)
==
::
+$ key-update [=life crypto-suite=@ud =pass]
::
:: Invertible diffs
::
+$ diffs (list diff)
+$ diff
$% [%rift from=rift to=rift]
[%keys from=key-update to=key-update]
[%spon from=(unit @p) to=(unit @p)]
==
::
:: Non-invertible diffs
::
+$ udiffs (list [=ship =udiff])
+$ udiff
$: =id:block
$% [%rift =rift]
[%keys key-update]
[%spon sponsor=(unit @p)]
[%disavow ~]
== ==
::
++ udiff-to-diff
|= [=a=udiff =a=point]
^- (unit diff)
?- +<.a-udiff
%disavow ~|(%udiff-to-diff-disavow !!)
%spon `[%spon sponsor.a-point sponsor.a-udiff]
%rift
?. (gth rift.a-udiff rift.a-point)
~
~? !=(rift.a-udiff +(rift.a-point))
[%udiff-to-diff-skipped-rift a-udiff a-point]
`[%rift rift.a-point rift.a-udiff]
::
%keys
?. (gth life.a-udiff life.a-point)
~
~? !=(life.a-udiff +(life.a-point))
[%udiff-to-diff-skipped-life a-udiff a-point]
:^ ~ %keys
[life.a-point (~(gut by keys.a-point) life.a-point *[@ud pass])]
[life crypto-suite pass]:a-udiff
==
::
++ inverse
|= diffs=(list diff)
^- (list diff)
%- flop
%+ turn diffs
|= =diff
^- ^diff
?- -.diff
%rift [%rift to from]:diff
%keys [%keys to from]:diff
%spon [%spon to from]:diff
==
::
++ compose
(bake weld ,[(list diff) (list diff)])
::
++ apply
|= [diffs=(list diff) =a=point]
(roll diffs (apply-diff a-point))
::
++ apply-diff
|= a=point
|: [*=diff a-point=a]
^- point
?- -.diff
%rift
?> =(rift.a-point from.diff)
a-point(rift to.diff)
::
%keys
?> =(life.a-point life.from.diff)
?> =((~(get by keys.a-point) life.a-point) `+.from.diff)
%_ a-point
life life.to.diff
keys (~(put by keys.a-point) life.to.diff +.to.diff)
==
::
%spon
?> =(sponsor.a-point from.diff)
a-point(sponsor to.diff)
==
--
:: ::
:::: ::
:: ::
+$ source (each ship term)
+$ source-id @udsourceid
::
:: +state-eth-node: state of a connection to an ethereum node
::
+$ state-eth-node :: node config + meta
$: top-source-id=source-id
sources=(map source-id source)
sources-reverse=(map source source-id)
default-source=source-id
ship-sources=(map ship source-id)
ship-sources-reverse=(jug source-id ship)
== ::
:: ::
:::: ++pki:jael :: (1h2) certificates
:: ::::
++ pki ^?
|%
::TODO update to fit azimuth-style keys
:: the urbit meta-certificate (++will) is a sequence
:: of certificates (++cert). each cert in a will
:: revokes and replaces the previous cert. the
:: version number of a ship is a ++life.
::
:: the deed contains an ++arms, a definition
:: of cosmetic identity; a semi-trusted parent,
:: which signs the initial certificate and provides
:: routing services; and a dirty bit. if the dirty
:: bit is set, the new life of this ship may have
:: lost information that the old life had.
::
+$ hand @uvH :: 128-bit hash
+$ mind [who=ship lyf=life] :: key identifier
+$ name (pair @ta @t) :: ascii / unicode
+$ oath @ :: signature
-- :: pki
-- :: jael
::
+$ gift-arvo :: out result <-$
$~ [%doze ~]
$% gift:ames
gift:behn
gift:clay
gift:dill
gift:eyre
gift:gall
gift:iris
gift:jael
==
+$ task-arvo :: in request ->$
$% task:ames
task:clay
task:behn
task:dill
task:eyre
task:gall
task:iris
task:jael
==
+$ note-arvo :: out request $->
$~ [%b %wake ~]
$% [%a task:ames]
[%b task:behn]
[%c task:clay]
[%d task:dill]
[%e task:eyre]
[%g task:gall]
[%i task:iris]
[%j task:jael]
[@tas %meta vase]
==
+$ sign-arvo :: in result $<-
$% [%a gift:ames]
$: %b
$% gift:behn
$>(%wris gift:clay)
$>(%writ gift:clay)
$>(%mere gift:clay)
$>(%unto gift:gall)
==
==
[%c gift:clay]
[%d gift:dill]
[%e gift:eyre]
[%g gift:gall]
[%i gift:iris]
[%j gift:jael]
==
:: $unix-task: input from unix
::
+$ unix-task :: input from unix
$~ [%wake ~]
$% :: %dill: keyboard input
::
$>(%belt task:dill)
:: %dill: configure terminal (resized)
::
$>(%blew task:dill)
:: %clay: new process
::
$>(%boat task:clay)
:: %behn/%eyre/%iris: new process
::
$>(%born vane-task)
:: %eyre: cancel request
::
[%cancel-request ~]
:: any vane: error report
::
$>(%crud vane-task)
:: %dill: reset terminal configuration
::
$>(%hail task:dill)
:: %ames: hear packet
::
$>(%hear task:ames)
:: %dill: hangup
::
$>(%hook task:dill)
:: %clay: external edit
::
$>(%into task:clay)
:: %eyre: learn ports of live http servers
::
$>(%live task:eyre)
:: %iris: hear (partial) http response
::
$>(%receive task:iris)
:: %eyre: starts handling an inbound http request
::
$>(%request task:eyre)
:: %eyre: starts handling an backdoor http request
::
$>(%request-local task:eyre)
:: %behn: wakeup
::
$>(%wake task:behn)
==
-- ::
:: :: ::
:::: :: :: (2) engines
:: :: ::
|%
:: ::::
:::: ++number :: (2a) number theory
:: ::::
++ number ^?
|%
:: :: ++fu:number
++ fu :: modulo (mul p q)
|= a=[p=@ q=@]
=+ b=?:(=([0 0] a) 0 (~(inv fo p.a) (~(sit fo p.a) q.a)))
|%
:: :: ++dif:fu:number
++ dif :: subtract
|= [c=[@ @] d=[@ @]]
[(~(dif fo p.a) -.c -.d) (~(dif fo q.a) +.c +.d)]
:: :: ++exp:fu:number
++ exp :: exponent
|= [c=@ d=[@ @]]
:- (~(exp fo p.a) (mod c (dec p.a)) -.d)
(~(exp fo q.a) (mod c (dec q.a)) +.d)
:: :: ++out:fu:number
++ out :: garner's formula
|= c=[@ @]
%+ add +.c
%+ mul q.a
%+ ~(pro fo p.a) b
(~(dif fo p.a) -.c (~(sit fo p.a) +.c))
:: :: ++pro:fu:number
++ pro :: multiply
|= [c=[@ @] d=[@ @]]
[(~(pro fo p.a) -.c -.d) (~(pro fo q.a) +.c +.d)]
:: :: ++sum:fu:number
++ sum :: add
|= [c=[@ @] d=[@ @]]
[(~(sum fo p.a) -.c -.d) (~(sum fo q.a) +.c +.d)]
:: :: ++sit:fu:number
++ sit :: represent
|= c=@
[(mod c p.a) (mod c q.a)]
-- ::fu
:: :: ++pram:number
++ pram :: rabin-miller
|= a=@ ^- ?
?: ?| =(0 (end 0 a))
=(1 a)
=+ b=1
|- ^- ?
?: =(512 b)
|
?|(=+(c=+((mul 2 b)) &(!=(a c) =(a (mul c (div a c))))) $(b +(b)))
==
|
=+ ^= b
=+ [s=(dec a) t=0]
|- ^- [s=@ t=@]
?: =(0 (end 0 s))
$(s (rsh 0 s), t +(t))
[s t]
?> =((mul s.b (bex t.b)) (dec a))
=+ c=0
|- ^- ?
?: =(c 64)
&
=+ d=(~(raw og (add c a)) (met 0 a))
=+ e=(~(exp fo a) s.b d)
?& ?| =(1 e)
=+ f=0
|- ^- ?
?: =(e (dec a))
&
?: =(f (dec t.b))
|
$(e (~(pro fo a) e e), f +(f))
==
$(c +(c))
==
:: :: ++ramp:number
++ ramp :: make r-m prime
|= [a=@ b=(list @) c=@] ^- @ux :: [bits snags seed]
=> .(c (shas %ramp c))
=+ d=*@
|-
?: =((mul 100 a) d)
~|(%ar-ramp !!)
=+ e=(~(raw og c) a)
?: &((levy b |=(f=@ !=(1 (mod e f)))) (pram e))
e
$(c +(c), d (shax d))
:: :: ++curt:number
++ curt :: curve25519
|= [a=@ b=@]
=> %= .
+
=> +
=+ =+ [p=486.662 q=(sub (bex 255) 19)]
=+ fq=~(. fo q)
[p=p q=q fq=fq]
|%
:: :: ++cla:curt:number
++ cla ::
|= raw=@
=+ low=(dis 248 (cut 3 [0 1] raw))
=+ hih=(con 64 (dis 127 (cut 3 [31 1] raw)))
=+ mid=(cut 3 [1 30] raw)
(can 3 [[1 low] [30 mid] [1 hih] ~])
:: :: ++sqr:curt:number
++ sqr ::
|=(a=@ (mul a a))
:: :: ++inv:curt:number
++ inv ::
|=(a=@ (~(exp fo q) (sub q 2) a))
:: :: ++cad:curt:number
++ cad ::
|= [n=[x=@ z=@] m=[x=@ z=@] d=[x=@ z=@]]
=+ ^= xx
;: mul 4 z.d
%- sqr %- abs:si
%+ dif:si
(sun:si (mul x.m x.n))
(sun:si (mul z.m z.n))
==
=+ ^= zz
;: mul 4 x.d
%- sqr %- abs:si
%+ dif:si
(sun:si (mul x.m z.n))
(sun:si (mul z.m x.n))
==
[(sit.fq xx) (sit.fq zz)]
:: :: ++cub:curt:number
++ cub ::
|= [x=@ z=@]
=+ ^= xx
%+ mul
%- sqr %- abs:si
(dif:si (sun:si x) (sun:si z))
(sqr (add x z))
=+ ^= zz
;: mul 4 x z
:(add (sqr x) :(mul p x z) (sqr z))
==
[(sit.fq xx) (sit.fq zz)]
-- ::
==
=+ one=[b 1]
=+ i=253
=+ r=one
=+ s=(cub one)
|-
?: =(i 0)
=+ x=(cub r)
(sit.fq (mul -.x (inv +.x)))
=+ m=(rsh [0 i] a)
?: =(0 (mod m 2))
$(i (dec i), s (cad r s one), r (cub r))
$(i (dec i), r (cad r s one), s (cub s))
:: :: ++ga:number
++ ga :: GF (bex p.a)
|= a=[p=@ q=@ r=@] :: dim poly gen
=+ si=(bex p.a)
=+ ma=(dec si)
=> |%
:: :: ++dif:ga:number
++ dif :: add and sub
|= [b=@ c=@]
~| [%dif-ga a]
?> &((lth b si) (lth c si))
(mix b c)
:: :: ++dub:ga:number
++ dub :: mul by x
|= b=@
~| [%dub-ga a]
?> (lth b si)
?: =(1 (cut 0 [(dec p.a) 1] b))
(dif (sit q.a) (sit (lsh 0 b)))
(lsh 0 b)
:: :: ++pro:ga:number
++ pro :: slow multiply
|= [b=@ c=@]
?: =(0 b)
0
?: =(1 (dis 1 b))
(dif c $(b (rsh 0 b), c (dub c)))
$(b (rsh 0 b), c (dub c))
:: :: ++toe:ga:number
++ toe :: exp+log tables
=+ ^= nu
|= [b=@ c=@]
^- (map @ @)
=+ d=*(map @ @)
|-
?: =(0 c)
d
%= $
c (dec c)
d (~(put by d) c b)
==
=+ [p=(nu 0 (bex p.a)) q=(nu ma ma)]
=+ [b=1 c=0]
|- ^- [p=(map @ @) q=(map @ @)]
?: =(ma c)
[(~(put by p) c b) q]
%= $
b (pro r.a b)
c +(c)
p (~(put by p) c b)
q (~(put by q) b c)
==
:: :: ++sit:ga:number
++ sit :: reduce
|= b=@
(mod b (bex p.a))
-- ::
=+ toe
|%
:: :: ++fra:ga:number
++ fra :: divide
|= [b=@ c=@]
(pro b (inv c))
:: :: ++inv:ga:number
++ inv :: invert
|= b=@
~| [%inv-ga a]
=+ c=(~(get by q) b)
?~ c !!
=+ d=(~(get by p) (sub ma u.c))
(need d)
:: :: ++pow:ga:number
++ pow :: exponent
|= [b=@ c=@]
=+ [d=1 e=c f=0]
|-
?: =(p.a f)
d
?: =(1 (cut 0 [f 1] b))
$(d (pro d e), e (pro e e), f +(f))
$(e (pro e e), f +(f))
:: :: ++pro:ga:number
++ pro :: multiply
|= [b=@ c=@]
~| [%pro-ga a]
=+ d=(~(get by q) b)
?~ d 0
=+ e=(~(get by q) c)
?~ e 0
=+ f=(~(get by p) (mod (add u.d u.e) ma))
(need f)
-- ::ga
-- ::number
:: ::::
:::: ++crypto :: (2b) cryptography
:: ::::
++ crypto ^?
=, ames
=, number
|%
:: ::
:::: ++aes:crypto :: (2b1) aes, all sizes
:: ::::
++ aes !.
~% %aes ..part ~
|%
:: :: ++ahem:aes:crypto
++ ahem :: kernel state
|= [nnk=@ nnb=@ nnr=@]
=>
=+ => [gr=(ga 8 0x11b 3) few==>(fe .(a 5))]
[pro=pro.gr dif=dif.gr pow=pow.gr ror=ror.few]
=> |% ::
++ cipa $_ ^? :: AES params
|%
++ co *[p=@ q=@ r=@ s=@] :: column coefficients
++ ix |~(a=@ *@) :: key index
++ ro *[p=@ q=@ r=@ s=@] :: row shifts
++ su *@ :: s-box
-- ::cipa
-- ::
|%
:: :: ++pen:ahem:aes:
++ pen :: encrypt
^- cipa
|%
:: :: ++co:pen:ahem:aes:
++ co :: column coefficients
[0x2 0x3 1 1]
:: :: ++ix:pen:ahem:aes:
++ ix :: key index
|~(a=@ a)
:: :: ++ro:pen:ahem:aes:
++ ro :: row shifts
[0 1 2 3]
:: :: ++su:pen:ahem:aes:
++ su :: s-box
0x16bb.54b0.0f2d.9941.6842.e6bf.0d89.a18c.
df28.55ce.e987.1e9b.948e.d969.1198.f8e1.
9e1d.c186.b957.3561.0ef6.0348.66b5.3e70.
8a8b.bd4b.1f74.dde8.c6b4.a61c.2e25.78ba.
08ae.7a65.eaf4.566c.a94e.d58d.6d37.c8e7.
79e4.9591.62ac.d3c2.5c24.0649.0a3a.32e0.
db0b.5ede.14b8.ee46.8890.2a22.dc4f.8160.
7319.5d64.3d7e.a7c4.1744.975f.ec13.0ccd.
d2f3.ff10.21da.b6bc.f538.9d92.8f40.a351.
a89f.3c50.7f02.f945.8533.4d43.fbaa.efd0.
cf58.4c4a.39be.cb6a.5bb1.fc20.ed00.d153.
842f.e329.b3d6.3b52.a05a.6e1b.1a2c.8309.
75b2.27eb.e280.1207.9a05.9618.c323.c704.
1531.d871.f1e5.a534.ccf7.3f36.2693.fdb7.
c072.a49c.afa2.d4ad.f047.59fa.7dc9.82ca.
76ab.d7fe.2b67.0130.c56f.6bf2.7b77.7c63
--
:: :: ++pin:ahem:aes:
++ pin :: decrypt
^- cipa
|%
:: :: ++co:pin:ahem:aes:
++ co :: column coefficients
[0xe 0xb 0xd 0x9]
:: :: ++ix:pin:ahem:aes:
++ ix :: key index
|~(a=@ (sub nnr a))
:: :: ++ro:pin:ahem:aes:
++ ro :: row shifts
[0 3 2 1]
:: :: ++su:pin:ahem:aes:
++ su :: s-box
0x7d0c.2155.6314.69e1.26d6.77ba.7e04.2b17.
6199.5383.3cbb.ebc8.b0f5.2aae.4d3b.e0a0.
ef9c.c993.9f7a.e52d.0d4a.b519.a97f.5160.
5fec.8027.5910.12b1.31c7.0788.33a8.dd1f.
f45a.cd78.fec0.db9a.2079.d2c6.4b3e.56fc.
1bbe.18aa.0e62.b76f.89c5.291d.711a.f147.
6edf.751c.e837.f9e2.8535.ade7.2274.ac96.
73e6.b4f0.cecf.f297.eadc.674f.4111.913a.
6b8a.1301.03bd.afc1.020f.3fca.8f1e.2cd0.
0645.b3b8.0558.e4f7.0ad3.bc8c.00ab.d890.
849d.8da7.5746.155e.dab9.edfd.5048.706c.
92b6.655d.cc5c.a4d4.1698.6886.64f6.f872.
25d1.8b6d.49a2.5b76.b224.d928.66a1.2e08.
4ec3.fa42.0b95.4cee.3d23.c2a6.3294.7b54.
cbe9.dec4.4443.8e34.87ff.2f9b.8239.e37c.
fbd7.f381.9ea3.40bf.38a5.3630.d56a.0952
--
:: :: ++mcol:ahem:aes:
++ mcol ::
|= [a=(list @) b=[p=@ q=@ r=@ s=@]]
^- (list @)
=+ c=[p=*@ q=*@ r=*@ s=*@]
|- ^- (list @)
?~ a ~
=> .(p.c (cut 3 [0 1] i.a))
=> .(q.c (cut 3 [1 1] i.a))
=> .(r.c (cut 3 [2 1] i.a))
=> .(s.c (cut 3 [3 1] i.a))
:_ $(a t.a)
%+ rep 3
%+ turn
%- limo
:~ [[p.c p.b] [q.c q.b] [r.c r.b] [s.c s.b]]
[[p.c s.b] [q.c p.b] [r.c q.b] [s.c r.b]]
[[p.c r.b] [q.c s.b] [r.c p.b] [s.c q.b]]
[[p.c q.b] [q.c r.b] [r.c s.b] [s.c p.b]]
==
|= [a=[@ @] b=[@ @] c=[@ @] d=[@ @]]
:(dif (pro a) (pro b) (pro c) (pro d))
:: :: ++pode:ahem:aes:
++ pode :: explode to block
|= [a=bloq b=@ c=@] ^- (list @)
=+ d=(rip a c)
=+ m=(met a c)
|-
?: =(m b)
d
$(m +(m), d (weld d (limo [0 ~])))
:: :: ++sube:ahem:aes:
++ sube :: s-box word
|= [a=@ b=@] ^- @
(rep 3 (turn (pode 3 4 a) |=(c=@ (cut 3 [c 1] b))))
-- ::
|%
:: :: ++be:ahem:aes:crypto
++ be :: block cipher
|= [a=? b=@ c=@H] ^- @uxH
~| %be-aesc
=> %= .
+
=> +
|%
:: :: ++ankh:be:ahem:aes:
++ ankh ::
|= [a=cipa b=@ c=@]
(pode 5 nnb (cut 5 [(mul (ix.a b) nnb) nnb] c))
:: :: ++sark:be:ahem:aes:
++ sark ::
|= [c=(list @) d=(list @)]
^- (list @)
?~ c ~
?~ d !!
[(mix i.c i.d) $(c t.c, d t.d)]
:: :: ++srow:be:ahem:aes:
++ srow ::
|= [a=cipa b=(list @)] ^- (list @)
=+ [c=0 d=~ e=ro.a]
|-
?: =(c nnb)
d
:_ $(c +(c))
%+ rep 3
%+ turn
(limo [0 p.e] [1 q.e] [2 r.e] [3 s.e] ~)
|= [f=@ g=@]
(cut 3 [f 1] (snag (mod (add g c) nnb) b))
:: :: ++subs:be:ahem:aes:
++ subs ::
|= [a=cipa b=(list @)] ^- (list @)
?~ b ~
[(sube i.b su.a) $(b t.b)]
--
==
=+ [d=?:(a pen pin) e=(pode 5 nnb c) f=1]
=> .(e (sark e (ankh d 0 b)))
|-
?. =(nnr f)
=> .(e (subs d e))
=> .(e (srow d e))
=> .(e (mcol e co.d))
=> .(e (sark e (ankh d f b)))
$(f +(f))
=> .(e (subs d e))
=> .(e (srow d e))
=> .(e (sark e (ankh d nnr b)))
(rep 5 e)
:: :: ++ex:ahem:aes:crypto
++ ex :: key expand
|= a=@I ^- @
=+ [b=a c=0 d=su:pen i=nnk]
|-
?: =(i (mul nnb +(nnr)))
b
=> .(c (cut 5 [(dec i) 1] b))
=> ?: =(0 (mod i nnk))
=> .(c (ror 3 1 c))
=> .(c (sube c d))
.(c (mix c (pow (dec (div i nnk)) 2)))
?: &((gth nnk 6) =(4 (mod i nnk)))
.(c (sube c d))
.
=> .(c (mix c (cut 5 [(sub i nnk) 1] b)))
=> .(b (can 5 [i b] [1 c] ~))
$(i +(i))
:: :: ++ix:ahem:aes:crypto
++ ix :: key expand, inv
|= a=@ ^- @
=+ [i=1 j=*@ b=*@ c=co:pin]
|-
?: =(nnr i)
a
=> .(b (cut 7 [i 1] a))
=> .(b (rep 5 (mcol (pode 5 4 b) c)))
=> .(j (sub nnr i))
%= $
i +(i)
a
%+ can 7
:~ [i (cut 7 [0 i] a)]
[1 b]
[j (cut 7 [+(i) j] a)]
==
==
--
:: :: ++ecba:aes:crypto
++ ecba :: AES-128 ECB
~% %ecba +> ~
|_ key=@H
:: :: ++en:ecba:aes:crypto
++ en :: encrypt
~/ %en
|= blk=@H ^- @uxH
=+ (ahem 4 4 10)
=:
key (~(net fe 7) key)
blk (~(net fe 7) blk)
==
%- ~(net fe 7)
(be & (ex key) blk)
:: :: ++de:ecba:aes:crypto
++ de :: decrypt
~/ %de
|= blk=@H ^- @uxH
=+ (ahem 4 4 10)
=:
key (~(net fe 7) key)
blk (~(net fe 7) blk)
==
%- ~(net fe 7)
(be | (ix (ex key)) blk)
-- ::ecba
:: :: ++ecbb:aes:crypto
++ ecbb :: AES-192 ECB
~% %ecbb +> ~
|_ key=@I
:: :: ++en:ecbb:aes:crypto
++ en :: encrypt
~/ %en
|= blk=@H ^- @uxH
=+ (ahem 6 4 12)
=:
key (rsh 6 (~(net fe 8) key))
blk (~(net fe 7) blk)
==
%- ~(net fe 7)
(be & (ex key) blk)
:: :: ++de:ecbb:aes:crypto
++ de :: decrypt
~/ %de
|= blk=@H ^- @uxH
=+ (ahem 6 4 12)
=:
key (rsh 6 (~(net fe 8) key))
blk (~(net fe 7) blk)
==
%- ~(net fe 7)
(be | (ix (ex key)) blk)
-- ::ecbb
:: :: ++ecbc:aes:crypto
++ ecbc :: AES-256 ECB
~% %ecbc +> ~
|_ key=@I
:: :: ++en:ecbc:aes:crypto
++ en :: encrypt
~/ %en
|= blk=@H ^- @uxH
=+ (ahem 8 4 14)
=:
key (~(net fe 8) key)
blk (~(net fe 7) blk)
==
%- ~(net fe 7)
(be & (ex key) blk)
:: :: ++de:ecbc:aes:crypto
++ de :: decrypt
~/ %de
|= blk=@H ^- @uxH
=+ (ahem 8 4 14)
=:
key (~(net fe 8) key)
blk (~(net fe 7) blk)
==
%- ~(net fe 7)
(be | (ix (ex key)) blk)
-- ::ecbc
:: :: ++cbca:aes:crypto
++ cbca :: AES-128 CBC
~% %cbca +> ~
|_ [key=@H prv=@H]
:: :: ++en:cbca:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@ ^- @ux
=+ pts=?:(=(txt 0) `(list @)`~[0] (flop (rip 7 txt)))
=| cts=(list @)
%+ rep 7
:: logically, flop twice here
|- ^- (list @)
?~ pts
cts
=+ cph=(~(en ecba key) (mix prv i.pts))
%= $
cts [cph cts]
pts t.pts
prv cph
==
:: :: ++de:cbca:aes:crypto
++ de :: decrypt
~/ %de
|= txt=@ ^- @ux
=+ cts=?:(=(txt 0) `(list @)`~[0] (flop (rip 7 txt)))
=| pts=(list @)
%+ rep 7
:: logically, flop twice here
|- ^- (list @)
?~ cts
pts
=+ pln=(mix prv (~(de ecba key) i.cts))
%= $
pts [pln pts]
cts t.cts
prv i.cts
==
-- ::cbca
:: :: ++cbcb:aes:crypto
++ cbcb :: AES-192 CBC
~% %cbcb +> ~
|_ [key=@I prv=@H]
:: :: ++en:cbcb:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@ ^- @ux
=+ pts=?:(=(txt 0) `(list @)`~[0] (flop (rip 7 txt)))
=| cts=(list @)
%+ rep 7
:: logically, flop twice here
|- ^- (list @)
?~ pts
cts
=+ cph=(~(en ecbb key) (mix prv i.pts))
%= $
cts [cph cts]
pts t.pts
prv cph
==
:: :: ++de:cbcb:aes:crypto
++ de :: decrypt
~/ %de
|= txt=@ ^- @ux
=+ cts=?:(=(txt 0) `(list @)`~[0] (flop (rip 7 txt)))
=| pts=(list @)
%+ rep 7
:: logically, flop twice here
|- ^- (list @)
?~ cts
pts
=+ pln=(mix prv (~(de ecbb key) i.cts))
%= $
pts [pln pts]
cts t.cts
prv i.cts
==
-- ::cbcb
:: :: ++cbcc:aes:crypto
++ cbcc :: AES-256 CBC
~% %cbcc +> ~
|_ [key=@I prv=@H]
:: :: ++en:cbcc:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@ ^- @ux
=+ pts=?:(=(txt 0) `(list @)`~[0] (flop (rip 7 txt)))
=| cts=(list @)
%+ rep 7
:: logically, flop twice here
|- ^- (list @)
?~ pts
cts
=+ cph=(~(en ecbc key) (mix prv i.pts))
%= $
cts [cph cts]
pts t.pts
prv cph
==
:: :: ++de:cbcc:aes:crypto
++ de :: decrypt
~/ %de
|= txt=@ ^- @ux
=+ cts=?:(=(txt 0) `(list @)`~[0] (flop (rip 7 txt)))
=| pts=(list @)
%+ rep 7
:: logically, flop twice here
|- ^- (list @)
?~ cts
pts
=+ pln=(mix prv (~(de ecbc key) i.cts))
%= $
pts [pln pts]
cts t.cts
prv i.cts
==
-- ::cbcc
:: :: ++inc:aes:crypto
++ inc :: inc. low bloq
|= [mod=bloq ctr=@H]
^- @uxH
=+ bqs=(rip mod ctr)
?~ bqs 0x1
%+ rep mod
[(~(sum fe mod) i.bqs 1) t.bqs]
:: :: ++ctra:aes:crypto
++ ctra :: AES-128 CTR
~% %ctra +> ~
|_ [key=@H mod=bloq len=@ ctr=@H]
:: :: ++en:ctra:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@
^- @ux
=/ encrypt ~(en ecba key)
=/ blocks (add (div len 16) ?:(=((^mod len 16) 0) 0 1))
?> (gte len (met 3 txt))
%+ mix txt
%+ rsh [3 (sub (mul 16 blocks) len)]
%+ rep 7
=| seed=(list @ux)
|- ^+ seed
?: =(blocks 0) seed
%= $
seed [(encrypt ctr) seed]
ctr (inc mod ctr)
blocks (dec blocks)
==
:: :: ++de:ctra:aes:crypto
++ de :: decrypt
en
-- ::ctra
:: :: ++ctrb:aes:crypto
++ ctrb :: AES-192 CTR
~% %ctrb +> ~
|_ [key=@I mod=bloq len=@ ctr=@H]
:: :: ++en:ctrb:aes:crypto
++ en
~/ %en
|= txt=@
^- @ux
=/ encrypt ~(en ecbb key)
=/ blocks (add (div len 16) ?:(=((^mod len 16) 0) 0 1))
?> (gte len (met 3 txt))
%+ mix txt
%+ rsh [3 (sub (mul 16 blocks) len)]
%+ rep 7
=| seed=(list @ux)
|- ^+ seed
?: =(blocks 0) seed
%= $
seed [(encrypt ctr) seed]
ctr (inc mod ctr)
blocks (dec blocks)
==
:: :: ++de:ctrb:aes:crypto
++ de :: decrypt
en
-- ::ctrb
:: :: ++ctrc:aes:crypto
++ ctrc :: AES-256 CTR
~% %ctrc +> ~
|_ [key=@I mod=bloq len=@ ctr=@H]
:: :: ++en:ctrc:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@
^- @ux
=/ encrypt ~(en ecbc key)
=/ blocks (add (div len 16) ?:(=((^mod len 16) 0) 0 1))
?> (gte len (met 3 txt))
%+ mix txt
%+ rsh [3 (sub (mul 16 blocks) len)]
%+ rep 7
=| seed=(list @ux)
|- ^+ seed
?: =(blocks 0) seed
%= $
seed [(encrypt ctr) seed]
ctr (inc mod ctr)
blocks (dec blocks)
==
:: :: ++de:ctrc:aes:crypto
++ de :: decrypt
en
-- ::ctrc
:: :: ++doub:aes:crypto
++ doub :: double 128-bit
|= :: string mod finite
::
str=@H
::
:: field (see spec)
::
^- @uxH
%- ~(sit fe 7)
?. =((xeb str) 128)
(lsh 0 str)
(mix 0x87 (lsh 0 str))
:: :: ++mpad:aes:crypto
++ mpad ::
|= [oct=@ txt=@]
::
:: pad message to multiple of 128 bits
:: by appending 1, then 0s
:: the spec is unclear, but it must be octet based
:: to match the test vectors
::
^- @ux
=+ pad=(mod oct 16)
?: =(pad 0) 0x8000.0000.0000.0000.0000.0000.0000.0000
(lsh [3 (sub 15 pad)] (mix 0x80 (lsh 3 txt)))
:: :: ++suba:aes:crypto
++ suba :: AES-128 subkeys
|= key=@H
=+ l=(~(en ecba key) 0)
=+ k1=(doub l)
=+ k2=(doub k1)
^- [@ux @ux]
[k1 k2]
:: :: ++subb:aes:crypto
++ subb :: AES-192 subkeys
|= key=@I
=+ l=(~(en ecbb key) 0)
=+ k1=(doub l)
=+ k2=(doub k1)
^- [@ux @ux]
[k1 k2]
:: :: ++subc:aes:crypto
++ subc :: AES-256 subkeys
|= key=@I
=+ l=(~(en ecbc key) 0)
=+ k1=(doub l)
=+ k2=(doub k1)
^- [@ux @ux]
[k1 k2]
:: :: ++maca:aes:crypto
++ maca :: AES-128 CMAC
~/ %maca
|= [key=@H oct=(unit @) txt=@]
^- @ux
=+ [sub=(suba key) len=?~(oct (met 3 txt) u.oct)]
=+ ^= pdt
?: &(=((mod len 16) 0) !=(len 0))
[& txt]
[| (mpad len txt)]
=+ ^= mac
%- ~(en cbca key 0)
%+ mix +.pdt
?- -.pdt
%& -.sub
%| +.sub
==
:: spec says MSBs, LSBs match test vectors
::
(~(sit fe 7) mac)
:: :: ++macb:aes:crypto
++ macb :: AES-192 CMAC
~/ %macb
|= [key=@I oct=(unit @) txt=@]
^- @ux
=+ [sub=(subb key) len=?~(oct (met 3 txt) u.oct)]
=+ ^= pdt
?: &(=((mod len 16) 0) !=(len 0))
[& txt]
[| (mpad len txt)]
=+ ^= mac
%- ~(en cbcb key 0)
%+ mix +.pdt
?- -.pdt
%& -.sub
%| +.sub
==
:: spec says MSBs, LSBs match test vectors
::
(~(sit fe 7) mac)
:: :: ++macc:aes:crypto
++ macc :: AES-256 CMAC
~/ %macc
|= [key=@I oct=(unit @) txt=@]
^- @ux
=+ [sub=(subc key) len=?~(oct (met 3 txt) u.oct)]
=+ ^= pdt
?: &(=((mod len 16) 0) !=(len 0))
[& txt]
[| (mpad len txt)]
=+ ^= mac
%- ~(en cbcc key 0)
%+ mix +.pdt
?- -.pdt
%& -.sub
%| +.sub
==
:: spec says MSBs, LSBs match test vectors
::
(~(sit fe 7) mac)
:: :: ++s2va:aes:crypto
++ s2va :: AES-128 S2V
~/ %s2va
|= [key=@H ads=(list @)]
?~ ads (maca key `16 0x1)
=/ res (maca key `16 0x0)
%+ maca key
|- ^- [[~ @ud] @uxH]
?~ t.ads
=/ wyt (met 3 i.ads)
?: (gte wyt 16)
[`wyt (mix i.ads res)]
[`16 (mix (doub res) (mpad wyt i.ads))]
%= $
ads t.ads
res (mix (doub res) (maca key ~ i.ads))
==
:: :: ++s2vb:aes:crypto
++ s2vb :: AES-192 S2V
~/ %s2vb
|= [key=@I ads=(list @)]
?~ ads (macb key `16 0x1)
=/ res (macb key `16 0x0)
%+ macb key
|- ^- [[~ @ud] @uxH]
?~ t.ads
=/ wyt (met 3 i.ads)
?: (gte wyt 16)
[`wyt (mix i.ads res)]
[`16 (mix (doub res) (mpad wyt i.ads))]
%= $
ads t.ads
res (mix (doub res) (macb key ~ i.ads))
==
:: :: ++s2vc:aes:crypto
++ s2vc :: AES-256 S2V
~/ %s2vc
|= [key=@I ads=(list @)]
?~ ads (macc key `16 0x1)
=/ res (macc key `16 0x0)
%+ macc key
|- ^- [[~ @ud] @uxH]
?~ t.ads
=/ wyt (met 3 i.ads)
?: (gte wyt 16)
[`wyt (mix i.ads res)]
[`16 (mix (doub res) (mpad wyt i.ads))]
%= $
ads t.ads
res (mix (doub res) (macc key ~ i.ads))
==
:: :: ++siva:aes:crypto
++ siva :: AES-128 SIV
~% %siva +> ~
|_ [key=@I vec=(list @)]
:: :: ++en:siva:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@
^- (trel @uxH @ud @ux)
=+ [k1=(rsh 7 key) k2=(end 7 key)]
=+ iv=(s2va k1 (weld vec (limo ~[txt])))
=+ len=(met 3 txt)
=* hib (dis iv 0xffff.ffff.ffff.ffff.7fff.ffff.7fff.ffff)
:+
iv
len
(~(en ctra k2 7 len hib) txt)
:: :: ++de:siva:aes:crypto
++ de :: decrypt
~/ %de
|= [iv=@H len=@ txt=@]
^- (unit @ux)
=+ [k1=(rsh 7 key) k2=(end 7 key)]
=* hib (dis iv 0xffff.ffff.ffff.ffff.7fff.ffff.7fff.ffff)
=+ ^= pln
(~(de ctra k2 7 len hib) txt)
?. =((s2va k1 (weld vec (limo ~[pln]))) iv)
~
`pln
-- ::siva
:: :: ++sivb:aes:crypto
++ sivb :: AES-192 SIV
~% %sivb +> ~
|_ [key=@J vec=(list @)]
:: :: ++en:sivb:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@
^- (trel @uxH @ud @ux)
=+ [k1=(rsh [6 3] key) k2=(end [6 3] key)]
=+ iv=(s2vb k1 (weld vec (limo ~[txt])))
=* hib (dis iv 0xffff.ffff.ffff.ffff.7fff.ffff.7fff.ffff)
=+ len=(met 3 txt)
:+ iv
len
(~(en ctrb k2 7 len hib) txt)
:: :: ++de:sivb:aes:crypto
++ de :: decrypt
~/ %de
|= [iv=@H len=@ txt=@]
^- (unit @ux)
=+ [k1=(rsh [6 3] key) k2=(end [6 3] key)]
=* hib (dis iv 0xffff.ffff.ffff.ffff.7fff.ffff.7fff.ffff)
=+ ^= pln
(~(de ctrb k2 7 len hib) txt)
?. =((s2vb k1 (weld vec (limo ~[pln]))) iv)
~
`pln
-- ::sivb
:: :: ++sivc:aes:crypto
++ sivc :: AES-256 SIV
~% %sivc +> ~
|_ [key=@J vec=(list @)]
:: :: ++en:sivc:aes:crypto
++ en :: encrypt
~/ %en
|= txt=@
^- (trel @uxH @ud @ux)
=+ [k1=(rsh 8 key) k2=(end 8 key)]
=+ iv=(s2vc k1 (weld vec (limo ~[txt])))
=* hib (dis iv 0xffff.ffff.ffff.ffff.7fff.ffff.7fff.ffff)
=+ len=(met 3 txt)
:+
iv
len
(~(en ctrc k2 7 len hib) txt)
:: :: ++de:sivc:aes:crypto
++ de :: decrypt
~/ %de
|= [iv=@H len=@ txt=@]
^- (unit @ux)
=+ [k1=(rsh 8 key) k2=(end 8 key)]
=* hib (dis iv 0xffff.ffff.ffff.ffff.7fff.ffff.7fff.ffff)
=+ ^= pln
(~(de ctrc k2 7 len hib) txt)
?. =((s2vc k1 (weld vec (limo ~[pln]))) iv)
~
`pln
-- ::sivc
--
:: ::
:::: ++ed:crypto :: ed25519
:: ::::
++ ed
=>
=+ =+ [b=256 q=(sub (bex 255) 19)]
=+ fq=~(. fo q)
=+ ^= l
%+ add
(bex 252)
27.742.317.777.372.353.535.851.937.790.883.648.493
=+ d=(dif.fq 0 (fra.fq 121.665 121.666))
=+ ii=(exp.fq (div (dec q) 4) 2)
[b=b q=q fq=fq l=l d=d ii=ii]
~% %coed ..part ~
|%
:: :: ++norm:ed:crypto
++ norm ::
|=(x=@ ?:(=(0 (mod x 2)) x (sub q x)))
:: :: ++xrec:ed:crypto
++ xrec :: recover x-coord
|= y=@ ^- @
=+ ^= xx
%+ mul (dif.fq (mul y y) 1)
(inv.fq +(:(mul d y y)))
=+ x=(exp.fq (div (add 3 q) 8) xx)
?: !=(0 (dif.fq (mul x x) (sit.fq xx)))
(norm (pro.fq x ii))
(norm x)
:: :: ++ward:ed:crypto
++ ward :: edwards multiply
|= [pp=[@ @] qq=[@ @]] ^- [@ @]
=+ dp=:(pro.fq d -.pp -.qq +.pp +.qq)
=+ ^= xt
%+ pro.fq
%+ sum.fq
(pro.fq -.pp +.qq)
(pro.fq -.qq +.pp)
(inv.fq (sum.fq 1 dp))
=+ ^= yt
%+ pro.fq
%+ sum.fq
(pro.fq +.pp +.qq)
(pro.fq -.pp -.qq)
(inv.fq (dif.fq 1 dp))
[xt yt]
:: :: ++scam:ed:crypto
++ scam :: scalar multiply
|= [pp=[@ @] e=@] ^- [@ @]
?: =(0 e)
[0 1]
=+ qq=$(e (div e 2))
=> .(qq (ward qq qq))
?: =(1 (dis 1 e))
(ward qq pp)
qq
:: :: ++etch:ed:crypto
++ etch :: encode point
|= pp=[@ @] ^- @
(can 0 ~[[(sub b 1) +.pp] [1 (dis 1 -.pp)]])
:: :: ++curv:ed:crypto
++ curv :: point on curve?
|= [x=@ y=@] ^- ?
.= 0
%+ dif.fq
%+ sum.fq
(pro.fq (sub q (sit.fq x)) x)
(pro.fq y y)
(sum.fq 1 :(pro.fq d x x y y))
:: :: ++deco:ed:crypto
++ deco :: decode point
|= s=@ ^- (unit [@ @])
=+ y=(cut 0 [0 (dec b)] s)
=+ si=(cut 0 [(dec b) 1] s)
=+ x=(xrec y)
=> .(x ?:(!=(si (dis 1 x)) (sub q x) x))
=+ pp=[x y]
?. (curv pp)
~
[~ pp]
:: :: ++bb:ed:crypto
++ bb ::
=+ bby=(pro.fq 4 (inv.fq 5))
[(xrec bby) bby]
-- ::
~% %ed + ~
|%
::
++ point-add
~/ %point-add
|= [a-point=@udpoint b-point=@udpoint]
^- @udpoint
::
=/ a-point-decoded=[@ @] (need (deco a-point))
=/ b-point-decoded=[@ @] (need (deco b-point))
::
%- etch
(ward a-point-decoded b-point-decoded)
::
++ scalarmult
~/ %scalarmult
|= [a=@udscalar a-point=@udpoint]
^- @udpoint
::
=/ a-point-decoded=[@ @] (need (deco a-point))
::
%- etch
(scam a-point-decoded a)
::
++ scalarmult-base
~/ %scalarmult-base
|= scalar=@udscalar
^- @udpoint
%- etch
(scam bb scalar)
::
++ add-scalarmult-scalarmult-base
~/ %add-scalarmult-scalarmult-base
|= [a=@udscalar a-point=@udpoint b=@udscalar]
^- @udpoint
::
=/ a-point-decoded=[@ @] (need (deco a-point))
::
%- etch
%+ ward
(scam bb b)
(scam a-point-decoded a)
::
++ add-double-scalarmult
~/ %add-double-scalarmult
|= [a=@udscalar a-point=@udpoint b=@udscalar b-point=@udpoint]
^- @udpoint
::
=/ a-point-decoded=[@ @] (need (deco a-point))
=/ b-point-decoded=[@ @] (need (deco b-point))
::
%- etch
%+ ward
(scam a-point-decoded a)
(scam b-point-decoded b)
:: :: ++puck:ed:crypto
++ puck :: public key
~/ %puck
|= sk=@I ^- @
?: (gth (met 3 sk) 32) !!
=+ h=(shal (rsh [0 3] b) sk)
=+ ^= a
%+ add
(bex (sub b 2))
(lsh [0 3] (cut 0 [3 (sub b 5)] h))
=+ aa=(scam bb a)
(etch aa)
:: :: ++suck:ed:crypto
++ suck :: keypair from seed
|= se=@I ^- @uJ
=+ pu=(puck se)
(can 0 ~[[b se] [b pu]])
:: :: ++shar:ed:crypto
++ shar :: curve25519 secret
~/ %shar
|= [pub=@ sek=@]
^- @ux
=+ exp=(shal (rsh [0 3] b) (suck sek))
=. exp (dis exp (can 0 ~[[3 0] [251 (fil 0 251 1)]]))
=. exp (con exp (lsh [3 31] 0b100.0000))
=+ prv=(end 8 exp)
=+ crv=(fra.fq (sum.fq 1 pub) (dif.fq 1 pub))
(curt prv crv)
:: :: ++sign:ed:crypto
++ sign :: certify
~/ %sign
|= [m=@ se=@] ^- @
=+ sk=(suck se)
=+ pk=(cut 0 [b b] sk)
=+ h=(shal (rsh [0 3] b) sk)
=+ ^= a
%+ add
(bex (sub b 2))
(lsh [0 3] (cut 0 [3 (sub b 5)] h))
=+ ^= r
=+ hm=(cut 0 [b b] h)
=+ ^= i
%+ can 0
:~ [b hm]
[(met 0 m) m]
==
(shaz i)
=+ rr=(scam bb r)
=+ ^= ss
=+ er=(etch rr)
=+ ^= ha
%+ can 0
:~ [b er]
[b pk]
[(met 0 m) m]
==
(~(sit fo l) (add r (mul (shaz ha) a)))
(can 0 ~[[b (etch rr)] [b ss]])
:: :: ++veri:ed:crypto
++ veri :: validate
~/ %veri
|= [s=@ m=@ pk=@] ^- ?
?: (gth (div b 4) (met 3 s)) |
?: (gth (div b 8) (met 3 pk)) |
=+ cb=(rsh [0 3] b)
=+ rr=(deco (cut 0 [0 b] s))
?~ rr |
=+ aa=(deco pk)
?~ aa |
=+ ss=(cut 0 [b b] s)
=+ ha=(can 3 ~[[cb (etch u.rr)] [cb pk] [(met 3 m) m]])
=+ h=(shaz ha)
=((scam bb ss) (ward u.rr (scam u.aa h)))
-- ::ed
:: ::
:::: ++scr:crypto :: (2b3) scrypt
:: ::::
++ scr
~% %scr ..part ~
|%
:: :: ++sal:scr:crypto
++ sal :: salsa20 hash
|= [x=@ r=@] :: with r rounds
?> =((mod r 2) 0) ::
=+ few==>(fe .(a 5))
=+ ^= rot
|= [a=@ b=@]
(mix (end 5 (lsh [0 a] b)) (rsh [0 (sub 32 a)] b))
=+ ^= lea
|= [a=@ b=@]
(net:few (sum:few (net:few a) (net:few b)))
=> |%
:: :: ++qr:sal:scr:crypto
++ qr :: quarterround
|= y=[@ @ @ @ ~]
=+ zb=(mix &2.y (rot 7 (sum:few &1.y &4.y)))
=+ zc=(mix &3.y (rot 9 (sum:few zb &1.y)))
=+ zd=(mix &4.y (rot 13 (sum:few zc zb)))
=+ za=(mix &1.y (rot 18 (sum:few zd zc)))
~[za zb zc zd]
:: :: ++rr:sal:scr:crypto
++ rr :: rowround
|= [y=(list @)]
=+ za=(qr ~[&1.y &2.y &3.y &4.y])
=+ zb=(qr ~[&6.y &7.y &8.y &5.y])
=+ zc=(qr ~[&11.y &12.y &9.y &10.y])
=+ zd=(qr ~[&16.y &13.y &14.y &15.y])
^- (list @) :~
&1.za &2.za &3.za &4.za
&4.zb &1.zb &2.zb &3.zb
&3.zc &4.zc &1.zc &2.zc
&2.zd &3.zd &4.zd &1.zd ==
:: :: ++cr:sal:scr:crypto
++ cr :: columnround
|= [x=(list @)]
=+ ya=(qr ~[&1.x &5.x &9.x &13.x])
=+ yb=(qr ~[&6.x &10.x &14.x &2.x])
=+ yc=(qr ~[&11.x &15.x &3.x &7.x])
=+ yd=(qr ~[&16.x &4.x &8.x &12.x])
^- (list @) :~
&1.ya &4.yb &3.yc &2.yd
&2.ya &1.yb &4.yc &3.yd
&3.ya &2.yb &1.yc &4.yd
&4.ya &3.yb &2.yc &1.yd ==
:: :: ++dr:sal:scr:crypto
++ dr :: doubleround
|= [x=(list @)]
(rr (cr x))
:: :: ++al:sal:scr:crypto
++ al :: add two lists
|= [a=(list @) b=(list @)]
|- ^- (list @)
?~ a ~ ?~ b ~
[i=(sum:few -.a -.b) t=$(a +.a, b +.b)]
-- ::
=+ xw=(rpp 5 16 x)
=+ ^= ow |- ^- (list @)
?~ r xw
$(xw (dr xw), r (sub r 2))
(rep 5 (al xw ow))
:: :: ++rpp:scr:crypto
++ rpp :: rip+filler blocks
|= [a=bloq b=@ c=@]
=+ q=(rip a c)
=+ w=(lent q)
?. =(w b)
?. (lth w b) (slag (sub w b) q)
^+ q (weld q (reap (sub b (lent q)) 0))
q
:: :: ++bls:scr:crypto
++ bls :: split to sublists
|= [a=@ b=(list @)]
?> =((mod (lent b) a) 0)
|- ^- (list (list @))
?~ b ~
[i=(scag a `(list @)`b) t=$(b (slag a `(list @)`b))]
:: :: ++slb:scr:crypto
++ slb ::
|= [a=(list (list @))]
|- ^- (list @)
?~ a ~
(weld `(list @)`-.a $(a +.a))
:: :: ++sbm:scr:crypto
++ sbm :: scryptBlockMix
|= [r=@ b=(list @)]
?> =((lent b) (mul 2 r))
=+ [x=(snag (dec (mul 2 r)) b) c=0]
=| [ya=(list @) yb=(list @)]
|- ^- (list @)
?~ b (flop (weld yb ya))
=. x (sal (mix x -.b) 8)
?~ (mod c 2)
$(c +(c), b +.b, ya [i=x t=ya])
$(c +(c), b +.b, yb [i=x t=yb])
:: :: ++srm:scr:crypto
++ srm :: scryptROMix
|= [r=@ b=(list @) n=@]
?> ?& =((lent b) (mul 2 r))
=(n (bex (dec (xeb n))))
(lth n (bex (mul r 16)))
==
=+ [v=*(list (list @)) c=0]
=. v
|- ^- (list (list @))
=+ w=(sbm r b)
?: =(c n) (flop v)
$(c +(c), v [i=[b] t=v], b w)
=+ x=(sbm r (snag (dec n) v))
|- ^- (list @)
?: =(c n) x
=+ q=(snag (dec (mul r 2)) x)
=+ z=`(list @)`(snag (mod q n) v)
=+ ^= w |- ^- (list @)
?~ x ~ ?~ z ~
[i=(mix -.x -.z) t=$(x +.x, z +.z)]
$(x (sbm r w), c +(c))
:: :: ++hmc:scr:crypto
++ hmc :: HMAC-SHA-256
|= [k=@ t=@]
(hml k (met 3 k) t (met 3 t))
:: :: ++hml:scr:crypto
++ hml :: w+length
|= [k=@ kl=@ t=@ tl=@]
=> .(k (end [3 kl] k), t (end [3 tl] t))
=+ b=64
=? k (gth kl b) (shay kl k)
=+ ^= q %+ shay (add b tl)
(add (lsh [3 b] t) (mix k (fil 3 b 0x36)))
%+ shay (add b 32)
(add (lsh [3 b] q) (mix k (fil 3 b 0x5c)))
:: :: ++pbk:scr:crypto
++ pbk :: PBKDF2-HMAC-SHA256
~/ %pbk
|= [p=@ s=@ c=@ d=@]
(pbl p (met 3 p) s (met 3 s) c d)
:: :: ++pbl:scr:crypto
++ pbl :: w+length
~/ %pbl
|= [p=@ pl=@ s=@ sl=@ c=@ d=@]
=> .(p (end [3 pl] p), s (end [3 sl] s))
=+ h=32
::
:: max key length 1GB
:: max iterations 2^28
::
?> ?& (lte d (bex 30))
(lte c (bex 28))
!=(c 0)
==
=+ ^= l ?~ (mod d h)
(div d h)
+((div d h))
=+ r=(sub d (mul h (dec l)))
=+ [t=0 j=1 k=1]
=. t |- ^- @
?: (gth j l) t
=+ u=(add s (lsh [3 sl] (rep 3 (flop (rpp 3 4 j)))))
=+ f=0 =. f |- ^- @
?: (gth k c) f
=+ q=(hml p pl u ?:(=(k 1) (add sl 4) h))
$(u q, f (mix f q), k +(k))
$(t (add t (lsh [3 (mul (dec j) h)] f)), j +(j))
(end [3 d] t)
:: :: ++hsh:scr:crypto
++ hsh :: scrypt
~/ %hsh
|= [p=@ s=@ n=@ r=@ z=@ d=@]
(hsl p (met 3 p) s (met 3 s) n r z d)
:: :: ++hsl:scr:crypto
++ hsl :: w+length
~/ %hsl
|= [p=@ pl=@ s=@ sl=@ n=@ r=@ z=@ d=@]
=| v=(list (list @))
=> .(p (end [3 pl] p), s (end [3 sl] s))
=+ u=(mul (mul 128 r) z)
::
:: n is power of 2; max 1GB memory
::
?> ?& =(n (bex (dec (xeb n))))
!=(r 0) !=(z 0)
%+ lte
(mul (mul 128 r) (dec (add n z)))
(bex 30)
(lth pl (bex 31))
(lth sl (bex 31))
==
=+ ^= b =+ (rpp 3 u (pbl p pl s sl 1 u))
%+ turn (bls (mul 128 r) -)
|=(a=(list @) (rpp 9 (mul 2 r) (rep 3 a)))
?> =((lent b) z)
=+ ^= q
=+ |- ?~ b (flop v)
$(b +.b, v [i=(srm r -.b n) t=v])
%+ turn `(list (list @))`-
|=(a=(list @) (rpp 3 (mul 128 r) (rep 9 a)))
(pbl p pl (rep 3 (slb q)) u 1 d)
:: :: ++ypt:scr:crypto
++ ypt :: 256bit {salt pass}
|= [s=@ p=@]
^- @
(hsh p s 16.384 8 1 256)
-- ::scr
:: ::
:::: ++crub:crypto :: (2b4) suite B, Ed
:: ::::
++ crub !:
^- acru
=| [pub=[cry=@ sgn=@] sek=(unit [cry=@ sgn=@])]
|%
:: :: ++as:crub:crypto
++ as ::
|%
:: :: ++sign:as:crub:
++ sign ::
|= msg=@
^- @ux
?~ sek ~| %pubkey-only !!
(jam [(sign:ed msg sgn.u.sek) msg])
:: :: ++sure:as:crub:
++ sure ::
|= txt=@
^- (unit @ux)
=+ ;;([sig=@ msg=@] (cue txt))
?. (veri:ed sig msg sgn.pub) ~
(some msg)
:: :: ++seal:as:crub:
++ seal ::
|= [bpk=pass msg=@]
^- @ux
?~ sek ~| %pubkey-only !!
?> =('b' (end 3 bpk))
=+ pk=(rsh 8 (rsh 3 bpk))
=+ shar=(shax (shar:ed pk cry.u.sek))
=+ smsg=(sign msg)
(jam (~(en siva:aes shar ~) smsg))
:: :: ++tear:as:crub:
++ tear ::
|= [bpk=pass txt=@]
^- (unit @ux)
?~ sek ~| %pubkey-only !!
?> =('b' (end 3 bpk))
=+ pk=(rsh 8 (rsh 3 bpk))
=+ shar=(shax (shar:ed pk cry.u.sek))
=+ ;;([iv=@ len=@ cph=@] (cue txt))
=+ try=(~(de siva:aes shar ~) iv len cph)
?~ try ~
(sure:as:(com:nu:crub bpk) u.try)
-- ::as
:: :: ++de:crub:crypto
++ de :: decrypt
|= [key=@J txt=@]
^- (unit @ux)
=+ ;;([iv=@ len=@ cph=@] (cue txt))
%^ ~(de sivc:aes (shaz key) ~)
iv
len
cph
:: :: ++dy:crub:crypto
++ dy :: need decrypt
|= [key=@J cph=@]
(need (de key cph))
:: :: ++en:crub:crypto
++ en :: encrypt
|= [key=@J msg=@]
^- @ux
(jam (~(en sivc:aes (shaz key) ~) msg))
:: :: ++ex:crub:crypto
++ ex :: extract
|%
:: :: ++fig:ex:crub:crypto
++ fig :: fingerprint
^- @uvH
(shaf %bfig pub)
:: :: ++pac:ex:crub:crypto
++ pac :: private fingerprint
^- @uvG
?~ sek ~| %pubkey-only !!
(end 6 (shaf %bcod sec))
:: :: ++pub:ex:crub:crypto
++ pub :: public key
^- pass
(cat 3 'b' (cat 8 sgn.^pub cry.^pub))
:: :: ++sec:ex:crub:crypto
++ sec :: private key
^- ring
?~ sek ~| %pubkey-only !!
(cat 3 'B' (cat 8 sgn.u.sek cry.u.sek))
-- ::ex
:: :: ++nu:crub:crypto
++ nu ::
|%
:: :: ++pit:nu:crub:crypto
++ pit :: create keypair
|= [w=@ seed=@]
=+ wid=(add (div w 8) ?:(=((mod w 8) 0) 0 1))
=+ bits=(shal wid seed)
=+ [c=(rsh 8 bits) s=(end 8 bits)]
..nu(pub [cry=(puck:ed c) sgn=(puck:ed s)], sek `[cry=c sgn=s])
:: :: ++nol:nu:crub:crypto
++ nol :: activate secret
|= a=ring
=+ [mag=(end 3 a) bod=(rsh 3 a)]
~| %not-crub-seckey ?> =('B' mag)
=+ [c=(rsh 8 bod) s=(end 8 bod)]
..nu(pub [cry=(puck:ed c) sgn=(puck:ed s)], sek `[cry=c sgn=s])
:: :: ++com:nu:crub:crypto
++ com :: activate public
|= a=pass
=+ [mag=(end 3 a) bod=(rsh 3 a)]
~| %not-crub-pubkey ?> =('b' mag)
..nu(pub [cry=(rsh 8 bod) sgn=(end 8 bod)], sek ~)
-- ::nu
-- ::crub
:: ::
:::: ++crua:crypto :: (2b5) suite B, RSA
:: ::::
++ crua !!
:: ::
:::: ++test:crypto :: (2b6) test crypto
:: ::::
++ test ^?
|%
:: :: ++trub:test:crypto
++ trub :: test crub
|= msg=@t
::
:: make acru cores
::
=/ ali (pit:nu:crub 512 (shaz 'Alice'))
=/ ali-pub (com:nu:crub pub:ex.ali)
=/ bob (pit:nu:crub 512 (shaz 'Robert'))
=/ bob-pub (com:nu:crub pub:ex.bob)
::
:: alice signs and encrypts a symmetric key to bob
::
=/ secret-key %- shaz
'Let there be no duplicity when taking a stand against him.'
=/ signed-key (sign:as.ali secret-key)
=/ crypted-key (seal:as.ali pub:ex.bob-pub signed-key)
:: bob decrypts and verifies
=/ decrypt-key-attempt (tear:as.bob pub:ex.ali-pub crypted-key)
=/ decrypted-key ~| %decrypt-fail (need decrypt-key-attempt)
=/ verify-key-attempt (sure:as.ali-pub decrypted-key)
=/ verified-key ~| %verify-fail (need verify-key-attempt)
:: bob encrypts with symmetric key
=/ crypted-msg (en.bob verified-key msg)
:: alice decrypts with same key
`@t`(dy.ali secret-key crypted-msg)
-- ::test
:: ::
:::: ++keccak:crypto :: (2b7) keccak family
:: ::::
++ keccak
|%
::
:: keccak
::
++ keccak-224 |=(a=octs (keccak 1.152 448 224 a))
++ keccak-256 |=(a=octs (keccak 1.088 512 256 a))
++ keccak-384 |=(a=octs (keccak 832 768 384 a))
++ keccak-512 |=(a=octs (keccak 576 1.024 512 a))
::
++ keccak (cury (cury hash keccak-f) padding-keccak)
::
++ padding-keccak (multirate-padding 0x1)
::
:: sha3
::
++ sha3-224 |=(a=octs (sha3 1.152 448 224 a))
++ sha3-256 |=(a=octs (sha3 1.088 512 256 a))
++ sha3-384 |=(a=octs (sha3 832 768 384 a))
++ sha3-512 |=(a=octs (sha3 576 1.024 512 a))
::
++ sha3 (cury (cury hash keccak-f) padding-sha3)
::
++ padding-sha3 (multirate-padding 0x6)
::
:: shake
::
++ shake-128 |=([o=@ud i=octs] (shake 1.344 256 o i))
++ shake-256 |=([o=@ud i=octs] (shake 1.088 512 o i))
::
++ shake (cury (cury hash keccak-f) padding-shake)
::
++ padding-shake (multirate-padding 0x1f)
::
:: rawshake
::
++ rawshake-128 |=([o=@ud i=octs] (rawshake 1.344 256 o i))
++ rawshake-256 |=([o=@ud i=octs] (rawshake 1.088 512 o i))
::
++ rawshake (cury (cury hash keccak-f) padding-rawshake)
::
++ padding-rawshake (multirate-padding 0x7)
::
:: core
::
++ hash
:: per: permutation function with configurable width.
:: pad: padding function.
:: rat: bitrate, size in bits of blocks to operate on.
:: cap: capacity, bits of sponge padding.
:: out: length of desired output, in bits.
:: inp: input to hash.
|= $: per=$-(@ud $-(@ @))
pad=$-([octs @ud] octs)
rat=@ud
cap=@ud
out=@ud
inp=octs
==
^- @
:: urbit's little-endian to keccak's big-endian.
=. q.inp (rev 3 inp)
%. [inp out]
(sponge per pad rat cap)
::
::NOTE if ++keccak ever needs to be made to operate
:: on bits rather than bytes, all that needs to
:: be done is updating the way this padding
:: function works. (and also "octs" -> "bits")
++ multirate-padding
:: dsb: domain separation byte, reverse bit order.
|= dsb=@ux
?> (lte dsb 0xff)
|= [inp=octs mut=@ud]
^- octs
=. mut (div mut 8)
=+ pal=(sub mut (mod p.inp mut))
=? pal =(pal 0) mut
=. pal (dec pal)
:- (add p.inp +(pal))
:: padding is provided in lane bit ordering,
:: ie, LSB = left.
(cat 3 (con (lsh [3 pal] dsb) 0x80) q.inp)
::
++ sponge
:: sponge construction
::
:: preperm: permutation function with configurable width.
:: padding: padding function.
:: bitrate: size of blocks to operate on.
:: capacity: sponge padding.
|= $: preperm=$-(@ud $-(@ @))
padding=$-([octs @ud] octs)
bitrate=@ud
capacity=@ud
==
::
:: preparing
=+ bitrate-bytes=(div bitrate 8)
=+ blockwidth=(add bitrate capacity)
=+ permute=(preperm blockwidth)
::
|= [input=octs output=@ud]
|^ ^- @
::
:: padding
=. input (padding input bitrate)
::
:: absorbing
=/ pieces=(list @)
:: amount of bitrate-sized blocks.
?> =(0 (mod p.input bitrate-bytes))
=+ i=(div p.input bitrate-bytes)
|-
?: =(i 0) ~
:_ $(i (dec i))
:: get the bitrate-sized block of bytes
:: that ends with the byte at -.
=- (cut 3 [- bitrate-bytes] q.input)
(mul (dec i) bitrate-bytes)
=/ state=@
:: for every piece,
%+ roll pieces
|= [p=@ s=@]
:: pad with capacity,
=. p (lsh [0 capacity] p)
:: xor it into the state and permute it.
(permute (mix s (bytes-to-lanes p)))
::
:: squeezing
=| res=@
=| len=@ud
|-
:: append a bitrate-sized head of state to the
:: result.
=. res
%+ con (lsh [0 bitrate] res)
(rsh [0 capacity] (lanes-to-bytes state))
=. len (add len bitrate)
?: (gte len output)
:: produce the requested bits of output.
(rsh [0 (sub len output)] res)
$(res res, state (permute state))
::
++ bytes-to-lanes
:: flip byte order in blocks of 8 bytes.
|= a=@
%^ run 6 a
|=(b=@ (lsh [3 (sub 8 (met 3 b))] (swp 3 b)))
::
++ lanes-to-bytes
:: unflip byte order in blocks of 8 bytes.
|= a=@
%+ can 6
%+ turn
=+ (rip 6 a)
(weld - (reap (sub 25 (lent -)) 0x0))
|= a=@
:- 1
%+ can 3
=- (turn - |=(a=@ [1 a]))
=+ (flop (rip 3 a))
(weld (reap (sub 8 (lent -)) 0x0) -)
--
::
++ keccak-f
:: keccak permutation function
|= [width=@ud]
:: assert valid blockwidth.
?> =- (~(has in -) width)
(sy 25 50 100 200 400 800 1.600 ~)
:: assumes 5x5 lanes state, as is the keccak
:: standard.
=+ size=5
=+ lanes=(mul size size)
=+ lane-bloq=(dec (xeb (div width lanes)))
=+ lane-size=(bex lane-bloq)
=+ rounds=(add 12 (mul 2 lane-bloq))
|= [input=@]
^- @
=* a input
=+ round=0
|^
?: =(round rounds) a
::
:: theta
=/ c=@
%+ roll (gulf 0 (dec size))
|= [x=@ud c=@]
%+ con (lsh [lane-bloq 1] c)
%+ roll (gulf 0 (dec size))
|= [y=@ud c=@]
(mix c (get-lane x y a))
=/ d=@
%+ roll (gulf 0 (dec size))
|= [x=@ud d=@]
%+ con (lsh [lane-bloq 1] d)
%+ mix
=- (get-word - size c)
?:(=(x 0) (dec size) (dec x))
%^ ~(rol fe lane-bloq) 0 1
(get-word (mod +(x) size) size c)
=. a
%+ roll (gulf 0 (dec lanes))
|= [i=@ud a=_a]
%+ mix a
%+ lsh
[lane-bloq (sub lanes +(i))]
(get-word i size d)
::
:: rho and pi
=/ b=@
%+ roll (gulf 0 (dec lanes))
|= [i=@ b=@]
=+ x=(mod i 5)
=+ y=(div i 5)
%+ con b
%+ lsh
:- lane-bloq
%+ sub lanes
%+ add +(y)
%+ mul size
(mod (add (mul 2 x) (mul 3 y)) size)
%^ ~(rol fe lane-bloq) 0
(rotation-offset i)
(get-word i lanes a)
::
:: chi
=. a
%+ roll (gulf 0 (dec lanes))
|= [i=@ud a=@]
%+ con (lsh lane-bloq a)
=+ x=(mod i 5)
=+ y=(div i 5)
%+ mix (get-lane x y b)
%+ dis
=- (get-lane - y b)
(mod (add x 2) size)
%^ not lane-bloq 1
(get-lane (mod +(x) size) y b)
::
:: iota
=. a
=+ (round-constant round)
(mix a (lsh [lane-bloq (dec lanes)] -))
::
:: next round
$(round +(round))
::
++ get-lane
:: get the lane with coordinates
|= [x=@ud y=@ud a=@]
=+ i=(add x (mul size y))
(get-word i lanes a)
::
++ get-word
:: get word {n} from atom {a} of {m} words.
|= [n=@ud m=@ud a=@]
(cut lane-bloq [(sub m +((mod n m))) 1] a)
::
++ round-constant
|= c=@ud
=- (snag (mod c 24) -)
^- (list @ux)
:~ 0x1
0x8082
0x8000.0000.0000.808a
0x8000.0000.8000.8000
0x808b
0x8000.0001
0x8000.0000.8000.8081
0x8000.0000.0000.8009
0x8a
0x88
0x8000.8009
0x8000.000a
0x8000.808b
0x8000.0000.0000.008b
0x8000.0000.0000.8089
0x8000.0000.0000.8003
0x8000.0000.0000.8002
0x8000.0000.0000.0080
0x800a
0x8000.0000.8000.000a
0x8000.0000.8000.8081
0x8000.0000.0000.8080
0x8000.0001
0x8000.0000.8000.8008
==
::
++ rotation-offset
|= x=@ud
=- (snag x -)
^- (list @ud)
:~ 0 1 62 28 27
36 44 6 55 20
3 10 43 25 39
41 45 15 21 8
18 2 61 56 14
==
--
-- ::keccak
:: ::
:::: ++hmac:crypto :: (2b8) hmac family
:: ::::
++ hmac
~% %hmac ..part ~
=, sha
=> |%
++ meet |=([k=@ m=@] [[(met 3 k) k] [(met 3 m) m]])
++ flip |=([k=@ m=@] [(swp 3 k) (swp 3 m)])
--
|%
::
:: use with @
::
++ hmac-sha1 (cork meet hmac-sha1l)
++ hmac-sha256 (cork meet hmac-sha256l)
++ hmac-sha512 (cork meet hmac-sha512l)
::
:: use with @t
::
++ hmac-sha1t (cork flip hmac-sha1)
++ hmac-sha256t (cork flip hmac-sha256)
++ hmac-sha512t (cork flip hmac-sha512)
::
:: use with byts
::
++ hmac-sha1l (cury hmac sha-1l 64 20)
++ hmac-sha256l (cury hmac sha-256l 64 32)
++ hmac-sha512l (cury hmac sha-512l 128 64)
::
:: main logic
::
++ hmac
~/ %hmac
:: boq: block size in bytes used by haj
:: out: bytes output by haj
|* [[haj=$-([@u @] @) boq=@u out=@u] key=byts msg=byts]
:: ensure key and message fit signaled lengths
=. dat.key (end [3 wid.key] dat.key)
=. dat.msg (end [3 wid.msg] dat.msg)
:: keys longer than block size are shortened by hashing
=? dat.key (gth wid.key boq) (haj wid.key dat.key)
=? wid.key (gth wid.key boq) out
:: keys shorter than block size are right-padded
=? dat.key (lth wid.key boq) (lsh [3 (sub boq wid.key)] dat.key)
:: pad key, inner and outer
=+ kip=(mix dat.key (fil 3 boq 0x36))
=+ kop=(mix dat.key (fil 3 boq 0x5c))
:: append inner padding to message, then hash
=+ (haj (add wid.msg boq) (add (lsh [3 wid.msg] kip) dat.msg))
:: prepend outer padding to result, hash again
(haj (add out boq) (add (lsh [3 out] kop) -))
-- :: hmac
:: ::
:::: ++secp:crypto :: (2b9) secp family
:: ::::
++ secp !.
:: TODO: as-octs and hmc are outside of jet parent
=> :+ ..part
hmc=hmac-sha256l:hmac:crypto
as-octs=as-octs:mimes:html
~% %secp +< ~
|%
+$ jacobian [x=@ y=@ z=@] :: jacobian point
+$ point [x=@ y=@] :: curve point
+$ domain
$: p=@ :: prime modulo
a=@ :: y^2=x^3+ax+b
b=@ ::
g=point :: base point
n=@ :: prime order of g
==
++ secp
|_ [bytes=@ =domain]
++ field-p ~(. fo p.domain)
++ field-n ~(. fo n.domain)
++ compress-point
|= =point
^- @
%+ can 3
:~ [bytes x.point]
[1 (add 2 (cut 0 [0 1] y.point))]
==
::
++ serialize-point
|= =point
^- @
%+ can 3
:~ [bytes y.point]
[bytes x.point]
[1 4]
==
::
++ decompress-point
|= compressed=@
^- point
=/ x=@ (end [3 bytes] compressed)
?> =(3 (mod p.domain 4))
=/ fop field-p
=+ [fadd fmul fpow]=[sum.fop pro.fop exp.fop]
=/ y=@ %+ fpow (rsh [0 2] +(p.domain))
%+ fadd b.domain
%+ fadd (fpow 3 x)
(fmul a.domain x)
=/ s=@ (rsh [3 bytes] compressed)
~| [`@ux`s `@ux`compressed]
?> |(=(2 s) =(3 s))
:: check parity
::
=? y !=((sub s 2) (mod y 2))
(sub p.domain y)
[x y]
::
++ jc :: jacobian math
|%
++ from
|= a=jacobian
^- point
=/ fop field-p
=+ [fmul fpow finv]=[pro.fop exp.fop inv.fop]
=/ z (finv z.a)
:- (fmul x.a (fpow 2 z))
(fmul y.a (fpow 3 z))
::
++ into
|= point
^- jacobian
[x y 1]
::
++ double
|= jacobian
^- jacobian
?: =(0 y) [0 0 0]
=/ fop field-p
=+ [fadd fsub fmul fpow]=[sum.fop dif.fop pro.fop exp.fop]
=/ s :(fmul 4 x (fpow 2 y))
=/ m %+ fadd
(fmul 3 (fpow 2 x))
(fmul a.domain (fpow 4 z))
=/ nx %+ fsub
(fpow 2 m)
(fmul 2 s)
=/ ny %+ fsub
(fmul m (fsub s nx))
(fmul 8 (fpow 4 y))
=/ nz :(fmul 2 y z)
[nx ny nz]
::
++ add
|= [a=jacobian b=jacobian]
^- jacobian
?: =(0 y.a) b
?: =(0 y.b) a
=/ fop field-p
=+ [fadd fsub fmul fpow]=[sum.fop dif.fop pro.fop exp.fop]
=/ u1 :(fmul x.a z.b z.b)
=/ u2 :(fmul x.b z.a z.a)
=/ s1 :(fmul y.a z.b z.b z.b)
=/ s2 :(fmul y.b z.a z.a z.a)
?: =(u1 u2)
?. =(s1 s2)
[0 0 1]
(double a)
=/ h (fsub u2 u1)
=/ r (fsub s2 s1)
=/ h2 (fmul h h)
=/ h3 (fmul h2 h)
=/ u1h2 (fmul u1 h2)
=/ nx %+ fsub
(fmul r r)
:(fadd h3 u1h2 u1h2)
=/ ny %+ fsub
(fmul r (fsub u1h2 nx))
(fmul s1 h3)
=/ nz :(fmul h z.a z.b)
[nx ny nz]
::
++ mul
|= [a=jacobian scalar=@]
^- jacobian
?: =(0 y.a)
[0 0 1]
?: =(0 scalar)
[0 0 1]
?: =(1 scalar)
a
?: (gte scalar n.domain)
$(scalar (mod scalar n.domain))
?: =(0 (mod scalar 2))
(double $(scalar (rsh 0 scalar)))
(add a (double $(scalar (rsh 0 scalar))))
--
++ add-points
|= [a=point b=point]
^- point
=/ j jc
(from.j (add.j (into.j a) (into.j b)))
++ mul-point-scalar
|= [p=point scalar=@]
^- point
=/ j jc
%- from.j
%+ mul.j
(into.j p)
scalar
::
++ valid-hash
|= has=@
(lte (met 3 has) bytes)
::
++ in-order
|= i=@
?& (gth i 0)
(lth i n.domain)
==
++ priv-to-pub
|= private-key=@
^- point
?> (in-order private-key)
(mul-point-scalar g.domain private-key)
::
++ make-k
|= [hash=@ private-key=@]
^- @
?> (in-order private-key)
?> (valid-hash hash)
=/ v (fil 3 bytes 1)
=/ k 0
=. k %+ hmc [bytes k]
%- as-octs
%+ can 3
:~ [bytes hash]
[bytes private-key]
[1 0]
[bytes v]
==
=. v (hmc bytes^k bytes^v)
=. k %+ hmc [bytes k]
%- as-octs
%+ can 3
:~ [bytes hash]
[bytes private-key]
[1 1]
[bytes v]
==
=. v (hmc bytes^k bytes^v)
(hmc bytes^k bytes^v)
::
++ ecdsa-raw-sign
|= [hash=@ private-key=@]
^- [r=@ s=@ y=@]
:: make-k and priv-to pub will validate inputs
=/ k (make-k hash private-key)
=/ rp (priv-to-pub k)
=* r x.rp
?< =(0 r)
=/ fon field-n
=+ [fadd fmul finv]=[sum.fon pro.fon inv.fon]
=/ s %+ fmul (finv k)
%+ fadd hash
%+ fmul r
private-key
?< =(0 s)
[r s y.rp]
:: general recovery omitted, but possible
--
++ secp256k1
~% %secp256k1 + ~
|%
++ t :: in the battery for jet matching
^- domain
:* 0xffff.ffff.ffff.ffff.ffff.ffff.ffff.ffff.
ffff.ffff.ffff.ffff.ffff.fffe.ffff.fc2f
0
7
:- 0x79be.667e.f9dc.bbac.55a0.6295.ce87.0b07.
029b.fcdb.2dce.28d9.59f2.815b.16f8.1798
0x483a.da77.26a3.c465.5da4.fbfc.0e11.08a8.
fd17.b448.a685.5419.9c47.d08f.fb10.d4b8
0xffff.ffff.ffff.ffff.ffff.ffff.ffff.fffe.
baae.dce6.af48.a03b.bfd2.5e8c.d036.4141
==
::
++ curve ~(. secp 32 t)
++ serialize-point serialize-point:curve
++ compress-point compress-point:curve
++ decompress-point decompress-point:curve
++ add-points add-points:curve
++ mul-point-scalar mul-point-scalar:curve
++ make-k
~/ %make
|= [hash=@uvI private-key=@]
:: checks sizes
(make-k:curve hash private-key)
++ priv-to-pub
|= private-key=@
:: checks sizes
(priv-to-pub:curve private-key)
::
++ ecdsa-raw-sign
~/ %sign
|= [hash=@uvI private-key=@]
^- [v=@ r=@ s=@]
=/ c curve
:: raw-sign checks sizes
=+ (ecdsa-raw-sign.c hash private-key)
=/ rp=point [r y]
=/ s-high (gte (mul 2 s) n.domain.c)
=? s s-high
(sub n.domain.c s)
=? rp s-high
[x.rp (sub p.domain.c y.rp)]
=/ v (end 0 y.rp)
=? v (gte x.rp n.domain.c)
(add v 2)
[v x.rp s]
::
++ ecdsa-raw-recover
~/ %reco
|= [hash=@ sig=[v=@ r=@ s=@]]
^- point
?> (lte v.sig 3)
=/ c curve
?> (valid-hash.c hash)
?> (in-order.c r.sig)
?> (in-order.c s.sig)
=/ x ?: (gte v.sig 2)
(add r.sig n.domain.c)
r.sig
=/ fop field-p.c
=+ [fadd fmul fpow]=[sum.fop pro.fop exp.fop]
=/ ysq (fadd (fpow 3 x) b.domain.c)
=/ beta (fpow (rsh [0 2] +(p.domain.c)) ysq)
=/ y ?: =((end 0 v.sig) (end 0 beta))
beta
(sub p.domain.c beta)
?> =(0 (dif.fop ysq (fmul y y)))
=/ nz (sub n.domain.c hash)
=/ j jc.c
=/ gz (mul.j (into.j g.domain.c) nz)
=/ xy (mul.j (into.j x y) s.sig)
=/ qr (add.j gz xy)
=/ qj (mul.j qr (inv:field-n.c x))
=/ pub (from.j qj)
?< =([0 0] pub)
pub
--
--
::
++ blake
~% %blake ..part ~
|%
::TODO generalize for both blake2 variants
++ blake2b
~/ %blake2b
|= [msg=byts key=byts out=@ud]
^- @
:: initialization vector
=/ iv=@
0x6a09.e667.f3bc.c908.
bb67.ae85.84ca.a73b.
3c6e.f372.fe94.f82b.
a54f.f53a.5f1d.36f1.
510e.527f.ade6.82d1.
9b05.688c.2b3e.6c1f.
1f83.d9ab.fb41.bd6b.
5be0.cd19.137e.2179
:: per-round constants
=/ sigma=(list (list @ud))
:~
:~ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ==
:~ 14 10 4 8 9 15 13 6 1 12 0 2 11 7 5 3 ==
:~ 11 8 12 0 5 2 15 13 10 14 3 6 7 1 9 4 ==
:~ 7 9 3 1 13 12 11 14 2 6 5 10 4 0 15 8 ==
:~ 9 0 5 7 2 4 10 15 14 1 11 12 6 8 3 13 ==
:~ 2 12 6 10 0 11 8 3 4 13 7 5 15 14 1 9 ==
:~ 12 5 1 15 14 13 4 10 0 7 6 3 9 2 8 11 ==
:~ 13 11 7 14 12 1 3 9 5 0 15 4 8 6 2 10 ==
:~ 6 15 14 9 11 3 0 8 12 2 13 7 1 4 10 5 ==
:~ 10 2 8 4 7 6 1 5 15 11 9 14 3 12 13 0 ==
:~ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ==
:~ 14 10 4 8 9 15 13 6 1 12 0 2 11 7 5 3 ==
==
=> |%
++ get-word-list
|= [h=@ w=@ud]
^- (list @)
%- flop
=+ l=(rip 6 h)
=- (weld - l)
(reap (sub w (lent l)) 0)
::
++ get-word
|= [h=@ i=@ud w=@ud]
^- @
%+ snag i
(get-word-list h w)
::
++ put-word
|= [h=@ i=@ud w=@ud d=@]
^- @
%+ rep 6
=+ l=(get-word-list h w)
%- flop
%+ weld (scag i l)
[d (slag +(i) l)]
::
++ mod-word
|* [h=@ i=@ud w=@ud g=$-(@ @)]
(put-word h i w (g (get-word h i w)))
::
++ pad
|= [byts len=@ud]
(lsh [3 (sub len wid)] dat)
::
++ compress
|= [h=@ c=@ t=@ud l=?]
^- @
:: set up local work vector
=+ v=(add (lsh [6 8] h) iv)
:: xor the counter t into v
=. v
%- mod-word
:^ v 12 16
(cury mix (end [0 64] t))
=. v
%- mod-word
:^ v 13 16
(cury mix (rsh [0 64] t))
:: for the last block, invert v14
=? v l
%- mod-word
:^ v 14 16
(cury mix 0xffff.ffff.ffff.ffff)
:: twelve rounds of message mixing
=+ i=0
=| s=(list @)
|^
?: =(i 12)
:: xor upper and lower halves of v into state h
=. h (mix h (rsh [6 8] v))
(mix h (end [6 8] v))
:: select message mixing schedule and mix v
=. s (snag (mod i 10) sigma)
=. v (do-mix 0 4 8 12 0 1)
=. v (do-mix 1 5 9 13 2 3)
=. v (do-mix 2 6 10 14 4 5)
=. v (do-mix 3 7 11 15 6 7)
=. v (do-mix 0 5 10 15 8 9)
=. v (do-mix 1 6 11 12 10 11)
=. v (do-mix 2 7 8 13 12 13)
=. v (do-mix 3 4 9 14 14 15)
$(i +(i))
::
++ do-mix
|= [na=@ nb=@ nc=@ nd=@ nx=@ ny=@]
^- @
=- =. v (put-word v na 16 a)
=. v (put-word v nb 16 b)
=. v (put-word v nc 16 c)
(put-word v nd 16 d)
%- b2mix
:* (get-word v na 16)
(get-word v nb 16)
(get-word v nc 16)
(get-word v nd 16)
(get-word c (snag nx s) 16)
(get-word c (snag ny s) 16)
==
--
::
++ b2mix
|= [a=@ b=@ c=@ d=@ x=@ y=@]
^- [a=@ b=@ c=@ d=@]
=. x (rev 3 8 x)
=. y (rev 3 8 y)
=+ fed=~(. fe 6)
=. a :(sum:fed a b x)
=. d (ror:fed 0 32 (mix d a))
=. c (sum:fed c d)
=. b (ror:fed 0 24 (mix b c))
=. a :(sum:fed a b y)
=. d (ror:fed 0 16 (mix d a))
=. c (sum:fed c d)
=. b (ror:fed 0 63 (mix b c))
[a b c d]
--
:: ensure inputs adhere to contraints
=. out (max 1 (min out 64))
=. wid.msg (min wid.msg (bex 128))
=. wid.key (min wid.key 64)
=. dat.msg (end [3 wid.msg] dat.msg)
=. dat.key (end [3 wid.key] dat.key)
:: initialize state vector
=+ h=iv
:: mix key length and output length into h0
=. h
%- mod-word
:^ h 0 8
%+ cury mix
%+ add 0x101.0000
(add (lsh 3 wid.key) out)
:: keep track of how much we've compressed
=* mes dat.msg
=+ com=0
=+ rem=wid.msg
:: if we have a key, pad it and prepend to msg
=? mes (gth wid.key 0)
(can 3 ~[rem^mes 128^(pad key 128)])
=? rem (gth wid.key 0)
(add rem 128)
|-
:: compress 128-byte chunks of the message
?: (gth rem 128)
=+ c=(cut 3 [(sub rem 128) 128] mes)
=. com (add com 128)
%_ $
rem (sub rem 128)
h (compress h c com |)
==
:: compress the final bytes of the msg
=+ c=(cut 3 [0 rem] mes)
=. com (add com rem)
=. c (pad [rem c] 128)
=. h (compress h c com &)
:: produce output of desired length
%+ rsh [3 (sub 64 out)]
:: do some word
%+ rep 6
%+ turn (flop (gulf 0 7))
|= a=@
(rev 3 8 (get-word h a 8))
-- ::blake
::
++ argon2
~% %argon ..part ~
|%
::
:: structures
::
+$ argon-type ?(%d %i %id %u)
::
:: shorthands
::
++ argon2-urbit
|= out=@ud
(argon2 out %u 0x13 4 512.000 1 *byts *byts)
::
:: argon2 proper
::
:: main argon2 operation
++ argon2
:: out: desired output size in bytes
:: typ: argon2 type
:: version: argon2 version (0x10/v1.0 or 0x13/v1.3)
:: threads: amount of threads/parallelism
:: mem-cost: kb of memory to use
:: time-cost: iterations to run
:: key: optional secret
:: extra: optional arbitrary data
|= $: out=@ud
typ=argon-type
version=@ux
::
threads=@ud
mem-cost=@ud
time-cost=@ud
::
key=byts
extra=byts
==
^- $-([msg=byts sat=byts] @)
::
:: check configuration sanity
::
?: =(0 threads)
~| %parallelism-must-be-above-zero
!!
?: =(0 time-cost)
~| %time-cost-must-be-above-zero
!!
?: (lth mem-cost (mul 8 threads))
~| :- %memory-cost-must-be-at-least-threads
[threads %times 8 (mul 8 threads)]
!!
?. |(=(0x10 version) =(0x13 version))
~| [%unsupported-version version %want [0x10 0x13]]
!!
::
:: calculate constants and initialize buffer
::
:: for each thread, there is a row in the buffer.
:: the amount of columns depends on the memory-cost.
:: columns are split into groups of four.
:: a single such quarter section of a row is a segment.
::
:: blocks: (m_prime)
:: columns: row length (q)
:: seg-length: segment length
=/ blocks=@ud
:: round mem-cost down to the nearest multiple of 4*threads
=+ (mul 4 threads)
(mul (div mem-cost -) -)
=+ columns=(div blocks threads)
=+ seg-length=(div columns 4)
::
=/ buffer=(list (list @))
(reap threads (reap columns 0))
::
:: main function
::
:: msg: the main input
:: sat: optional salt
~% %argon2 ..argon2 ~
|= [msg=byts sat=byts]
^- @
?: (lth wid.sat 8)
~| [%min-salt-length-is-8 wid.sat]
!!
::
:: h0: initial 64-byte block
=/ h0=@
=- (blake2b:blake - 0^0 64)
:- :(add 40 wid.msg wid.sat wid.key wid.extra)
%+ can 3
=+ (cury (cury rev 3) 4)
:~ (prep-wid extra)
(prep-wid key)
(prep-wid sat)
(prep-wid msg)
4^(- (type-to-num typ))
4^(- version)
4^(- time-cost)
4^(- mem-cost)
4^(- out)
4^(- threads)
==
::
:: do time-cost passes over the buffer
::
=+ t=0
|-
?: (lth t time-cost)
::
:: process all four segments in the columns...
::
=+ s=0
|-
?. (lth s 4) ^$(t +(t))
::
:: ...of every row/thread
::
=+ r=0
|-
?. (lth r threads) ^$(s +(s))
=; new=_buffer
$(buffer new, r +(r))
%- fill-segment
:* buffer h0
t s r
blocks columns seg-length
threads time-cost typ version
==
::
:: mix all rows together and hash the result
::
=+ r=0
=| final=@
|-
?: =(r threads)
(hash 1.024^final out)
=- $(final -, r +(r))
%+ mix final
(snag (dec columns) (snag r buffer))
::
:: per-segment computation
++ fill-segment
|= $: buffer=(list (list @))
h0=@
::
itn=@ud
seg=@ud
row=@ud
::
blocks=@ud
columns=@ud
seg-length=@ud
::
threads=@ud
time-cost=@ud
typ=argon-type
version=@ux
==
::
:: fill-segment utilities
::
=> |%
++ put-word
|= [rob=(list @) i=@ud d=@]
%+ weld (scag i rob)
[d (slag +(i) rob)]
--
^+ buffer
::
:: rob: row buffer to operate on
:: do-i: whether to use prns from input rather than state
:: rands: prns generated from input, if we do-i
=+ rob=(snag row buffer)
=/ do-i=?
?| ?=(%i typ)
&(?=(%id typ) =(0 itn) (lte seg 1))
&(?=(%u typ) =(0 itn) (lte seg 2))
==
=/ rands=(list (pair @ @))
?. do-i ~
::
:: keep going until we have a list of :seg-length prn pairs
::
=+ l=0
=+ counter=1
|- ^- (list (pair @ @))
?: (gte l seg-length) ~
=- (weld - $(counter +(counter), l (add l 128)))
::
:: generate pseudorandom block by compressing metadata
::
=/ random-block=@
%+ compress 0
%+ compress 0
%+ lsh [3 968]
%+ rep 6
=+ (cury (cury rev 3) 8)
:~ (- counter)
(- (type-to-num typ))
(- time-cost)
(- blocks)
(- seg)
(- row)
(- itn)
==
::
:: split the random-block into 64-bit sections,
:: then extract the first two 4-byte sections from each.
::
%+ turn (flop (rip 6 random-block))
|= a=@
^- (pair @ @)
:- (rev 3 4 (rsh 5 a))
(rev 3 4 (end 5 a))
::
:: iterate over the entire segment length
::
=+ sin=0
|-
::
:: when done, produce the updated buffer
::
?: =(sin seg-length)
%+ weld (scag row buffer)
[rob (slag +(row) buffer)]
::
:: col: current column to process
=/ col=@ud
(add (mul seg seg-length) sin)
::
:: first two columns are generated from h0
::
?: &(=(0 itn) (lth col 2))
=+ (app-num (app-num 64^h0 col) row)
=+ (hash - 1.024)
$(rob (put-word rob col -), sin +(sin))
::
:: c1, c2: prns for picking reference block
=/ [c1=@ c2=@]
?: do-i (snag sin rands)
=+ =- (snag - rob)
?: =(0 col) (dec columns)
(mod (dec col) columns)
:- (rev 3 4 (cut 3 [1.020 4] -))
(rev 3 4 (cut 3 [1.016 4] -))
::
:: ref-row: reference block row
=/ ref-row=@ud
?: &(=(0 itn) =(0 seg)) row
(mod c2 threads)
::
:: ref-col: reference block column
=/ ref-col=@ud
=- (mod - columns)
%+ add
:: starting index
?: |(=(0 itn) =(3 seg)) 0
(mul +(seg) seg-length)
:: pseudorandom offset
=- %+ sub (dec -)
%+ rsh [0 32]
%+ mul -
(rsh [0 32] (mul c1 c1))
:: reference area size
?: =(0 itn)
?: |(=(0 seg) =(row ref-row)) (dec col)
?: =(0 sin) (dec (mul seg seg-length))
(mul seg seg-length)
=+ sul=(sub columns seg-length)
?: =(ref-row row) (dec (add sul sin))
?: =(0 sin) (dec sul)
sul
::
:: compress the previous and reference block
:: to create the new block
::
=/ new=@
%+ compress
=- (snag - rob)
:: previous index, wrap-around
?: =(0 col) (dec columns)
(mod (dec col) columns)
:: get reference block
%+ snag ref-col
?: =(ref-row row) rob
(snag ref-row buffer)
::
:: starting from v1.3, we xor the new block in,
:: rather than directly overwriting the old block
::
=? new &(!=(0 itn) =(0x13 version))
(mix new (snag col rob))
$(rob (put-word rob col new), sin +(sin))
::
:: compression function (g)
++ compress
:: x, y: assumed to be 1024 bytes
|= [x=@ y=@]
^- @
::
=+ r=(mix x y)
=| q=(list @)
::
:: iterate over rows of r to get q
::
=+ i=0
|-
?: (lth i 8)
=; p=(list @)
$(q (weld q p), i +(i))
%- permute
=- (weld (reap (sub 8 (lent -)) 0) -)
%- flop
%+ rip 7
(cut 10 [(sub 7 i) 1] r)
::
:: iterate over columns of q to get z
::
=/ z=(list @) (reap 64 0)
=. i 0
|-
::
:: when done, assemble z and xor it with r
::
?. (lth i 8)
(mix (rep 7 (flop z)) r)
::
:: permute the column
::
=/ out=(list @)
%- permute
:~ (snag i q)
(snag (add i 8) q)
(snag (add i 16) q)
(snag (add i 24) q)
(snag (add i 32) q)
(snag (add i 40) q)
(snag (add i 48) q)
(snag (add i 56) q)
==
::
:: put the result into z per column
::
=+ j=0
|-
?: =(8 j) ^$(i +(i))
=- $(z -, j +(j))
=+ (add i (mul j 8))
%+ weld (scag - z)
[(snag j out) (slag +(-) z)]
::
:: permutation function (p)
++ permute
::NOTE this function really just takes and produces
:: 8 values, but taking and producing them as
:: lists helps clean up the code significantly.
|= s=(list @)
?> =(8 (lent s))
^- (list @)
::
:: list inputs as 16 8-byte values
::
=/ v=(list @)
%- zing
^- (list (list @))
%+ turn s
|= a=@
:: rev for endianness
=+ (rip 6 (rev 3 16 a))
(weld - (reap (sub 2 (lent -)) 0))
::
:: do permutation rounds
::
=. v (do-round v 0 4 8 12)
=. v (do-round v 1 5 9 13)
=. v (do-round v 2 6 10 14)
=. v (do-round v 3 7 11 15)
=. v (do-round v 0 5 10 15)
=. v (do-round v 1 6 11 12)
=. v (do-round v 2 7 8 13)
=. v (do-round v 3 4 9 14)
:: rev for endianness
=. v (turn v (cury (cury rev 3) 8))
::
:: cat v back together into 8 16-byte values
::
%+ turn (gulf 0 7)
|= i=@
=+ (mul 2 i)
(cat 6 (snag +(-) v) (snag - v))
::
:: perform a round and produce updated value list
++ do-round
|= [v=(list @) na=@ nb=@ nc=@ nd=@]
^+ v
=> |%
++ get-word
|= i=@ud
(snag i v)
::
++ put-word
|= [i=@ud d=@]
^+ v
%+ weld (scag i v)
[d (slag +(i) v)]
--
=- =. v (put-word na a)
=. v (put-word nb b)
=. v (put-word nc c)
(put-word nd d)
%- round
:* (get-word na)
(get-word nb)
(get-word nc)
(get-word nd)
==
::
:: perform a round (bg) and produce updated values
++ round
|= [a=@ b=@ c=@ d=@]
^- [a=@ b=@ c=@ d=@]
:: operate on 64 bit words
=+ fed=~(. fe 6)
=* sum sum:fed
=* ror ror:fed
=+ end=(cury end 5)
=. a :(sum a b :(mul 2 (end a) (end b)))
=. d (ror 0 32 (mix d a))
=. c :(sum c d :(mul 2 (end c) (end d)))
=. b (ror 0 24 (mix b c))
=. a :(sum a b :(mul 2 (end a) (end b)))
=. d (ror 0 16 (mix d a))
=. c :(sum c d :(mul 2 (end c) (end d)))
=. b (ror 0 63 (mix b c))
[a b c d]
::
:: argon2 wrapper around blake2b (h')
++ hash
=, blake
|= [byts out=@ud]
^- @
::
:: msg: input with byte-length prepended
=+ msg=(prep-num [wid dat] out)
::
:: if requested size is low enough, hash directly
::
?: (lte out 64)
(blake2b msg 0^0 out)
::
:: build up the result by hashing and re-hashing
:: the input message, adding the first 32 bytes
:: of the hash to the result, until we have the
:: desired output size.
::
=+ tmp=(blake2b msg 0^0 64)
=+ res=(rsh [3 32] tmp)
=. out (sub out 32)
|-
?: (gth out 64)
=. tmp (blake2b 64^tmp 0^0 64)
=. res (add (lsh [3 32] res) (rsh [3 32] tmp))
$(out (sub out 32))
%+ add (lsh [3 out] res)
(blake2b 64^tmp 0^0 out)
::
:: utilities
::
++ type-to-num
|= t=argon-type
?- t
%d 0
%i 1
%id 2
%u 10
==
::
++ app-num
|= [byts num=@ud]
^- byts
:- (add wid 4)
%+ can 3
~[4^(rev 3 4 num) wid^dat]
::
++ prep-num
|= [byts num=@ud]
^- byts
:- (add wid 4)
%+ can 3
~[wid^dat 4^(rev 3 4 num)]
::
++ prep-wid
|= a=byts
(prep-num a wid.a)
--
::
++ ripemd
~% %ripemd ..part ~
|%
++ ripemd-160
~/ %ripemd160
|= byts
^- @
:: we operate on bits rather than bytes
=. wid (mul wid 8)
:: add padding
=+ (md5-pad wid dat)
:: endianness
=. dat (run 5 dat |=(a=@ (rev 3 4 a)))
=* x dat
=+ blocks=(div wid 512)
=+ fev=~(. fe 5)
:: initial register values
=+ h0=0x6745.2301
=+ h1=0xefcd.ab89
=+ h2=0x98ba.dcfe
=+ h3=0x1032.5476
=+ h4=0xc3d2.e1f0
:: i: current block
=+ [i=0 j=0]
=+ *[a=@ b=@ c=@ d=@ e=@] :: a..e
=+ *[aa=@ bb=@ cc=@ dd=@ ee=@] :: a'..e'
|^
?: =(i blocks)
%+ rep 5
%+ turn `(list @)`~[h4 h3 h2 h1 h0]
:: endianness
|=(h=@ (rev 3 4 h))
=: a h0 aa h0
b h1 bb h1
c h2 cc h2
d h3 dd h3
e h4 ee h4
==
:: j: current word
=+ j=0
|-
?: =(j 80)
%= ^$
i +(i)
h1 :(sum:fev h2 d ee)
h2 :(sum:fev h3 e aa)
h3 :(sum:fev h4 a bb)
h4 :(sum:fev h0 b cc)
h0 :(sum:fev h1 c dd)
==
%= $
j +(j)
::
a e
b (fn j a b c d e (get (r j)) (k j) (s j))
c b
d (rol 10 c)
e d
::
aa ee
bb (fn (sub 79 j) aa bb cc dd ee (get (rr j)) (kk j) (ss j))
cc bb
dd (rol 10 cc)
ee dd
==
::
++ get :: word from x in block i
|= j=@ud
=+ (add (mul i 16) +(j))
(cut 5 [(sub (mul blocks 16) -) 1] x)
::
++ fn
|= [j=@ud a=@ b=@ c=@ d=@ e=@ m=@ k=@ s=@]
=- (sum:fev (rol s :(sum:fev a m k -)) e)
=. j (div j 16)
?: =(0 j) (mix (mix b c) d)
?: =(1 j) (con (dis b c) (dis (not 0 32 b) d))
?: =(2 j) (mix (con b (not 0 32 c)) d)
?: =(3 j) (con (dis b d) (dis c (not 0 32 d)))
?: =(4 j) (mix b (con c (not 0 32 d)))
!!
::
++ rol (cury rol:fev 0)
::
++ k
|= j=@ud
=. j (div j 16)
?: =(0 j) 0x0
?: =(1 j) 0x5a82.7999
?: =(2 j) 0x6ed9.eba1
?: =(3 j) 0x8f1b.bcdc
?: =(4 j) 0xa953.fd4e
!!
::
++ kk :: k'
|= j=@ud
=. j (div j 16)
?: =(0 j) 0x50a2.8be6
?: =(1 j) 0x5c4d.d124
?: =(2 j) 0x6d70.3ef3
?: =(3 j) 0x7a6d.76e9
?: =(4 j) 0x0
!!
::
++ r
|= j=@ud
%+ snag j
^- (list @)
:~ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
7 4 13 1 10 6 15 3 12 0 9 5 2 14 11 8
3 10 14 4 9 15 8 1 2 7 0 6 13 11 5 12
1 9 11 10 0 8 12 4 13 3 7 15 14 5 6 2
4 0 5 9 7 12 2 10 14 1 3 8 11 6 15 13
==
::
++ rr :: r'
|= j=@ud
%+ snag j
^- (list @)
:~ 5 14 7 0 9 2 11 4 13 6 15 8 1 10 3 12
6 11 3 7 0 13 5 10 14 15 8 12 4 9 1 2
15 5 1 3 7 14 6 9 11 8 12 2 10 0 4 13
8 6 4 1 3 11 15 0 5 12 2 13 9 7 10 14
12 15 10 4 1 5 8 7 6 2 13 14 0 3 9 11
==
::
++ s
|= j=@ud
%+ snag j
^- (list @)
:~ 11 14 15 12 5 8 7 9 11 13 14 15 6 7 9 8
7 6 8 13 11 9 7 15 7 12 15 9 11 7 13 12
11 13 6 7 14 9 13 15 14 8 13 6 5 12 7 5
11 12 14 15 14 15 9 8 9 14 5 6 8 6 5 12
9 15 5 11 6 8 13 12 5 12 13 14 11 8 5 6
==
::
++ ss :: s'
|= j=@ud
%+ snag j
^- (list @)
:~ 8 9 9 11 13 15 15 5 7 7 8 11 14 14 12 6
9 13 15 7 12 8 9 11 7 7 12 7 6 15 13 11
9 7 15 11 8 6 6 14 12 13 5 14 13 13 7 5
15 5 8 11 14 14 6 14 6 9 12 9 12 5 15 8
8 5 12 9 12 5 14 6 8 13 6 5 15 13 11 11
==
--
::
++ md5-pad
|= byts
^- byts
=+ (sub 511 (mod (add wid 64) 512))
:- :(add 64 +(-) wid)
%+ can 0
~[64^(rev 3 8 wid) +(-)^(lsh [0 -] 1) wid^dat]
--
::
++ pbkdf
=> |%
++ meet |=([p=@ s=@ c=@ d=@] [[(met 3 p) p] [(met 3 s) s] c d])
++ flip |= [p=byts s=byts c=@ d=@]
[wid.p^(rev 3 p) wid.s^(rev 3 s) c d]
--
|%
::
:: use with @
::
++ hmac-sha1 (cork meet hmac-sha1l)
++ hmac-sha256 (cork meet hmac-sha256l)
++ hmac-sha512 (cork meet hmac-sha512l)
::
:: use with @t
::
++ hmac-sha1t (cork meet hmac-sha1d)
++ hmac-sha256t (cork meet hmac-sha256d)
++ hmac-sha512t (cork meet hmac-sha512d)
::
:: use with byts
::
++ hmac-sha1l (cork flip hmac-sha1d)
++ hmac-sha256l (cork flip hmac-sha256d)
++ hmac-sha512l (cork flip hmac-sha512d)
::
:: main logic
::
++ hmac-sha1d (cury pbkdf hmac-sha1l:hmac 20)
++ hmac-sha256d (cury pbkdf hmac-sha256l:hmac 32)
++ hmac-sha512d (cury pbkdf hmac-sha512l:hmac 64)
::
++ pbkdf
::TODO jet me! ++hmac:hmac is an example
|* [[prf=$-([byts byts] @) out=@u] p=byts s=byts c=@ d=@]
=> .(dat.p (end [3 wid.p] dat.p), dat.s (end [3 wid.s] dat.s))
::
:: max key length 1GB
:: max iterations 2^28
::
~| [%invalid-pbkdf-params c d]
?> ?& (lte d (bex 30))
(lte c (bex 28))
!=(c 0)
==
=/ l
?~ (mod d out)
(div d out)
+((div d out))
=+ r=(sub d (mul out (dec l)))
=+ [t=0 j=1 k=1]
=. t
|- ^- @
?: (gth j l) t
=/ u
%+ add dat.s
%+ lsh [3 wid.s]
%+ rep 3
(flop (rpp:scr 3 4 j))
=+ f=0
=. f
|- ^- @
?: (gth k c) f
=/ q
%^ rev 3 out
=+ ?:(=(k 1) (add wid.s 4) out)
(prf [wid.p (rev 3 p)] [- (rev 3 - u)])
$(u q, f (mix f q), k +(k))
$(t (add t (lsh [3 (mul (dec j) out)] f)), j +(j))
(rev 3 d (end [3 d] t))
--
-- ::crypto
:: ::::
:::: ++unity :: (2c) unit promotion
:: ::::
++ unity ^?
|%
:: :: ++drop-list:unity
++ drop-list :: collapse unit list
|* lut=(list (unit))
?. |- ^- ?
?~(lut & ?~(i.lut | $(lut t.lut)))
~
%- some
|-
?~ lut ~
[i=u:+.i.lut t=$(lut t.lut)]
:: :: ++drop-map:unity
++ drop-map :: collapse unit map
|* lum=(map term (unit))
?: (~(rep by lum) |=([[@ a=(unit)] b=_|] |(b ?=(~ a))))
~
(some (~(run by lum) need))
:: :: ++drop-pole:unity
++ drop-pole :: collapse to tuple
|^ |* pul=(pole (unit))
?: (test-pole pul) ~
(some (need-pole pul))
::
++ test-pole
|* pul=(pole (unit))
^- ?
?~ pul &
?| ?=(~ -.pul)
?~(+.pul | (test-pole +.pul))
==
::
++ need-pole
|* pul=(pole (unit))
?~ pul !!
?~ +.pul
u:->.pul
[u:->.pul (need-pole +.pul)]
--
--
:: ::::
:::: ++format :: (2d) common formats
:: ::::
++ format ^?
|%
:: 0 ending a line (invalid @t) is not preserved :: ++to-wain:format
++ to-wain :: cord to line list
~% %leer ..part ~
|= txt=cord
^- wain
=/ len=@ (met 3 txt)
=/ cut =+(cut -(a 3, c 1, d txt))
=/ sub sub
=| [i=@ out=wain]
|- ^+ out
=+ |- ^- j=@
?: ?| =(i len)
=(10 (cut(b i)))
==
i
$(i +(i))
=. out :_ out
(cut(b i, c (sub j i)))
?: =(j len)
(flop out)
$(i +(j))
:: :: ++of-wain:format
++ of-wain :: line list to cord
|= tez=wain ^- cord
(rap 3 (join '\0a' tez))
:: :: ++of-wall:format
++ of-wall :: line list to tape
|= a=wall ^- tape
?~(a ~ "{i.a}\0a{$(a t.a)}")
::
++ json-rn :: json to rn parser
%+ knee *rn |.
;~ plug
(easy %d)
;~(pose (cold | hep) (easy &))
;~ plug dim:ag
;~ pose
;~ pfix dot
%+ sear
|= a=tape
=/ b (rust a dum:ag)
?~ b ~
(some [(lent a) u.b])
(plus (shim '0' '9'))
==
(easy [0 0])
==
;~ pose
;~ pfix
(mask "eE")
;~ plug
;~(pose (cold | hep) (cold & lus) (easy &))
;~ pose
;~(pfix (plus (just '0')) dim:ag)
dim:ag
==
==
==
(easy [& 0])
==
==
==
:: :: ++enjs:format
++ enjs ^? :: json encoders
|%
:: :: ++frond:enjs:format
++ frond :: object from k-v pair
|= [p=@t q=json]
^- json
[%o [[p q] ~ ~]]
:: :: ++pairs:enjs:format
++ pairs :: object from k-v list
|= a=(list [p=@t q=json])
^- json
[%o (~(gas by *(map @t json)) a)]
:: :: ++tape:enjs:format
++ tape :: string from tape
|= a=^tape
^- json
[%s (crip a)]
:: :: ++wall:enjs:format
++ wall :: string from wall
|= a=^wall
^- json
(tape (of-wall a))
:: :: ++ship:enjs:format
++ ship :: string from ship
|= a=^ship
^- json
(tape (slag 1 (scow %p a)))
:: :: ++numb:enjs:format
++ numb :: number from unsigned
|= a=@u
^- json
:- %n
?: =(0 a) '0'
%- crip
%- flop
|- ^- ^tape
?:(=(0 a) ~ [(add '0' (mod a 10)) $(a (div a 10))])
:: :: ++time:enjs:format
++ time :: ms timestamp
|= a=^time
=- (numb (div (mul - 1.000) ~s1))
(add (div ~s1 2.000) (sub a ~1970.1.1))
:: :: ++path:enjs:format
++ path :: string from path
|= a=^path
^- json
[%s (spat a)]
:: :: ++tank:enjs:format
++ tank :: tank as string arr
|= a=^tank
^- json
[%a (turn (wash [0 80] a) tape)]
-- ::enjs
:: :: ++dejs:format
++ dejs :: json reparser
=> |% ++ grub * :: result
++ fist $-(json grub) :: reparser instance
-- ::
|%
:: :: ++ar:dejs:format
++ ar :: array as list
|* wit=fist
|= jon=json ^- (list _(wit *json))
?> ?=([%a *] jon)
(turn p.jon wit)
:: :: ++as:dejs:format
++ as :: array as set
|* a=fist
(cu ~(gas in *(set _$:a)) (ar a))
:: :: ++at:dejs:format
++ at :: array as tuple
|* wil=(pole fist)
|= jon=json
?> ?=([%a *] jon)
((at-raw wil) p.jon)
:: :: ++at-raw:dejs:format
++ at-raw :: array as tuple
|* wil=(pole fist)
|= jol=(list json)
?~ jol !!
?- wil :: mint-vain on empty
:: [wit=* t=*]
[* t=*]
=> .(wil [wit *]=wil)
?~ t.wil ?^(t.jol !! (wit.wil i.jol))
[(wit.wil i.jol) ((at-raw t.wil) t.jol)]
==
:: :: ++bo:dejs:format
++ bo :: boolean
|=(jon=json ?>(?=([%b *] jon) p.jon))
:: :: ++bu:dejs:format
++ bu :: boolean not
|=(jon=json ?>(?=([%b *] jon) !p.jon))
:: :: ++ci:dejs:format
++ ci :: maybe transform
|* [poq=gate wit=fist]
|= jon=json
(need (poq (wit jon)))
:: :: ++cu:dejs:format
++ cu :: transform
|* [poq=gate wit=fist]
|= jon=json
(poq (wit jon))
:: :: ++di:dejs:format
++ di :: millisecond date
%+ cu
|= a=@u ^- @da
(add ~1970.1.1 (div (mul ~s1 a) 1.000))
ni
:: :: ++mu:dejs:format
++ mu :: true unit
|* wit=fist
|= jon=json
?~(jon ~ (some (wit jon)))
:: :: ++ne:dejs:format
++ ne :: number as real
|= jon=json
^- @rd
?> ?=([%n *] jon)
(rash p.jon (cook ryld (cook royl-cell:^so json-rn)))
:: :: ++ni:dejs:format
++ ni :: number as integer
|= jon=json
?> ?=([%n *] jon)
(rash p.jon dem)
:: :: ++no:dejs:format
++ no :: number as cord
|=(jon=json ?>(?=([%n *] jon) p.jon))
:: :: ++of:dejs:format
++ of :: object as frond
|* wer=(pole [cord fist])
|= jon=json
?> ?=([%o [@ *] ~ ~] jon)
|-
?- wer :: mint-vain on empty
:: [[key=@t wit=*] t=*]
[[key=@t *] t=*]
=> .(wer [[* wit] *]=wer)
?: =(key.wer p.n.p.jon)
[key.wer ~|(key+key.wer (wit.wer q.n.p.jon))]
?~ t.wer ~|(bad-key+p.n.p.jon !!)
((of t.wer) jon)
==
:: :: ++ot:dejs:format
++ ot :: object as tuple
|* wer=(pole [cord fist])
|= jon=json
?> ?=([%o *] jon)
((ot-raw wer) p.jon)
:: :: ++ot-raw:dejs:format
++ ot-raw :: object as tuple
|* wer=(pole [cord fist])
|= jom=(map @t json)
?- wer :: mint-vain on empty
:: [[key=@t wit=*] t=*]
[[key=@t *] t=*]
=> .(wer [[* wit] *]=wer)
=/ ten ~|(key+key.wer (wit.wer (~(got by jom) key.wer)))
?~(t.wer ten [ten ((ot-raw t.wer) jom)])
==
::
++ ou :: object of units
|* wer=(pole [cord fist])
|= jon=json
?> ?=([%o *] jon)
((ou-raw wer) p.jon)
:: :: ++ou-raw:dejs:format
++ ou-raw :: object of units
|* wer=(pole [cord fist])
|= jom=(map @t json)
?- wer :: mint-vain on empty
:: [[key=@t wit=*] t=*]
[[key=@t *] t=*]
=> .(wer [[* wit] *]=wer)
=/ ten ~|(key+key.wer (wit.wer (~(get by jom) key.wer)))
?~(t.wer ten [ten ((ou-raw t.wer) jom)])
==
:: :: ++om:dejs:format
++ om :: object as map
|* wit=fist
|= jon=json
?> ?=([%o *] jon)
(~(run by p.jon) wit)
:: :: ++op:dejs:format
++ op :: parse keys of map
|* [fel=rule wit=fist]
|= jon=json ^- (map _(wonk *fel) _*wit)
=/ jom ((om wit) jon)
%- malt
%+ turn ~(tap by jom)
|* [a=cord b=*]
=> .(+< [a b]=+<)
[(rash a fel) b]
:: :: ++pa:dejs:format
++ pa :: string as path
(su ;~(pfix fas (more fas urs:ab)))
:: :: ++pe:dejs:format
++ pe :: prefix
|* [pre=* wit=fist]
(cu |*(* [pre +<]) wit)
:: :: ++sa:dejs:format
++ sa :: string as tape
|=(jon=json ?>(?=([%s *] jon) (trip p.jon)))
:: :: ++se:dejs:format
++ se :: string as aura
|= aur=@tas
|= jon=json
?>(?=([%s *] jon) (slav aur p.jon))
:: :: ++so:dejs:format
++ so :: string as cord
|=(jon=json ?>(?=([%s *] jon) p.jon))
:: :: ++su:dejs:format
++ su :: parse string
|* sab=rule
|= jon=json ^+ (wonk *sab)
?> ?=([%s *] jon)
(rash p.jon sab)
:: :: ++uf:dejs:format
++ uf :: unit fall
|* [def=* wit=fist]
|= jon=(unit json)
?~(jon def (wit u.jon))
:: :: ++un:dejs:format
++ un :: unit need
|* wit=fist
|= jon=(unit json)
(wit (need jon))
:: :: ++ul:dejs:format
++ ul :: null
|=(jon=json ?~(jon ~ !!))
::
++ za :: full unit pole
|* pod=(pole (unit))
?~ pod &
?~ -.pod |
(za +.pod)
::
++ zl :: collapse unit list
|* lut=(list (unit))
?. |- ^- ?
?~(lut & ?~(i.lut | $(lut t.lut)))
~
%- some
|-
?~ lut ~
[i=u:+.i.lut t=$(lut t.lut)]
::
++ zp :: unit tuple
|* but=(pole (unit))
?~ but !!
?~ +.but
u:->.but
[u:->.but (zp +.but)]
::
++ zm :: collapse unit map
|* lum=(map term (unit))
?: (~(rep by lum) |=([[@ a=(unit)] b=_|] |(b ?=(~ a))))
~
(some (~(run by lum) need))
-- ::dejs
:: :: ++dejs-soft:format
++ dejs-soft :: json reparse to unit
=, unity
=> |% ++ grub (unit *) :: result
++ fist $-(json grub) :: reparser instance
-- ::
::
:: XX: this is old code that replaced a rewritten dejs.
:: the rewritten dejs rest-looped with ++redo. the old
:: code is still in revision control -- revise and replace.
::
|%
++ ar :: array as list
|* wit=fist
|= jon=json
?. ?=([%a *] jon) ~
%- zl
|-
?~ p.jon ~
[i=(wit i.p.jon) t=$(p.jon t.p.jon)]
::
++ at :: array as tuple
|* wil=(pole fist)
|= jon=json
?. ?=([%a *] jon) ~
?. =((lent wil) (lent p.jon)) ~
=+ raw=((at-raw wil) p.jon)
?.((za raw) ~ (some (zp raw)))
::
++ at-raw :: array as tuple
|* wil=(pole fist)
|= jol=(list json)
?~ wil ~
:- ?~(jol ~ (-.wil i.jol))
((at-raw +.wil) ?~(jol ~ t.jol))
::
++ bo :: boolean
|=(jon=json ?.(?=([%b *] jon) ~ [~ u=p.jon]))
::
++ bu :: boolean not
|=(jon=json ?.(?=([%b *] jon) ~ [~ u=!p.jon]))
::
++ ci :: maybe transform
|* [poq=gate wit=fist]
|= jon=json
(biff (wit jon) poq)
::
++ cu :: transform
|* [poq=gate wit=fist]
|= jon=json
(bind (wit jon) poq)
::
++ da :: UTC date
|= jon=json
?. ?=([%s *] jon) ~
(bind (stud:chrono:userlib p.jon) |=(a=date (year a)))
::
++ di :: millisecond date
%+ cu
|= a=@u ^- @da
(add ~1970.1.1 (div (mul ~s1 a) 1.000))
ni
::
++ mu :: true unit
|* wit=fist
|= jon=json
?~(jon (some ~) (bind (wit jon) some))
::
++ ne :: number as real
|= jon=json
^- (unit @rd)
?. ?=([%n *] jon) ~
(rush p.jon (cook ryld (cook royl-cell:^so json-rn)))
::
++ ni :: number as integer
|= jon=json
?. ?=([%n *] jon) ~
(rush p.jon dem)
::
++ no :: number as cord
|= jon=json
?. ?=([%n *] jon) ~
(some p.jon)
::
++ of :: object as frond
|* wer=(pole [cord fist])
|= jon=json
?. ?=([%o [@ *] ~ ~] jon) ~
|-
?~ wer ~
?: =(-.-.wer p.n.p.jon)
((pe -.-.wer +.-.wer) q.n.p.jon)
((of +.wer) jon)
::
++ ot :: object as tuple
|* wer=(pole [cord fist])
|= jon=json
?. ?=([%o *] jon) ~
=+ raw=((ot-raw wer) p.jon)
?.((za raw) ~ (some (zp raw)))
::
++ ot-raw :: object as tuple
|* wer=(pole [cord fist])
|= jom=(map @t json)
?~ wer ~
=+ ten=(~(get by jom) -.-.wer)
[?~(ten ~ (+.-.wer u.ten)) ((ot-raw +.wer) jom)]
::
++ om :: object as map
|* wit=fist
|= jon=json
?. ?=([%o *] jon) ~
(zm (~(run by p.jon) wit))
::
++ op :: parse keys of map
|* [fel=rule wit=fist]
%+ cu
|= a=(list (pair _(wonk *fel) _(need *wit)))
(my:nl a)
%- ci :_ (om wit)
|= a=(map cord _(need *wit))
^- (unit (list _[(wonk *fel) (need *wit)]))
%- zl
%+ turn ~(tap by a)
|= [a=cord b=_(need *wit)]
=+ nit=(rush a fel)
?~ nit ~
(some [u.nit b])
::
++ pe :: prefix
|* [pre=* wit=fist]
(cu |*(* [pre +<]) wit)
::
++ sa :: string as tape
|= jon=json
?.(?=([%s *] jon) ~ (some (trip p.jon)))
::
++ so :: string as cord
|= jon=json
?.(?=([%s *] jon) ~ (some p.jon))
::
++ su :: parse string
|* sab=rule
|= jon=json
?. ?=([%s *] jon) ~
(rush p.jon sab)
::
++ ul |=(jon=json ?~(jon (some ~) ~)) :: null
++ za :: full unit pole
|* pod=(pole (unit))
?~ pod &
?~ -.pod |
(za +.pod)
::
++ zl :: collapse unit list
|* lut=(list (unit))
?. |- ^- ?
?~(lut & ?~(i.lut | $(lut t.lut)))
~
%- some
|-
?~ lut ~
[i=u:+.i.lut t=$(lut t.lut)]
::
++ zp :: unit tuple
|* but=(pole (unit))
?~ but !!
?~ +.but
u:->.but
[u:->.but (zp +.but)]
::
++ zm :: collapse unit map
|* lum=(map term (unit))
?: (~(rep by lum) |=([[@ a=(unit)] b=_|] |(b ?=(~ a))))
~
(some (~(run by lum) need))
-- ::dejs-soft
--
:: ::
:::: ++differ :: (2d) hunt-mcilroy
:: ::::
++ differ ^?
=, clay
=, format
|%
:: :: ++berk:differ
++ berk :: invert diff patch
|* bur=(urge)
|- ^+ bur
?~ bur ~
:_ $(bur t.bur)
?- -.i.bur
%& i.bur
%| [%| q.i.bur p.i.bur]
==
:: :: ++loss:differ
++ loss :: longest subsequence
~% %loss ..part ~
|* [hel=(list) hev=(list)]
|- ^+ hev
=+ ^= sev
=+ [inx=0 sev=*(map _i.-.hev (list @ud))]
|- ^+ sev
?~ hev sev
=+ guy=(~(get by sev) i.hev)
%= $
hev t.hev
inx +(inx)
sev (~(put by sev) i.hev [inx ?~(guy ~ u.guy)])
==
=| gox=[p=@ud q=(map @ud [p=@ud q=_hev])]
=< abet
=< main
|%
:: :: ++abet:loss:differ
++ abet :: subsequence
^+ hev
?: =(0 p.gox) ~
(flop q:(need (~(get by q.gox) (dec p.gox))))
:: :: ++hink:loss:differ
++ hink :: extend fits top
|= [inx=@ud goy=@ud] ^- ?
?| =(p.gox inx)
(lth goy p:(need (~(get by q.gox) inx)))
==
:: :: ++lonk:loss:differ
++ lonk :: extend fits bottom
|= [inx=@ud goy=@ud] ^- ?
?| =(0 inx)
(gth goy p:(need (~(get by q.gox) (dec inx))))
==
:: :: ++luna:loss:differ
++ luna :: extend
|= [inx=@ud goy=@ud]
^+ +>
%_ +>.$
gox
:- ?:(=(inx p.gox) +(p.gox) p.gox)
%+ ~(put by q.gox) inx
:+ goy
(snag goy hev)
?:(=(0 inx) ~ q:(need (~(get by q.gox) (dec inx))))
==
:: :: ++merg:loss:differ
++ merg :: merge all matches
|= gay=(list @ud)
^+ +>
=+ ^= zes
=+ [inx=0 zes=*(list [p=@ud q=@ud])]
|- ^+ zes
?: |(?=(~ gay) (gth inx p.gox)) zes
?. (lonk inx i.gay) $(gay t.gay)
?. (hink inx i.gay) $(inx +(inx))
$(inx +(inx), gay t.gay, zes [[inx i.gay] zes])
|- ^+ +>.^$
?~(zes +>.^$ $(zes t.zes, +>.^$ (luna i.zes)))
:: :: ++main:loss:differ
++ main ::
=+ hol=hel
|- ^+ +>
?~ hol +>
=+ guy=(~(get by sev) i.hol)
$(hol t.hol, +> (merg (flop `(list @ud)`?~(guy ~ u.guy))))
-- ::
:: :: ++lurk:differ
++ lurk :: apply list patch
|* [hel=(list) rug=(urge)]
^+ hel
=+ war=`_hel`~
|- ^+ hel
?~ rug (flop war)
?- -.i.rug
%&
%= $
rug t.rug
hel (slag p.i.rug hel)
war (weld (flop (scag p.i.rug hel)) war)
==
::
%|
%= $
rug t.rug
hel =+ gur=(flop p.i.rug)
|- ^+ hel
?~ gur hel
?>(&(?=(^ hel) =(i.gur i.hel)) $(hel t.hel, gur t.gur))
war (weld q.i.rug war)
==
==
:: :: ++lusk:differ
++ lusk :: lcs to list patch
|* [hel=(list) hev=(list) lcs=(list)]
=+ ^= rag
^- [$%([%& p=@ud] [%| p=_lcs q=_lcs])]
[%& 0]
=> .(rag [p=rag q=*(list _rag)])
=< abet =< main
|%
:: :: ++abet:lusk:differ
++ abet ::
=? q.rag !=([& 0] p.rag) [p.rag q.rag]
(flop q.rag)
:: :: ++done:lusk:differ
++ done ::
|= new=_p.rag
^+ rag
?- -.p.rag
%| ?- -.new
%| [[%| (weld p.new p.p.rag) (weld q.new q.p.rag)] q.rag]
%& [new [p.rag q.rag]]
==
%& ?- -.new
%| [new ?:(=(0 p.p.rag) q.rag [p.rag q.rag])]
%& [[%& (add p.p.rag p.new)] q.rag]
==
==
:: :: ++main:lusk:differ
++ main ::
|- ^+ +
?~ hel
?~ hev
?>(?=(~ lcs) +)
$(hev t.hev, rag (done %| ~ [i.hev ~]))
?~ hev
$(hel t.hel, rag (done %| [i.hel ~] ~))
?~ lcs
+(rag (done %| (flop hel) (flop hev)))
?: =(i.hel i.lcs)
?: =(i.hev i.lcs)
$(lcs t.lcs, hel t.hel, hev t.hev, rag (done %& 1))
$(hev t.hev, rag (done %| ~ [i.hev ~]))
?: =(i.hev i.lcs)
$(hel t.hel, rag (done %| [i.hel ~] ~))
$(hel t.hel, hev t.hev, rag (done %| [i.hel ~] [i.hev ~]))
-- ::
-- ::differ
:: ::
:::: ++html :: (2e) text encodings
:: ::::
++ html ^? :: XX rename to web-txt
=, eyre
|%
:: ::
:::: ++mimes:html :: (2e1) MIME
:: ::::
++ mimes ^?
~% %mimes ..part ~
|%
:: :: ++as-octs:mimes:html
++ as-octs :: atom to octstream
|= tam=@ ^- octs
[(met 3 tam) tam]
:: :: ++as-octt:mimes:html
++ as-octt :: tape to octstream
|= tep=tape ^- octs
(as-octs (rap 3 tep))
:: :: ++en-mite:mimes:html
++ en-mite :: mime type to text
|= myn=mite
%- crip
|- ^- tape
?~ myn ~
?: =(~ t.myn) (trip i.myn)
(weld (trip i.myn) `tape`['/' $(myn t.myn)])
::
:: |base16: en/decode arbitrary MSB-first hex strings
::
++ base16
~% %base16 + ~
|%
++ en
~/ %en
|= a=octs ^- cord
(crip ((x-co:co (mul p.a 2)) (end [3 p.a] q.a)))
::
++ de
~/ %de
|= a=cord ^- (unit octs)
(rush a rule)
::
++ rule
%+ cook
|= a=(list @) ^- octs
[(add (dvr (lent a) 2)) (rep [0 4] (flop a))]
(star hit)
--
:: :: ++en-base64:mimes:
++ en-base64 :: encode base64
|= tig=@
^- tape
=+ poc=(~(dif fo 3) 0 (met 3 tig))
=+ pad=(lsh [3 poc] (swp 3 tig))
=+ ^= cha
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'
=+ ^= sif
|- ^- tape
?~ pad
~
=+ d=(end [0 6] pad)
[(cut 3 [d 1] cha) $(pad (rsh [0 6] pad))]
(weld (flop (slag poc sif)) (reap poc '='))
:: :: ++de-base64:mimes:
++ de-base64 :: decode base64
=- |=(a=cord (rash a fel))
=< fel=(cook |~(a=@ `@t`(swp 3 a)) (bass 64 .))
=- (cook welp ;~(plug (plus siw) (stun 0^2 (cold %0 tis))))
^= siw
;~ pose
(cook |=(a=@ (sub a 'A')) (shim 'A' 'Z'))
(cook |=(a=@ (sub a 'G')) (shim 'a' 'z'))
(cook |=(a=@ (add a 4)) (shim '0' '9'))
(cold 62 (just '+'))
(cold 63 (just '/'))
==
::
++ en-base58
|= dat=@
=/ cha
'123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz'
%- flop
|- ^- tape
?: =(0 dat) ~
:- (cut 3 [(mod dat 58) 1] cha)
$(dat (div dat 58))
::
++ de-base58
|= t=tape
=- (scan t (bass 58 (plus -)))
;~ pose
(cook |=(a=@ (sub a 56)) (shim 'A' 'H'))
(cook |=(a=@ (sub a 57)) (shim 'J' 'N'))
(cook |=(a=@ (sub a 58)) (shim 'P' 'Z'))
(cook |=(a=@ (sub a 64)) (shim 'a' 'k'))
(cook |=(a=@ (sub a 65)) (shim 'm' 'z'))
(cook |=(a=@ (sub a 49)) (shim '1' '9'))
==
-- ::mimes
:: :: ++en-json:html
++ en-json :: print json
|^ |=(val=json (apex val ""))
:: :: ++apex:en-json:html
++ apex
|= [val=json rez=tape]
^- tape
?~ val (weld "null" rez)
?- -.val
%a
:- '['
=. rez [']' rez]
!.
?~ p.val rez
|-
?~ t.p.val ^$(val i.p.val)
^$(val i.p.val, rez [',' $(p.val t.p.val)])
::
%b (weld ?:(p.val "true" "false") rez)
%n (weld (trip p.val) rez)
%s
:- '"'
=. rez ['"' rez]
=+ viz=(trip p.val)
!.
|- ^- tape
?~ viz rez
=+ hed=(jesc i.viz)
?: ?=([@ ~] hed)
[i.hed $(viz t.viz)]
(weld hed $(viz t.viz))
::
%o
:- '{'
=. rez ['}' rez]
=+ viz=~(tap by p.val)
?~ viz rez
!.
|- ^+ rez
?~ t.viz ^$(val [%s p.i.viz], rez [':' ^$(val q.i.viz)])
=. rez [',' $(viz t.viz)]
^$(val [%s p.i.viz], rez [':' ^$(val q.i.viz)])
==
:: :: ++jesc:en-json:html
++ jesc :: escaped
=+ utf=|=(a=@ ['\\' 'u' ((x-co 4):co a)])
|= a=@ ^- tape
?+ a ?:((gth a 0x1f) [a ~] (utf a))
%10 "\\n"
%34 "\\\""
%92 "\\\\"
==
-- ::en-json
:: :: ++de-json:html
++ de-json :: parse JSON
=< |=(a=cord `(unit json)`(rush a apex))
|%
:: :: ++abox:de-json:html
++ abox :: array
%+ stag %a
(ifix [sel (wish ser)] (more (wish com) apex))
:: :: ++apex:de-json:html
++ apex :: any value
%+ knee *json |. ~+
%+ ifix [spac spac]
;~ pose
(cold ~ (jest 'null'))
(stag %b bool)
(stag %s stri)
(cook |=(s=tape [%n p=(rap 3 s)]) numb)
abox
obox
==
:: :: ++bool:de-json:html
++ bool :: boolean
;~ pose
(cold & (jest 'true'))
(cold | (jest 'false'))
==
:: :: ++digs:de-json:html
++ digs :: digits
(star (shim '0' '9'))
:: :: ++esca:de-json:html
++ esca :: escaped character
;~ pfix bas
=* loo
=* lip
^- (list (pair @t @))
[b+8 t+9 n+10 f+12 r+13 ~]
=* wow `(map @t @)`(malt lip)
(sear ~(get by wow) low)
=* tuf ;~(pfix (just 'u') (cook tuft qix:ab))
;~(pose doq fas soq bas loo tuf)
==
:: :: ++expo:de-json:html
++ expo :: exponent
;~ (comp twel)
(piec (mask "eE"))
(mayb (piec (mask "+-")))
digs
==
:: :: ++frac:de-json:html
++ frac :: fraction
;~(plug dot digs)
:: :: ++jcha:de-json:html
++ jcha :: string character
;~(pose ;~(less doq bas prn) esca)
:: :: ++mayb:de-json:html
++ mayb :: optional
|*(bus=rule ;~(pose bus (easy ~)))
:: :: ++numb:de-json:html
++ numb :: number
;~ (comp twel)
(mayb (piec hep))
;~ pose
(piec (just '0'))
;~(plug (shim '1' '9') digs)
==
(mayb frac)
(mayb expo)
==
:: :: ++obje:de-json:html
++ obje :: object list
%+ ifix [(wish kel) (wish ker)]
(more (wish com) pear)
:: :: ++obox:de-json:html
++ obox :: object
(stag %o (cook malt obje))
:: :: ++pear:de-json:html
++ pear :: key-value
;~(plug ;~(sfix (wish stri) (wish col)) apex)
:: :: ++piec:de-json:html
++ piec :: listify
|* bus=rule
(cook |=(a=@ [a ~]) bus)
:: :: ++stri:de-json:html
++ stri :: string
(cook crip (ifix [doq doq] (star jcha)))
:: :: ++tops:de-json:html
++ tops :: strict value
;~(pose abox obox)
:: :: ++spac:de-json:html
++ spac :: whitespace
(star (mask [`@`9 `@`10 `@`13 ' ' ~]))
:: :: ++twel:de-json:html
++ twel :: tape weld
|=([a=tape b=tape] (weld a b))
:: :: ++wish:de-json:html
++ wish :: with whitespace
|*(sef=rule ;~(pfix spac sef))
-- ::de-json
:: :: ++en-xml:html
++ en-xml :: xml printer
=< |=(a=manx `tape`(apex a ~))
|_ _[unq=`?`| cot=`?`|]
:: :: ++apex:en-xml:html
++ apex :: top level
|= [mex=manx rez=tape]
^- tape
?: ?=([%$ [[%$ *] ~]] g.mex)
(escp v.i.a.g.mex rez)
=+ man=`mane`n.g.mex
=. unq |(unq =(%script man) =(%style man))
=+ tam=(name man)
=+ att=`mart`a.g.mex
:- '<'
%+ welp tam
=- ?~(att rez [' ' (attr att rez)])
^- rez=tape
?: &(?=(~ c.mex) |(cot ?^(man | (clot man))))
[' ' '/' '>' rez]
:- '>'
(many c.mex :(weld "</" tam ">" rez))
:: :: ++attr:en-xml:html
++ attr :: attributes to tape
|= [tat=mart rez=tape]
^- tape
?~ tat rez
=. rez $(tat t.tat)
;: weld
(name n.i.tat)
"=\""
(escp(unq |) v.i.tat '"' ?~(t.tat rez [' ' rez]))
==
:: :: ++escp:en-xml:html
++ escp :: escape for xml
|= [tex=tape rez=tape]
?: unq
(weld tex rez)
=+ xet=`tape`(flop tex)
!.
|- ^- tape
?~ xet rez
%= $
xet t.xet
rez ?- i.xet
%34 ['&' 'q' 'u' 'o' 't' ';' rez]
%38 ['&' 'a' 'm' 'p' ';' rez]
%39 ['&' '#' '3' '9' ';' rez]
%60 ['&' 'l' 't' ';' rez]
%62 ['&' 'g' 't' ';' rez]
* [i.xet rez]
==
==
:: :: ++many:en-xml:html
++ many :: nodelist to tape
|= [lix=(list manx) rez=tape]
|- ^- tape
?~ lix rez
(apex i.lix $(lix t.lix))
:: :: ++name:en-xml:html
++ name :: name to tape
|= man=mane ^- tape
?@ man (trip man)
(weld (trip -.man) `tape`[':' (trip +.man)])
:: :: ++clot:en-xml:html
++ clot ~+ :: self-closing tags
%~ has in
%- silt ^- (list term) :~
%area %base %br %col %command %embed %hr %img %inputt
%keygen %link %meta %param %source %track %wbr
==
-- ::en-xml
:: :: ++de-xml:html
++ de-xml :: xml parser
=< |=(a=cord (rush a apex))
|_ ent=_`(map term @t)`[[%apos '\''] ~ ~]
:: :: ++apex:de-xml:html
++ apex :: top level
=+ spa=;~(pose comt whit)
%+ knee *manx |. ~+
%+ ifix
[;~(plug (punt decl) (star spa)) (star spa)]
;~ pose
%+ sear |=([a=marx b=marl c=mane] ?.(=(c n.a) ~ (some [a b])))
;~(plug head many tail)
empt
==
:: :: ++attr:de-xml:html
++ attr :: attributes
%+ knee *mart |. ~+
%- star
;~ plug
;~(pfix (plus whit) name)
;~ pose
%+ ifix
:_ doq
;~(plug (ifix [. .]:(star whit) tis) doq)
(star ;~(less doq escp))
::
%+ ifix
:_ soq
;~(plug (ifix [. .]:(star whit) tis) soq)
(star ;~(less soq escp))
::
(easy ~)
==
==
:: :: ++cdat:de-xml:html
++ cdat :: CDATA section
%+ cook
|=(a=tape ^-(mars ;/(a)))
%+ ifix
[(jest '<![CDATA[') (jest ']]>')]
%- star
;~(less (jest ']]>') next)
:: :: ++chrd:de-xml:html
++ chrd :: character data
%+ cook |=(a=tape ^-(mars ;/(a)))
(plus ;~(less doq ;~(pose (just `@`10) escp)))
:: :: ++comt:de-xml:html
++ comt :: comments
=- (ifix [(jest '<!--') (jest '-->')] (star -))
;~ pose
;~(less hep prn)
whit
;~(less (jest '-->') hep)
==
::
++ decl :: ++decl:de-xml:html
%+ ifix :: XML declaration
[(jest '<?xml') (jest '?>')]
%- star
;~(less (jest '?>') prn)
:: :: ++escp:de-xml:html
++ escp ::
;~(pose ;~(less gal gar pam prn) enty)
:: :: ++enty:de-xml:html
++ enty :: entity
%+ ifix pam^mic
;~ pose
=+ def=^+(ent (my:nl [%gt '>'] [%lt '<'] [%amp '&'] [%quot '"'] ~))
%+ sear ~(get by (~(uni by def) ent))
(cook crip ;~(plug alf (stun 1^31 aln)))
%+ cook |=(a=@c ?:((gth a 0x10.ffff) '<27>' (tuft a)))
=< ;~(pfix hax ;~(pose - +))
:- (bass 10 (stun 1^8 dit))
(bass 16 ;~(pfix (mask "xX") (stun 1^8 hit)))
==
:: :: ++empt:de-xml:html
++ empt :: self-closing tag
%+ ifix [gal (jest '/>')]
;~(plug ;~(plug name attr) (cold ~ (star whit)))
:: :: ++head:de-xml:html
++ head :: opening tag
(ifix [gal gar] ;~(plug name attr))
:: :: ++many:de-xml:html
++ many :: contents
;~(pfix (star comt) (star ;~(sfix ;~(pose apex chrd cdat) (star comt))))
:: :: ++name:de-xml:html
++ name :: tag name
=+ ^= chx
%+ cook crip
;~ plug
;~(pose cab alf)
(star ;~(pose cab dot alp))
==
;~(pose ;~(plug ;~(sfix chx col) chx) chx)
:: :: ++tail:de-xml:html
++ tail :: closing tag
(ifix [(jest '</') gar] name)
:: :: ++whit:de-xml:html
++ whit :: whitespace
(mask ~[' ' `@`0x9 `@`0xa])
-- ::de-xml
:: :: ++en-urlt:html
++ en-urlt :: url encode
|= tep=tape
^- tape
%- zing
%+ turn tep
|= tap=char
=+ xen=|=(tig=@ ?:((gte tig 10) (add tig 55) (add tig '0')))
?: ?| &((gte tap 'a') (lte tap 'z'))
&((gte tap 'A') (lte tap 'Z'))
&((gte tap '0') (lte tap '9'))
=('.' tap)
=('-' tap)
=('~' tap)
=('_' tap)
==
[tap ~]
['%' (xen (rsh [0 4] tap)) (xen (end [0 4] tap)) ~]
:: :: ++de-urlt:html
++ de-urlt :: url decode
|= tep=tape
^- (unit tape)
?~ tep [~ ~]
?: =('%' i.tep)
?. ?=([@ @ *] t.tep) ~
=+ nag=(mix i.t.tep (lsh 3 i.t.t.tep))
=+ val=(rush nag hex:ag)
?~ val ~
=+ nex=$(tep t.t.t.tep)
?~(nex ~ [~ [`@`u.val u.nex]])
=+ nex=$(tep t.tep)
?~(nex ~ [~ i.tep u.nex])
:: :: ++en-purl:html
++ en-purl :: print purl
=< |=(pul=purl `tape`(apex %& pul))
|%
:: :: ++apex:en-purl:html
++ apex ::
|= qur=quri ^- tape
?- -.qur
%& (weld (head p.p.qur) `tape`$(qur [%| +.p.qur]))
%| ['/' (weld (body p.qur) (tail q.qur))]
==
:: :: ++apix:en-purl:html
++ apix :: purf to tape
|= purf
(weld (apex %& p) ?~(q "" `tape`['#' (trip u.q)]))
:: :: ++body:en-purl:html
++ body ::
|= pok=pork ^- tape
?~ q.pok ~
|-
=+ seg=(en-urlt (trip i.q.pok))
?~ t.q.pok
?~(p.pok seg (welp seg '.' (trip u.p.pok)))
(welp seg '/' $(q.pok t.q.pok))
:: :: ++head:en-purl:html
++ head ::
|= har=hart
^- tape
;: weld
?:(&(p.har !?=(hoke r.har)) "https://" "http://")
::
?- -.r.har
%| (trip (rsh 3 (scot %if p.r.har)))
%& =+ rit=(flop p.r.har)
|- ^- tape
?~ rit ~
(weld (trip i.rit) ?~(t.rit "" `tape`['.' $(rit t.rit)]))
==
::
?~(q.har ~ `tape`[':' ((d-co:co 1) u.q.har)])
==
:: :: ++tail:en-purl:html
++ tail ::
|= kay=quay
^- tape
?: =(~ kay) ~
:- '?'
|- ^- tape
?~ kay ~
;: welp
(en-urlt (trip p.i.kay))
?~(q.i.kay ~ ['=' (en-urlt (trip q.i.kay))])
?~(t.kay ~ `tape`['&' $(kay t.kay)])
==
-- ::
:: :: ++de-purl:html
++ de-purl :: url+header parser
=< |=(a=cord `(unit purl)`(rush a auri))
|%
:: :: ++deft:de-purl:html
++ deft :: parse url extension
|= rax=(list @t)
|- ^- pork
?~ rax
[~ ~]
?^ t.rax
[p.pok [ire q.pok]]:[pok=$(rax t.rax) ire=i.rax]
=/ raf=(like term)
%- ;~ sfix
%+ sear
|=(a=@ ((sand %ta) (crip (flop (trip a)))))
(cook |=(a=tape (rap 3 ^-((list @) a))) (star aln))
dot
==
[1^1 (flop (trip i.rax))]
?~ q.raf
[~ [i.rax ~]]
=+ `[ext=term [@ @] fyl=tape]`u.q.raf
:- `ext
?:(=(~ fyl) ~ [(crip (flop fyl)) ~])
:: :: ++apat:de-purl:html
++ apat :: 2396 abs_path
%+ cook deft
;~(pfix fas (more fas smeg))
:: :: ++aurf:de-purl:html
++ aurf :: 2396 with fragment
%+ cook |~(a=purf a)
;~(plug auri (punt ;~(pfix hax (cook crip (star pque)))))
:: :: ++auri:de-purl:html
++ auri :: 2396 URL
;~ plug
;~(plug htts thor)
;~(plug ;~(pose apat (easy *pork)) yque)
==
:: :: ++auru:de-purl:html
++ auru :: 2396 with maybe user
%+ cook
|= $: a=[p=? q=(unit user) r=[(unit @ud) host]]
b=[pork quay]
==
^- (pair (unit user) purl)
[q.a [[p.a r.a] b]]
::
;~ plug
;~(plug htts (punt ;~(sfix urt:ab pat)) thor)
;~(plug ;~(pose apat (easy *pork)) yque)
==
:: :: ++htts:de-purl:html
++ htts :: scheme
%+ sear ~(get by (malt `(list (pair term ?))`[http+| https+& ~]))
;~(sfix scem ;~(plug col fas fas))
:: :: ++cock:de-purl:html
++ cock :: cookie
%+ most ;~(plug mic ace)
;~(plug toke ;~(pfix tis tosk))
:: :: ++dlab:de-purl:html
++ dlab :: 2396 domainlabel
%+ sear
|= a=@ta
?.(=('-' (rsh [3 (dec (met 3 a))] a)) [~ u=a] ~)
%+ cook |=(a=tape (crip (cass a)))
;~(plug aln (star alp))
:: :: ++fque:de-purl:html
++ fque :: normal query field
(cook crip (plus pquo))
:: :: ++fquu:de-purl:html
++ fquu :: optional query field
(cook crip (star pquo))
:: :: ++pcar:de-purl:html
++ pcar :: 2396 path char
;~(pose pure pesc psub col pat)
:: :: ++pcok:de-purl:html
++ pcok :: cookie char
;~(less bas mic com doq prn)
:: :: ++pesc:de-purl:html
++ pesc :: 2396 escaped
;~(pfix cen mes)
:: :: ++pold:de-purl:html
++ pold ::
(cold ' ' (just '+'))
:: :: ++pque:de-purl:html
++ pque :: 3986 query char
;~(pose pcar fas wut)
:: :: ++pquo:de-purl:html
++ pquo :: normal query char
;~(pose pure pesc pold fas wut col com)
:: :: ++pure:de-purl:html
++ pure :: 2396 unreserved
;~(pose aln hep cab dot zap sig tar soq pal par)
:: :: ++psub:de-purl:html
++ psub :: 3986 sub-delims
;~ pose
zap buc pam soq pal par
tar lus com mic tis
==
:: :: ++ptok:de-purl:html
++ ptok :: 2616 token
;~ pose
aln zap hax buc cen pam soq tar lus
hep dot ket cab tic bar sig
==
:: :: ++scem:de-purl:html
++ scem :: 2396 scheme
%+ cook |=(a=tape (crip (cass a)))
;~(plug alf (star ;~(pose aln lus hep dot)))
:: :: ++smeg:de-purl:html
++ smeg :: 2396 segment
(cook crip (star pcar))
:: :: ++tock:de-purl:html
++ tock :: 6265 raw value
(cook crip (plus pcok))
:: :: ++tosk:de-purl:html
++ tosk :: 6265 quoted value
;~(pose tock (ifix [doq doq] tock))
:: :: ++toke:de-purl:html
++ toke :: 2616 token
(cook crip (plus ptok))
:: :: ++thor:de-purl:html
++ thor :: 2396 host+port
%+ cook |*([* *] [+<+ +<-])
;~ plug
thos
;~((bend) (easy ~) ;~(pfix col dim:ag))
==
:: :: ++thos:de-purl:html
++ thos :: 2396 host, no local
;~ plug
;~ pose
%+ stag %&
%+ sear :: LL parser weak here
|= a=(list @t)
=+ b=(flop a)
?> ?=(^ b)
=+ c=(end 3 i.b)
?.(&((gte c 'a') (lte c 'z')) ~ [~ u=b])
(most dot dlab)
::
%+ stag %|
=+ tod=(ape:ag ted:ab)
%+ bass 256
;~(plug tod (stun [3 3] ;~(pfix dot tod)))
==
==
:: :: ++yque:de-purl:html
++ yque :: query ending
;~ pose
;~(pfix wut yquy)
(easy ~)
==
:: :: ++yquy:de-purl:html
++ yquy :: query
;~ pose
:: proper query
::
%+ more
;~(pose pam mic)
;~(plug fque ;~(pose ;~(pfix tis fquu) (easy '')))
::
:: funky query
::
%+ cook
|=(a=tape [[%$ (crip a)] ~])
(star pque)
==
:: :: ++zest:de-purl:html
++ zest :: 2616 request-uri
;~ pose
(stag %& (cook |=(a=purl a) auri))
(stag %| ;~(plug apat yque))
==
-- ::de-purl
:: +en-turf: encode +turf as a TLD-last domain string
::
++ en-turf
|= =turf
^- @t
(rap 3 (flop (join '.' turf)))
:: +de-turf: parse a TLD-last domain string into a TLD first +turf
::
++ de-turf
|= host=@t
^- (unit turf)
%+ rush host
%+ sear
|= =host:eyre
?.(?=(%& -.host) ~ (some p.host))
thos:de-purl:html
::
:: MOVEME
:: :: ++fuel:html
++ fuel :: parse urbit fcgi
|= [bem=beam ced=noun:cred quy=quer]
^- epic
=+ qix=|-(`quay`?~(quy quy [[p q]:quy $(quy t.quy)]))
[(malt qix) ;;(cred ced) bem]
::
++ hiss-to-request
|= =hiss
^- request:http
::
:* ?- p.q.hiss
%conn %'CONNECT'
%delt %'DELETE'
%get %'GET'
%head %'HEAD'
%opts %'OPTIONS'
%post %'POST'
%put %'PUT'
%trac %'TRACE'
==
::
(crip (en-purl:html p.hiss))
::
^- header-list:http
~! q.q.hiss
%+ turn ~(tap by q.q.hiss)
|= [a=@t b=(list @t)]
^- [@t @t]
?> ?=(^ b)
[a i.b]
::
r.q.hiss
==
-- :: html
:: ::
:::: ++wired :: wire formatting
:: ::::
++ wired ^?
|%
:: :: ++dray:wired
++ dray :: load tuple in path
::
:: .= ~[p=~.ack q=~.~sarnel r=~..y]
:: (dray ~[p=%tas q=%p r=%f] %ack ~sarnel &)
::
=- |* [a=[@tas (pole @tas)] b=*] ^- (paf a)
=> .(b `,(tup -.a +.a)`b)
?~ +.a [(scot -.a b) ~]
[(scot -.a -.b) `,(paf +.a)`(..$ +.a +.b)]
:- paf=|*(a=(pole) ?~(a ,~ ,[(odo:raid ,-.a(. %ta)) ,(..$ +.a)]))
^= tup
|* [a=@tas b=(pole @tas)]
=+ c=(odo:raid a)
?~(b c ,[c (..$ ,-.b ,+.b)])
:: :: ++raid:wired
++ raid :: demand path odors
::
:: .= [p=%ack q=~sarnel r=&]
:: (raid /ack/~sarnel+.y p=%tas q=%p r=%f ~)
::
=- |* [a=path b=[@tas (pole @tas)]]
=* fog (odo -.b)
?~ +.b `fog`(slav -.b -.a)
[`fog`(slav -.b -.a) (..$ +.a +.b)]
^= odo
|* a=@tas
|= b=*
=- a(, (- b)) :: preserve face
?+ a @
%c @c %da @da %dr @dr %f @f %if @if %is @is %p @p
%u @u %uc @uc %ub @ub %ui @ui %ux @ux %uv @uv %uw @uw
%s @s %t @t %ta @ta %tas @tas
==
:: :: :: ++read:wired
:: ++ read :: parse odored path
:: =< |*([a=path b=[@tas (pole @tas)]] ((+> b) a))
:: |* b=[@tas (pole @tas)]
:: |= a=path
:: ?~ a ~
:: =+ hed=(slaw -.b i.a)
:: =* fog (odo:raid -.b)
:: ?~ +.b
:: ^- (unit fog)
:: ?^(+.a ~ hed)
:: ^- (unit [fog _(need *(..^$ +.b))])
:: (both hed ((..^$ +.b) +.a))
-- ::wired
:: ::
:::: ++title :: (2j) namespace
:: ::::
++ title
=> |%
:: :: ++clan:title
++ clan :: ship to rank
|= who=ship
^- rank
=/ wid (met 3 who)
?: (lte wid 1) %czar
?: =(2 wid) %king
?: (lte wid 4) %duke
?: (lte wid 8) %earl
?> (lte wid 16) %pawn
:: :: ++rank:title
+$ rank ?(%czar %king %duke %earl %pawn) :: ship width class
:: :: ++name:title
++ name :: identity
|= who=ship
^- ship
?. ?=(%earl (clan who)) who
(sein who)
:: :: ++saxo:title
++ saxo :: autocanon
|= who=ship
^- (list ship)
=/ dad (sein who)
[who ?:(=(who dad) ~ $(who dad))]
:: :: ++sein:title
++ sein :: autoboss
|= who=ship
^- ship
=/ mir (clan who)
?- mir
%czar who
%king (end 3 who)
%duke (end 4 who)
%earl (end 5 who)
%pawn (end 4 who)
==
--
|%
:: :: ++cite:title
++ cite :: render ship
|= who=@p
^- tape
=+ kind=(clan who)
=+ name=(scow %p who)
?: =(%earl kind)
:(weld "~" (swag [15 6] name) "^" (swag [22 6] name))
?: =(%pawn kind)
:(weld (swag [0 7] name) "_" (swag [51 6] name))
name
:: :: ++saxo:title
++ saxo :: autocanon
|= [our=ship now=@da who=ship]
.^ (list ship)
%j
/(scot %p our)/saxo/(scot %da now)/(scot %p who)
==
:: :: ++sein:title
++ sein :: autoboss
|= [our=ship now=@da who=ship]
.^ ship
%j
/(scot %p our)/sein/(scot %da now)/(scot %p who)
==
:: :: ++team:title
++ team :: our / our moon
|= [our=ship who=ship]
^- ?
?| =(our who)
&(?=(%earl (clan who)) =(our (^sein who)))
==
-- ::title
:: ::
:::: ++milly :: (2k) milliseconds
:: ::::
++ milly ^|
|_ now=@da
:: :: ++around:milly
++ around :: relative msec
|= wen=@da
^- @tas
?: =(wen now) %now
?: (gth wen now)
(cat 3 (scot %ud (msec (sub wen now))) %ms)
(cat 3 '-' $(now wen, wen now))
::
++ about :: ++about:milly
|= wun=(unit @da) :: unit relative msec
^- @tas
?~(wun %no (around u.wun))
:: :: ++mill:milly
++ mill :: msec diff
|= one=@dr
^- @tas
?: =(`@`0 one) '0ms'
(cat 3 (scot %ud (msec one)) %ms)
:: :: ++msec:milly
++ msec :: @dr to @ud ms
|=(a=@dr `@ud`(div a (div ~s1 1.000)))
:: :: ++mull:milly
++ mull :: unit msec diff
|= une=(unit @dr)
^- @tas
?~(une %no (mill u.une))
--
::
::::
::
++ contain ^?
|%
:: +by-clock: interface core for a cache using the clock replacement algorithm
::
:: Presents an interface for a mapping, but somewhat specialized, and with
:: stateful accessors. The clock's :depth parameter is used as the maximum
:: freshness that an entry can have. The standard clock algorithm has a depth
:: of 1, meaning that a single sweep of the arm will delete the entry. For
:: more scan resistance, :depth can be set to a higher number.
::
:: Internally, :clock maintains a :lookup of type
:: `(map key-type [val=val-type fresh=@ud])`, where :depth.clock is the
:: maximum value of :fresh. Looking up a key increments its freshness, and a
:: sweep of the clock arm decrements its freshness.
::
:: The clock arm is stored as :queue, which is a `(qeu key-type)`. The head
:: of the queue represents the position of the clock arm. New entries are
:: inserted at the tail of the queue. When the clock arm sweeps, it
:: pops the head off the queue. If the :fresh of the head's entry in :lookup
:: is 0, remove the entry from the mapping and replace it with the new entry.
:: Otherwise, decrement the entry's freshness, put it back at the tail of
:: the queue, and pop the next head off the queue and try again.
::
:: Cache entries must be immutable: a key cannot be overwritten with a new
:: value. This property is enforced for entries currently stored in the
:: cache, but it is not enforced for previously deleted entries, since we
:: no longer remember what that key's value was supposed to be.
::
++ by-clock
|* [key-type=mold val-type=mold]
|_ clock=(clock key-type val-type)
:: +get: looks up a key, marking it as fresh
::
++ get
|= key=key-type
^- [(unit val-type) _clock]
::
=+ maybe-got=(~(get by lookup.clock) key)
?~ maybe-got
[~ clock]
::
=. clock (freshen key)
::
[`val.u.maybe-got clock]
:: +put: add a new cache entry, possibly removing an old one
::
++ put
|= [key=key-type val=val-type]
^+ clock
:: do nothing if our size is 0 so we don't decrement-underflow
::
?: =(0 max-size.clock)
clock
:: no overwrite allowed, but allow duplicate puts
::
?^ existing=(~(get by lookup.clock) key)
:: val must not change
::
?> =(val val.u.existing)
::
(freshen key)
::
=? clock =(max-size.clock size.clock)
evict
::
%_ clock
size +(size.clock)
lookup (~(put by lookup.clock) key [val 1])
queue (~(put to queue.clock) key)
==
:: +freshen: increment the protection level on an entry
::
++ freshen
|= key=key-type
^+ clock
%_ clock
lookup
%+ ~(jab by lookup.clock) key
|= entry=[val=val-type fresh=@ud]
entry(fresh (min +(fresh.entry) depth.clock))
==
:: +resize: changes the maximum size, removing entries if needed
::
++ resize
|= new-max=@ud
^+ clock
::
=. max-size.clock new-max
::
?: (gte new-max size.clock)
clock
::
(trim (sub size.clock new-max))
:: +evict: remove an entry from the cache
::
++ evict
^+ clock
::
=. size.clock (dec size.clock)
::
|-
^+ clock
::
=^ old-key queue.clock ~(get to queue.clock)
=/ old-entry (~(got by lookup.clock) old-key)
::
?: =(0 fresh.old-entry)
clock(lookup (~(del by lookup.clock) old-key))
::
%_ $
lookup.clock
(~(put by lookup.clock) old-key old-entry(fresh (dec fresh.old-entry)))
::
queue.clock
(~(put to queue.clock) old-key)
==
:: +trim: remove :count entries from the cache
::
++ trim
|= count=@ud
^+ clock
?: =(0 count)
clock
$(count (dec count), clock evict)
:: +purge: removes all cache entries
::
++ purge
^+ clock
%_ clock
lookup ~
queue ~
size 0
==
--
:: +to-capped-queue: interface door for +capped-queue
::
:: Provides a queue of a limited size where pushing additional items will
:: force pop the items at the front of the queue.
::
++ to-capped-queue
|* item-type=mold
|_ queue=(capped-queue item-type)
:: +put: enqueue :item, possibly popping and producing an old item
::
++ put
|= item=item-type
^- [(unit item-type) _queue]
:: are we already at max capacity?
::
?. =(size.queue max-size.queue)
:: we're below max capacity, so push and increment size
::
=. queue.queue (~(put to queue.queue) item)
=. size.queue +(size.queue)
::
[~ queue]
:: max is zero, the oldest item to return is the one which just went in.
::
?: =(~ queue.queue)
[`item queue]
:: we're at max capacity, so pop before pushing; size is unchanged
::
=^ oldest queue.queue ~(get to queue.queue)
=. queue.queue (~(put to queue.queue) item)
::
[`oldest queue]
:: +get: pop an item off the queue, adjusting size
::
++ get
^- [item-type _queue]
::
=. size.queue (dec size.queue)
=^ oldest queue.queue ~(get to queue.queue)
::
[oldest queue]
:: change the :max-size of the queue, popping items if necessary
::
++ resize
=| pops=(list item-type)
|= new-max=@ud
^+ [pops queue]
:: we're not overfull, so no need to pop off more items
::
?: (gte new-max size.queue)
[(flop pops) queue(max-size new-max)]
:: we're above capacity; pop an item off and recurse
::
=^ oldest queue get
::
$(pops [oldest pops])
--
--
::
:: +mop: constructs and validates ordered ordered map based on key,
:: val, and comparator gate
::
++ mop
|* [key=mold value=mold]
|= ord=$-([key key] ?)
|= a=*
=/ b ;;((tree [key=key val=value]) a)
?> (check-balance:((ordered-map key value) ord) b)
b
::
:: $mk-item: constructor for +ordered-map item type
::
++ mk-item |$ [key val] [key=key val=val]
:: +ordered-map: treap with user-specified horizontal order
::
:: Conceptually smaller items go on the left, so the item with the
:: smallest key can be popped off the head. If $key is `@` and
:: .compare is +lte, then the numerically smallest item is the head.
::
:: WARNING: ordered-map will not work properly if two keys can be
:: unequal under noun equality but equal via the compare gate
::
++ ordered-map
|* [key=mold val=mold]
=> |%
+$ item (mk-item key val)
--
:: +compare: item comparator for horizontal order
::
|= compare=$-([key key] ?)
|%
:: +check-balance: verify horizontal and vertical orderings
::
++ check-balance
=| [l=(unit key) r=(unit key)]
|= a=(tree item)
^- ?
:: empty tree is valid
::
?~ a %.y
:: nonempty trees must maintain several criteria
::
?& :: if .n.a is left of .u.l, assert horizontal comparator
::
?~(l %.y (compare key.n.a u.l))
:: if .n.a is right of .u.r, assert horizontal comparator
::
?~(r %.y (compare u.r key.n.a))
:: if .a is not leftmost element, assert vertical order between
:: .l.a and .n.a and recurse to the left with .n.a as right
:: neighbor
::
?~(l.a %.y &((mor key.n.a key.n.l.a) $(a l.a, l `key.n.a)))
:: if .a is not rightmost element, assert vertical order
:: between .r.a and .n.a and recurse to the right with .n.a as
:: left neighbor
::
?~(r.a %.y &((mor key.n.a key.n.r.a) $(a r.a, r `key.n.a)))
==
:: +put: ordered item insert
::
++ put
|= [a=(tree item) =key =val]
^- (tree item)
:: base case: replace null with single-item tree
::
?~ a [n=[key val] l=~ r=~]
:: base case: overwrite existing .key with new .val
::
?: =(key.n.a key) a(val.n val)
:: if item goes on left, recurse left then rebalance vertical order
::
?: (compare key key.n.a)
=/ l $(a l.a)
?> ?=(^ l)
?: (mor key.n.a key.n.l)
a(l l)
l(r a(l r.l))
:: item goes on right; recurse right then rebalance vertical order
::
=/ r $(a r.a)
?> ?=(^ r)
?: (mor key.n.a key.n.r)
a(r r)
r(l a(r l.r))
:: +peek: produce head (smallest item) or null
::
++ peek
|= a=(tree item)
^- (unit item)
::
?~ a ~
?~ l.a `n.a
$(a l.a)
::
:: +pop: produce .head (smallest item) and .rest or crash if empty
::
++ pop
|= a=(tree item)
^- [head=item rest=(tree item)]
::
?~ a !!
?~ l.a [n.a r.a]
::
=/ l $(a l.a)
:- head.l
:: load .rest.l back into .a and rebalance
::
?: |(?=(~ rest.l) (mor key.n.a key.n.rest.l))
a(l rest.l)
rest.l(r a(r r.rest.l))
:: +del: delete .key from .a if it exists, producing value iff deleted
::
++ del
|= [a=(tree item) =key]
^- [(unit val) (tree item)]
::
?~ a [~ ~]
:: we found .key at the root; delete and rebalance
::
?: =(key key.n.a)
[`val.n.a (nip a)]
:: recurse left or right to find .key
::
?: (compare key key.n.a)
=+ [found lef]=$(a l.a)
[found a(l lef)]
=+ [found rig]=$(a r.a)
[found a(r rig)]
:: +nip: remove root; for internal use
::
++ nip
|= a=(tree item)
^- (tree item)
::
?> ?=(^ a)
:: delete .n.a; merge and balance .l.a and .r.a
::
|- ^- (tree item)
?~ l.a r.a
?~ r.a l.a
?: (mor key.n.l.a key.n.r.a)
l.a(r $(l.a r.l.a))
r.a(l $(r.a l.r.a))
:: +traverse: stateful partial inorder traversal
::
:: Mutates .state on each run of .f. Starts at .start key, or if
:: .start is ~, starts at the head (item with smallest key). Stops
:: when .f produces .stop=%.y. Traverses from smaller to larger
:: keys. Each run of .f can replace an item's value or delete the
:: item.
::
++ traverse
|* state=mold
|= $: a=(tree item)
=state
f=$-([state item] [(unit val) ? state])
==
^+ [state a]
:: acc: accumulator
::
:: .stop: set to %.y by .f when done traversing
:: .state: threaded through each run of .f and produced by +abet
::
=/ acc [stop=`?`%.n state=state]
=< abet =< main
|%
++ abet [state.acc a]
:: +main: main recursive loop; performs a partial inorder traversal
::
++ main
^+ .
:: stop if empty or we've been told to stop
::
?~ a .
?: stop.acc .
:: inorder traversal: left -> node -> right, until .f sets .stop
::
=> left
?: stop.acc .
=> node
?: stop.acc .
right
:: +node: run .f on .n.a, updating .a, .state, and .stop
::
++ node
^+ .
:: run .f on node, updating .stop.acc and .state.acc
::
=^ res acc
?> ?=(^ a)
(f state.acc n.a)
:: apply update to .a from .f's product
::
=. a
:: if .f requested node deletion, merge and balance .l.a and .r.a
::
?~ res (nip a)
:: we kept the node; replace its .val; order is unchanged
::
?> ?=(^ a)
a(val.n u.res)
::
..node
:: +left: recurse on left subtree, copying mutant back into .l.a
::
++ left
^+ .
?~ a .
=/ lef main(a l.a)
lef(a a(l a.lef))
:: +right: recurse on right subtree, copying mutant back into .r.a
::
++ right
^+ .
?~ a .
=/ rig main(a r.a)
rig(a a(r a.rig))
--
:: +tap: convert to list, smallest to largest
::
++ tap
|= a=(tree item)
^- (list item)
::
=| b=(list item)
|- ^+ b
?~ a b
::
$(a l.a, b [n.a $(a r.a)])
:: +gas: put a list of items
::
++ gas
|= [a=(tree item) b=(list item)]
^- (tree item)
::
?~ b a
$(b t.b, a (put a i.b))
:: +uni: unify two ordered maps
::
:: .b takes precedence over .a if keys overlap.
::
++ uni
|= [a=(tree item) b=(tree item)]
^- (tree item)
::
?~ b a
?~ a b
?: =(key.n.a key.n.b)
::
[n=n.b l=$(a l.a, b l.b) r=$(a r.a, b r.b)]
::
?: (mor key.n.a key.n.b)
::
?: (compare key.n.b key.n.a)
$(l.a $(a l.a, r.b ~), b r.b)
$(r.a $(a r.a, l.b ~), b l.b)
::
?: (compare key.n.a key.n.b)
$(l.b $(b l.b, r.a ~), a r.a)
$(r.b $(b r.b, l.a ~), a l.a)
::
:: +get: get val at key or return ~
::
++ get
|= [a=(tree item) b=key]
^- (unit val)
?~ a ~
?: =(b key.n.a)
`val.n.a
?: (compare b key.n.a)
$(a l.a)
$(a r.a)
::
:: +subset: take a range excluding start and/or end and all elements
:: outside the range
::
++ subset
|= $: tre=(tree item)
start=(unit key)
end=(unit key)
==
^- (tree item)
|^
?: ?&(?=(~ start) ?=(~ end))
tre
?~ start
(del-span tre %end end)
?~ end
(del-span tre %start start)
?> (compare u.start u.end)
=. tre (del-span tre %start start)
(del-span tre %end end)
::
++ del-span
|= [a=(tree item) b=?(%start %end) c=(unit key)]
^- (tree item)
?~ a a
?~ c a
?- b
%start
:: found key
?: =(key.n.a u.c)
(nip a(l ~))
:: traverse to find key
?: (compare key.n.a u.c)
:: found key to the left of start
$(a (nip a(l ~)))
:: found key to the right of start
a(l $(a l.a))
::
%end
:: found key
?: =(u.c key.n.a)
(nip a(r ~))
:: traverse to find key
?: (compare key.n.a u.c)
:: found key to the left of end
a(r $(a r.a))
:: found key to the right of end
$(a (nip a(r ~)))
==
--
--
:: ::
:::: ++userlib :: (2u) non-vane utils
:: ::::
++ userlib ^?
|%
:: ::
:::: ++chrono:userlib :: (2uB) time
:: ::::
++ chrono ^?
|%
:: +from-unix: unix timestamp to @da
::
++ from-unix
|= timestamp=@ud
^- @da
%+ add ~1970.1.1
(mul timestamp ~s1)
:: :: ++dawn:chrono:
++ dawn :: Jan 1 weekday
|= yer=@ud
=+ yet=(sub yer 1)
%- mod :_ 7
;: add
1
(mul 5 (mod yet 4))
(mul 4 (mod yet 100))
(mul 6 (mod yet 400))
==
:: :: ++daws:chrono:
++ daws :: date weekday
|= yed=date
%- mod :_ 7
%+ add
(dawn y.yed)
(sub (yawn [y.yed m.yed d.t.yed]) (yawn y.yed 1 1))
:: :: ++deal:chrono:
++ deal :: to leap sec time
|= yer=@da
=+ n=0
=+ yud=(yore yer)
|- ^- date
?: (gte yer (add (snag n lef:yu) ~s1))
(yore (year yud(s.t (add n s.t.yud))))
?: &((gte yer (snag n lef:yu)) (lth yer (add (snag n lef:yu) ~s1)))
yud(s.t (add +(n) s.t.yud))
?: =(+(n) (lent lef:yu))
(yore (year yud(s.t (add +(n) s.t.yud))))
$(n +(n))
:: :: ++lead:chrono:
++ lead :: from leap sec time
|= ley=date
=+ ler=(year ley)
=+ n=0
|- ^- @da
=+ led=(sub ler (mul n ~s1))
?: (gte ler (add (snag n les:yu) ~s1))
led
?: &((gte ler (snag n les:yu)) (lth ler (add (snag n les:yu) ~s1)))
?: =(s.t.ley 60)
(sub led ~s1)
led
?: =(+(n) (lent les:yu))
(sub led ~s1)
$(n +(n))
:: :: ++dust:chrono:
++ dust :: print UTC format
|= yed=date
^- tape
=+ wey=(daws yed)
=/ num (d-co:co 1) :: print as decimal without dots
=/ pik |=([n=@u t=wall] `tape`(scag 3 (snag n t)))
::
"{(pik wey wik:yu)}, ".
"{(num d.t.yed)} {(pik (dec m.yed) mon:yu)} {(num y.yed)} ".
"{(num h.t.yed)}:{(num m.t.yed)}:{(num s.t.yed)} +0000"
:: :: ++stud:chrono:
++ stud :: parse UTC format
=< |= a=cord :: expose parsers
%+ biff (rush a (more sepa elem))
|= b=(list _(wonk *elem)) ^- (unit date)
=- ?.((za:dejs:format -) ~ (some (zp:dejs:format -)))
^+ =+ [*date u=unit]
*[(u _[a y]) (u _m) (u _d.t) (u _+.t) ~]
:~
|-(?~(b ~ ?.(?=(%y -.i.b) $(b t.b) `+.i.b)))
|-(?~(b ~ ?.(?=(%m -.i.b) $(b t.b) `+.i.b)))
|-(?~(b ~ ?.(?=(%d -.i.b) $(b t.b) `+.i.b)))
|-(?~(b ~ ?.(?=(%t -.i.b) $(b t.b) `+.i.b)))
==
|%
:: :: ++snug:stud:chrono:
++ snug :: position in list
|= a=(list tape)
|= b=tape
=+ [pos=1 len=(lent b)]
|- ^- (unit @u)
?~ a ~
?: =(b (scag len i.a))
`pos
$(pos +(pos), a t.a)
:: :: ++sepa:stud:chrono:
++ sepa :: separator
;~(pose ;~(plug com (star ace)) (plus ace))
:: :: ++elem:stud:chrono:
++ elem :: date element
;~ pose
(stag %t t) (stag %y y) (stag %m m) (stag %d d)
(stag %w w) (stag %z z)
==
:: :: ++y:stud:chrono:
++ y :: year
(stag %& (bass 10 (stun 3^4 dit)))
:: :: ++m:stud:chrono:
++ m :: month
(sear (snug mon:yu) (plus alf))
:: :: ++d:stud:chrono:
++ d :: day
(bass 10 (stun 1^2 dit))
:: :: ++t:stud:chrono:
++ t :: hours:minutes:secs
%+ cook |=([h=@u @ m=@u @ s=@u] ~[h m s])
;~(plug d col d col d)
::
:: XX day of week is currently unchecked, and
:: timezone outright ignored.
:: :: ++w:stud:chrono:
++ w :: day of week
(sear (snug wik:yu) (plus alf))
:: :: ++z:stud:chrono:
++ z :: time zone
;~(plug (mask "-+") dd dd)
:: :: ++dd:stud:chrono:
++ dd :: two digits
(bass 10 (stun 2^2 dit))
-- ::
:: :: ++unt:chrono:userlib
++ unt :: Urbit to Unix time
|= a=@
(div (sub a ~1970.1.1) ~s1)
:: :: ++yu:chrono:userlib
++ yu :: UTC format constants
|%
:: :: ++mon:yu:chrono:
++ mon :: months
^- (list tape)
:~ "January" "February" "March" "April" "May" "June" "July"
"August" "September" "October" "November" "December"
==
:: :: ++wik:yu:chrono:
++ wik :: weeks
^- (list tape)
:~ "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday"
"Friday" "Saturday"
==
:: :: ++lef:yu:chrono:
++ lef :: leapsecond dates
^- (list @da)
:~ ~2016.12.31..23.59.59 ~2015.6.30..23.59.59
~2012.6.30..23.59.59 ~2008.12.31..23.59.58
~2005.12.31..23.59.57 ~1998.12.31..23.59.56
~1997.6.30..23.59.55 ~1995.12.31..23.59.54
~1994.6.30..23.59.53 ~1993.6.30..23.59.52
~1992.6.30..23.59.51 ~1990.12.31..23.59.50
~1989.12.31..23.59.49 ~1987.12.31..23.59.48
~1985.6.30..23.59.47 ~1983.6.30..23.59.46
~1982.6.30..23.59.45 ~1981.6.30..23.59.44
~1979.12.31..23.59.43 ~1978.12.31..23.59.42
~1977.12.31..23.59.41 ~1976.12.31..23.59.40
~1975.12.31..23.59.39 ~1974.12.31..23.59.38
~1973.12.31..23.59.37 ~1972.12.31..23.59.36
~1972.6.30..23.59.35
==
::
:: +les:yu:chrono: leapsecond days
::
:: https://www.ietf.org/timezones/data/leap-seconds.list
::
++ les
^- (list @da)
:~ ~2017.1.1 ~2015.7.1 ~2012.7.1 ~2009.1.1 ~2006.1.1 ~1999.1.1
~1997.7.1 ~1996.1.1 ~1994.7.1 ~1993.7.1 ~1992.7.1 ~1991.1.1
~1990.1.1 ~1988.1.1 ~1985.7.1 ~1983.7.1 ~1982.7.1 ~1981.7.1
~1980.1.1 ~1979.1.1 ~1978.1.1 ~1977.1.1 ~1976.1.1 ~1975.1.1
~1974.1.1 ~1973.1.1 ~1972.7.1
==
-- ::yu
-- ::chrono
:: ::
:::: ++space:userlib :: (2uC) file utils
:: ::::
++ space ^?
=, clay
|%
:: :: ++feel:space:userlib
++ feel :: simple file write
|= [pax=path val=cage]
^- miso
=+ dir=.^(arch %cy pax)
?~ fil.dir [%ins val]
[%mut val]
:: :: ++file:space:userlib
++ file :: simple file load
|= pax=path
^- (unit)
=+ dir=.^(arch %cy pax)
?~(fil.dir ~ [~ .^(* %cx pax)])
:: :: ++foal:space:userlib
++ foal :: high-level write
|= [pax=path val=cage]
^- toro
?> ?=([* * * *] pax)
[i.t.pax [%& [[[t.t.t.pax (feel pax val)] ~]]]]
:: :: ++fray:space:userlib
++ fray :: high-level delete
|= pax=path
^- toro
?> ?=([* * * *] pax)
[i.t.pax [%& [[[t.t.t.pax [%del ~]] ~]]]]
:: :: ++furl:space:userlib
++ furl :: unify changes
|= [one=toro two=toro]
^- toro
~| %furl
?> ?& =(p.one p.two) :: same path
&(?=(%& -.q.one) ?=(%& -.q.two)) :: both deltas
==
[p.one [%& (weld p.q.one p.q.two)]]
-- ::space
:: ::
:::: ++unix:userlib :: (2uD) unix line-list
:: ::::
++ unix ^?
|%
:: :: ++lune:unix:userlib
++ lune :: cord by unix line
~% %lune ..part ~
|= txt=@t
?~ txt
^- (list @t) ~
=+ [byt=(rip 3 txt) len=(met 3 txt)]
=| [lin=(list @t) off=@]
^- (list @t)
%- flop
|- ^+ lin
?: =(off len)
~| %noeol !!
?: =((snag off byt) 10)
?: =(+(off) len)
[(rep 3 (scag off byt)) lin]
%= $
lin [(rep 3 (scag off byt)) lin]
byt (slag +(off) byt)
len (sub len +(off))
off 0
==
$(off +(off))
:: :: ++nule:unix:userlib
++ nule :: lines to unix cord
~% %nule ..part ~
|= lin=(list @t)
^- @t
%+ can 3
%+ turn lin
|= t=@t
[+((met 3 t)) (cat 3 t 10)]
--
:: ::
:::: ++scanf:userlib :: (2uF) exterpolation
:: ::::
++ scanf
=< |* [tape (pole _;/(*[$^(rule tape)]))] :: formatted scan
=> .(+< [a b]=+<)
(scan a (parsf b))
|%
:: :: ++parsf:scanf:
++ parsf :: make parser from:
|* a=(pole _;/(*[$^(rule tape)])) :: ;"chars{rule}chars"
=- (cook - (boil (norm a)))
|* (list)
?~ +< ~
?~ t i
[i $(+< t)]
::
:: .= (boil ~[[& dim] [| ", "] [& dim]]:ag)
:: ;~(plug dim ;~(pfix com ace ;~(plug dim (easy)))):ag
::
:: :: ++boil:scanf:userlib
++ boil ::
|* (list (each rule tape))
?~ +< (easy ~)
?: ?=(%| -.i) ;~(pfix (jest (crip p.i)) $(+< t))
%+ cook |*([* *] [i t]=+<)
;~(plug p.i $(+< t))
::
:: .= (norm [;"{n}, {n}"]:n=dim:ag) ~[[& dim] [| ", "] [& dim]]:ag
::
:: :: ++norm:scanf:userlib
++ norm ::
|* (pole _;/(*[$^(rule tape)]))
?~ +< ~
=> .(+< [i=+<- t=+<+])
:_ t=$(+< t)
=+ rul=->->.i
^= i
?~ rul [%| p=rul]
?~ +.rul [%| p=rul]
?@ &2.rul [%| p=;;(tape rul)]
[%& p=rul]
-- ::scanf
--
:: +harden: coerce %soft $hobo or pass-through
::
++ harden
|* task=mold
|= wrapped=(hobo task)
^- task
?. ?=(%soft -.wrapped)
wrapped
;;(task +.wrapped)
::
++ zuse %309 :: hoon+zuse kelvin
--
Reference in New Issue View Git Blame Copy Permalink