Author: wmb Date: 2009-09-24 08:12:39 +0200 (Thu, 24 Sep 2009) New Revision: 1375 Added: ofw/fs/cifs/ ofw/fs/cifs/loadpkg.fth ofw/fs/cifs/netbios.fth ofw/fs/cifs/smb.fth Modified: cpu/x86/pc/olpc/crypto.fth cpu/x86/pc/olpc/via/fw.bth Log: New CIFS (SMB) filesystem driver for accessing Windows shares. Requires new version of bios_crypto with DES and MD4 support for password computation. Modified: cpu/x86/pc/olpc/crypto.fth =================================================================== --- cpu/x86/pc/olpc/crypto.fth 2009-09-24 06:10:34 UTC (rev 1374) +++ cpu/x86/pc/olpc/crypto.fth 2009-09-24 06:12:39 UTC (rev 1375) @@ -40,6 +40,18 @@ hashbuf hashlen @ ; +\ Another hack - if the hashname is "des", the arguments to signature-bad? +\ are ( 0 plain$ cipher$ key$ hashname$="des" -- error? ) +\ plain$, cipher$, and key$ are all 8-byte arrays - ciper$ is output +: des ( data$ key$ -- result$ ) + 2>r 0 -rot hashbuf 8 2r> " des" ( 0 data$ ciper$ key$ hashname$ ) + signature-bad? h# fffff and abort" DES failed" ( ) + hashbuf 8 +; + + + + \ LICENSE_BEGIN \ Copyright (c) 2007 FirmWorks \ Modified: cpu/x86/pc/olpc/via/fw.bth =================================================================== --- cpu/x86/pc/olpc/via/fw.bth 2009-09-24 06:10:34 UTC (rev 1374) +++ cpu/x86/pc/olpc/via/fw.bth 2009-09-24 06:12:39 UTC (rev 1375) @@ -451,6 +451,13 @@ fload ${BP}/ofw/inet/http.fth \ HTTP client end-support-package +support-package: cifs + fload ${BP}/ofw/fs/cifs/loadpkg.fth +end-support-package +devalias smb tcp//cifs +devalias cifs tcp//cifs +: op " select smb:\\test:testxxx@10.20.0.14\XTest\hello.txt" eval ; + fload ${BP}/cpu/x86/pc/olpc/via/memtest.fth fload ${BP}/ofw/wifi/wifi-cfg.fth Added: ofw/fs/cifs/loadpkg.fth =================================================================== --- ofw/fs/cifs/loadpkg.fth (rev 0) +++ ofw/fs/cifs/loadpkg.fth 2009-09-24 06:12:39 UTC (rev 1375) @@ -0,0 +1,2 @@ +fload ${BP}/ofw/fs/cifs/netbios.fth \ Netbios session layer +fload ${BP}/ofw/fs/cifs/smb.fth \ SMB messages Added: ofw/fs/cifs/netbios.fth =================================================================== --- ofw/fs/cifs/netbios.fth (rev 0) +++ ofw/fs/cifs/netbios.fth 2009-09-24 06:12:39 UTC (rev 1375) @@ -0,0 +1,215 @@ + +d# 4096 constant max-data +d# 4356 constant my-max-buf +d# 0 constant my-max-raw +d# 1 constant my-max-mpx + +\ my-max-buf instance buffer: session-buf \ 4096 + 4 (session header length) +0 instance value session-buf +0 instance value x-adr + +: start-encode ( -- ) session-buf to x-adr ; +: +xb ( byte -- ) x-adr c! x-adr 1+ to x-adr ; +: +xw ( word -- ) x-adr le-w! x-adr wa1+ to x-adr ; +: +xl ( long -- ) x-adr le-l! x-adr la1+ to x-adr ; +: +xbytes ( adr len -- ) + tuck x-adr swap move ( len ) + x-adr + to x-adr ( ) +; +: +xalign ( -- ) x-adr session-buf - 1 and if 0 +xb then ; + +: +nibble ( b -- ) [char] A + +xb ; +: bnsplit ( b -- lo hi ) + dup h# f and swap 4 rshift h# f and +; +: +split ( b -- ) bnsplit +nibble +nibble ; + +\ String is e.g. "BDCO"(00)" or "*SMBSERVER " +\ The last character is usually either 00 or space +: split-last ( adr len -- lastchar adr len' ) + 2dup + 1- c@ -rot 1- ( lastchar adr len' ) +; +: +l1 ( adr len -- ) + split-last ( lastchar adr len' ) + d# 15 min tuck ( lastchar len' adr len' ) + bounds ?do ( lastchar len ) + i c@ +split ( lastchar len lo hi ) + loop ( lastchar len ) + d# 15 swap ?do ( lastchar ) + bl +split ( lastchar ) + loop ( lastchar ) + +split ( ) +; +: .one ( char -- ) + push-hex + dup h# 20 h# 7f between if + emit + else + bnsplit ." (" .2 .2 ." )" + then + pop-base +; +: -nulls ( adr len -- adr len' ) + begin dup while ( adr len ) + 2dup + 1- c@ if ( adr len ) + exit + then ( adr len ) + 1- ( adr len' ) + repeat ( adr len ) +; +: .l1 ( adr len -- ) + split-last ( lastchar adr len' ) + -trailing -nulls ( lastchar adr len' ) + bounds ?do + i c@ .one + loop +; +: +wildcard ( adr len -- ) + d# 16 min tuck ( len' adr len' ) + bounds ?do ( len ) + i c@ +split ( len ) + loop ( len ) + d# 16 swap ?do ( ) + 0 +split ( ) + loop ( ) +; + +: +l2 ( adr len -- ) \ Encode foo.bar.oof + [char] . left-parse-string ( rem$ head$ ) + d# 32 +xb +l1 ( rem$ ) + begin dup while ( rem$ ) + [char] . left-parse-string ( rem$ head$ ) + d# 63 max dup +xb ( rem$ head$ ) + bounds do i c@ +xb loop ( rem$ ) + repeat ( rem$ ) + 2drop ( ) +; +: l2-split ( $ -- rem$ this$ ) \ $ must be non-empty + over 1+ over c@ ( adr len thisadr thislen ) + dup h# c0 and abort" L2 name contains label string pointer (unimplemented)" + 2swap third ( thisadr thislen adr len thislen ) + 1+ /string ( thisadr thislen remadr remlen ) + 2swap ( rem$ this$ ) +; + +: .l2 ( adr len -- ) + l2-split .l1 ( rem$ ) + begin dup while ( rem$ ) + l2-split ( rem$ this$ ) + dup if ." ." then ( rem$ this$ ) + bounds ?do i c@ emit loop ( rem$ ) + repeat ( rem$ ) + 2drop ( ) +; + + +\ Name service implementation would go here... + + +: session{ ( type -- ) + start-encode ( type ) + +xb \ type + 0 +xb \ flags + 0 +xb 0 +xb \ length - patched later +; + +: }session ( -- error? ) + x-adr session-buf - 4 - ( length ) + lwsplit ( lo hi ) + dup 1 > abort" Session length too long" + session-buf 1+ c! ( lo ) + session-buf 2+ be-w! ( ) + session-buf x-adr over - tuck " write" $call-parent ( len actual ) + dup -1 = if ( len actual ) + ." TCP connection dropped" cr + 2drop true exit + then ( len actual ) + <> dup if ." TCP short write" cr then +; + +\ XXX we should probably have a timeout +: get-tcp ( adr len -- error? ) + begin dup while ( adr remlen ) + 2dup " read" $call-parent ( adr remlen thislen ) + dup -1 = if ( adr remlen thislen ) + 3drop true exit + then ( adr remlen thislen ) + \ -2 means "none available yet" + dup -2 = if drop 0 then ( adr remlen thislen ) + /string ( adr remlen' ) + repeat ( adr remlen' ) + 2drop false +; + +: +session-label ( $ -- ) bl +xb +l1 0 +xb ; + +0 instance value /session-response +: .session-error ( code -- ) + ." Session error: " + case + h# 80 of ." Not listening on called name" cr endof + h# 81 of ." Not listening for calling name" cr endof + h# 82 of ." Called name not present" cr endof + h# 83 of ." Insufficient resources" cr endof + h# 8f of ." Unspecified error" cr endof + ( default ) ." Undefined error code: " dup .x cr + endcase +; + +: do-retarget ( -- error? ) + /session-response 6 <> if + ." Incorrect length for session retarget response" cr + true exit + then + + ." Retarget to IP " session-buf .ipaddr + ." port " session-buf 4 + be-w@ .d cr + true +; + +: get-session-response ( -- true | adr len false ) + session-buf 4 get-tcp if true exit then ( ) + session-buf c@ ( type ) + session-buf 2+ be-w@ ( type length-lo ) + session-buf 1+ c@ 1 and ( type length-lo length-hi ) + wljoin to /session-response ( type ) + + session-buf /session-response get-tcp if true exit then ( type ) + + case ( ) + 0 of \ Session message + session-buf /session-response false exit + endof + + h# 82 of \ Positive response + session-buf /session-response false exit + endof + + h# 83 of \ Negative response + /session-response 1 <> if + ." Incorrect length for negative session response" cr + true exit + then + session-buf c@ .session-error + true exit + endof + + h# 84 of do-retarget endof + + ( default ) + ." Undefined session response code: " .x cr + true exit + endcase +; + +: start-session ( calling$ called$ -- error? ) + h# 81 session{ ( calling$ called$ ) + +session-label ( calling$ ) + +session-label ( ) + }session if true exit then ( ) + get-session-response if ( ) + true ( true ) + else ( adr len ) + 2drop false ( false ) + then ( error? ) +; Added: ofw/fs/cifs/smb.fth =================================================================== --- ofw/fs/cifs/smb.fth (rev 0) +++ ofw/fs/cifs/smb.fth 2009-09-24 06:12:39 UTC (rev 1375) @@ -0,0 +1,649 @@ +char \ constant delim + +0. instance 2value share$ +0. instance 2value server$ +0. instance 2value password$ + +0. instance 2value account$ + +: set-account ( adr len -- ) + dup alloc-mem ( adr len dst-adr ) + swap to account$ ( adr ) + account$ move ( ) +; + +: parse-server ( url$ -- rem$ ) + \ If the string is shorter than 2 characters, the server portion is null + dup 2 < if " " exit then ( url$ ) + + \ If the string doesn't start with \\, the server portion is null + over " \\" comp if " " exit then ( url$ ) + + 2 /string ( url$' ) + delim left-parse-string ( rem$ server$ ) + [char] @ split-string ( rem$ head$ tail$ ) + dup if \ @ is present, tail is server ( rem$ cred$ server$ ) + 1 /string to server$ ( rem$ cred$ ) + [char] : left-parse-string ( rem$ password$ user$ ) + to account$ to password$ ( rem$ ) + else \ No @; head is server ( rem$ server$ empty$ ) + 2drop to server$ ( rem$ ) + " GUEST" to account$ ( rem$ ) + then ( rem$ ) +; + +\ If the filename itself contains "\\", split it around that, returning +\ filename$' as the portion preceding the "\\" and "rem$" as the trailing +\ portion beginning with the second "\" of the pair. +\ For example, "\foo\bar\\oof\rab" parses to "\oof\rab" "\foo\bar" +: parse-pathname ( filename$ -- rem$ filename$' ) + 2dup ( filename$ test$ ) + begin dup while ( filename$ test$ ) + delim split-string ( filename$ head$ tail$ ) + 2swap 2drop ( filename$ tail$ ) + dup if 1 /string then ( filename$ tail$' ) \ Remove first "\" + dup if ( filename$ tail$ ) + over c@ delim = if ( filename$ tail$ ) + \ We found a \\ ( filename$ tail$ ) + 2swap 2 pick - 1- ( rem$ filename$' ) \ Remove tail + exit + then ( filename$ tail$ ) + then ( filename$ tail$ ) + repeat ( filename$ tail$ ) + 2swap ( null-rem$ filename$ ) +; + +: parse-share ( share+path$ -- /path$ ) + delim split-string 2swap to share$ ( /path$ ) +; + +\ If the filename itself contains "//", split it around that, returning +\ filename$' as the portion preceding the "//" and "rem$" as the trailing +\ portion beginning with the second "/" of the pair. +\ For example, "/foo/bar//oof/rab" parses to "/oof/rab" "/foo/bar" +: parse-filename ( filename$ -- rem$ filename$' ) + 2dup ( filename$ test$ ) + begin dup while ( filename$ test$ ) + delim split-string ( filename$ head$ tail$ ) + 2swap 2drop ( filename$ tail$ ) + dup if 1 /string then ( filename$ tail$' ) \ Remove first "/" + dup if ( filename$ tail$ ) + over c@ delim = if ( filename$ tail$ ) + \ We found a // ( filename$ tail$ ) + 2swap 2 pick - 1- ( rem$ filename$' ) \ Remove tail + exit + then ( filename$ tail$ ) + then ( filename$ tail$ ) + repeat ( filename$ tail$ ) + 2swap ( null-rem$ filename$ ) +; + +headers +: set-server ( server$ -- ) + dup if " $set-host" $call-parent else 2drop then +; +: old-parse-server ( server+share$ -- server$ ) + \ If the string is shorter than 2 characters, the server portion is null + dup 2 < if " " exit then ( ss$ ) + + \ If the string doesn't start with \\, the server portion is null + over " \\" comp if " " exit then ( ss$ ) + + 2 /string ( server\share$ ) + delim split-string ( server$ share$ ) + 2drop ( server$ ) +; + +: old-parse-share ( url$ -- rem$ server+share$ ) + \ If the string is shorter than 2 characters, the server portion is null + dup 2 < if " " exit then ( url$ ) + + \ If the string doesn't start with \\, the server portion is null + over " \\" comp if " " exit then ( url$ ) + + 2dup 2 /string ( url$ $1 ) \ $1 omits the leading \\ + delim left-parse-string ( url$ share+path$ server$ ) + 2drop ( url$ share+path$ ) + delim split-string ( url$ share$ path$ ) + 2nip ( url$ path$ ) + 2swap ( path$ url$ ) + third - ( path$ server+share$ ) +; + +8 instance buffer: signature +h# c001 constant smb-flags +h# c05c constant my-capabilities \ LargeRd, LargeWr, NTStat, NT SMBs, Large files, Unicode +0 instance value pid +0 instance value tid +0 instance value uid +0 instance value mid +0 instance value msg# + +0 instance value last-command + +: smb-init ( -- ) + signature 8 erase + random h# ffff and to pid + 0 to tid + 0 to mid + 0 to uid +; + +: +dialect ( adr len -- ) 2 +xb +xbytes 0 +xb ; + +: needed ( adr len needed -- adr len ) + over > abort" SMB response too short" +; +: -xb ( adr len -- adr' len' byte ) + 1 needed over c@ >r 1 /string r> +; +: -xw ( adr len -- adr' len' byte ) + 2 needed over le-w@ >r 2 /string r> +; +: -xl ( adr len -- adr' len' byte ) + 4 needed over le-l@ >r 4 /string r> +; +: drop-b ( rem$ -- rem$' ) -xb drop ; +: drop-w ( rem$ -- rem$' ) -xw drop ; +: drop-l ( rem$ -- rem$' ) -xl drop ; + +: -magic ( adr len -- adr' len' ) + 4 needed over " "(ff)SMB" comp abort" Non-SMB response!" + 4 /string +; +: -xbytes ( adr len n -- rem$ this$ ) + >r r@ needed ( adr len ) + 2dup r@ /string 2swap ( rem$ adr len ) + drop r> +; +: -wcnt ( rem$ -- rem$' wcnt ) + -xb >r r@ 2* needed r> +; +: expect-wcnt ( rem$ n -- rem$' ) + >r -wcnt r> <> abort" Unexpected word count" +; + +: shift$ ( tail$ head$ -- tail$' head$' ) + 2+ 2swap 2 /string 2swap +; + +\ The unicode length excludes the null terminator word (or byte) +: -unicode$ ( adr len -- rem$ unicode$ ) + over 0 ( rem$ unicode$ ) + begin third 1 > while ( rem$ unicode$ ) + shift$ ( rem$' unicode$' ) + over le-w@ 0= if 2- exit then ( rem$ unicode$ ) + repeat +; + +0 instance value server-flags +8 instance buffer: his-signature +: -smb ( adr len -- true | adr len false ) + d# 32 needed + -magic ( rem$' ) + -xb last-command <> abort" Wrong command value in response" + -xl ?dup if ( rem$' error ) + ." SMB Error: " .x cr + 2drop true exit + then ( rem$ ) + -xb >r ( rem$ r: flags-hi ) + r@ h# 80 and 0= abort" Reply bit not set in SMB response" + -xw r> wljoin to server-flags ( rem$' ) + drop-w ( rem$' ) \ Ignore PID high + 8 -xbytes his-signature swap move ( rem$' ) \ Signature + drop-w ( rem$' ) \ Ignore reserved + -xw to tid ( rem$' ) \ Lock onto new TID + -xw pid <> abort" PID mismatch" ( rem$' ) + -xw to uid ( rem$' ) \ Lock onto new UID + -xw mid <> abort" MID mismatch" ( rem$' ) + false +; + +0 instance value byte-cnt-adr +: bytes{ ( -- ) + x-adr to byte-cnt-adr + 0 +xw +; +: }bytes ( -- ) + x-adr byte-cnt-adr - 2- byte-cnt-adr le-w! +; + +0 instance value word-cnt-adr +: words{ ( -- ) + x-adr to word-cnt-adr + 0 +xb +; +: }words ( -- ) + x-adr word-cnt-adr - 1- ( #bytes ) + dup 1 and abort" Word area length is odd!" + 2/ word-cnt-adr c! +; + +: --bytes-- ( -- ) }words bytes{ ; + +: smb{ ( cmd -- ) + 0 session{ + " "(ff)SMB" +xbytes ( cmd ) + dup to last-command +xb ( ) + 0 +xl \ NT_STATUS_SUCCESS + smb-flags lwsplit +xb +xw + 0 +xw \ PID high - always 0 + signature 8 +xbytes + 0 +xw \ Reserved + tid +xw + pid +xw + uid +xw + mid +xw + words{ +; +: }smb ( -- true | adr len false ) + }bytes + }session if true exit then + get-session-response if true exit then + -smb +; + +0 instance value encrypt? +0 instance value max-tbuf +0 instance value max-raw +0 instance value max-mpx +0 instance value session-key +0 instance value capabilities +0 instance value time-hi +0 instance value time-lo +0 instance value time-zone +0 instance value key-length +0. instance 2value challenge$ + +: parse-negotiate ( adr len -- error? ) + d# 17 expect-wcnt ( rem$' ) + -xw 0<> abort" Bogus dialect index" ( rem$' ) + -xb dup 1 and 0= abort" Not supporting share-level security" ( rem$' mode ) + 2 and 0<> to encrypt? ( rem$ ) + -xw to max-mpx ( rem$' ) + drop-w ( rem$' ) \ MaxNumberVcs + -xl to max-tbuf ( rem$' ) + -xl to max-raw ( rem$' ) + -xl to session-key ( rem$' ) + -xl to capabilities ( rem$' ) + drop-l ( rem$' ) \ time-low + drop-l ( rem$' ) \ time-hi + drop-w ( rem$' ) \ time zone + -xb dup alloc-mem swap to challenge$ ( rem$ ) + -xw dup needed ( rem$' strings-len ) + nip ( rem$' ) + challenge$ nip -xbytes drop challenge$ move ( rem$' ) + \ The rest is the server domain name and name, which we don't need + 2drop false +; +: +unicode$ ( adr len -- ) + +xalign \ Force to even address + bounds ?do i c@ +xw loop + 0 +xw +; +: negotiate ( -- error? ) + h# 72 smb{ + --bytes-- + " NT LM 0.12" +dialect + }smb if true exit then ( rem$ ) + parse-negotiate +; + +\ Authentication for NT LM 0.12 + +8 instance buffer: buf8 + +: @7bits ( adr bit# -- n ) + dup 7 and >r 3 rshift ( adr byte# r: bit# ) + + be-w@ r> lshift h# fe00 and 8 rshift +; + +\ This really should compute the parity bit and insert it in the LSB, +\ but I happen to know that the DES implemention in bios_crypto ignores that bit. +: >odd ( byte -- byte' ) ; + +: 7to8 ( adr -- adr' 8 ) + 8 0 do ( adr ) + dup i 7 * @7bits >odd buf8 i + c! ( adr ) + loop ( adr ) + drop ( ) + buf8 8 +; + +0 instance value password-buf +d# 16 buffer: p21-buf +d# 24 buffer: p24-buf +: p24$ ( -- adr len ) p24-buf d# 24 ; + +: set-password ( adr len -- ) + load-crypto abort" Crypto load failed" + dup 2* alloc-mem to password-buf ( adr len ) + tuck 0 ?do ( len adr ) + dup i + c@ ( len adr ) + password-buf i wa+ le-w! ( len adr ) + loop ( len adr ) + drop ( len ) + password-buf over 2* " md4" crypto-hash ( len hashed$ ) + p21-buf swap move ( len ) + p21-buf d# 16 + 5 erase ( len ) + password-buf swap 2* free-mem ( ) +; + +: compute-password ( -- ) + \ XXX should be contingent upon encrypt? + challenge$ p21-buf d# 00 + 7to8 des p24-buf d# 00 + swap move + challenge$ p21-buf d# 07 + 7to8 des p24-buf d# 08 + swap move + challenge$ p21-buf d# 14 + 7to8 des p24-buf d# 16 + swap move +; + +: no-andx ( -- ) + h# ff +xb \ No more AndX commands + 0 +xb \ Reserved + 0 +xw \ Offset to next AndX command +; + +: send-setup ( -- true | rem$ false ) + h# 73 smb{ + no-andx + max-tbuf my-max-buf min +xw + max-mpx my-max-mpx min +xw + 0 +xw \ VC number + 0 +xl \ Session key (unused when VC number is 0) + p24$ nip dup +xw +xw \ Password length and unicode password length + 0 +xl \ Reserved + my-capabilities +xl + }words + bytes{ + p24$ +xbytes \ ASCII + p24$ +xbytes \ Unicode + account$ +unicode$ + " " +unicode$ + " Open Firmware" +unicode$ + " Open Firmware CIFS Client" +unicode$ + }smb +; +: drop-andx ( rem$ -- rem$' ) + -xb h# ff <> abort" Unexpected AndX continuation" + drop-b ( rem$' ) + drop-w ( rem$' ) +; +0 instance value guest? +: parse-setup ( adr len -- error? ) + 3 expect-wcnt ( rem$ ) + drop-andx ( rem$' ) + -xw 1 and 0<> to guest? ( rem$' ) + \ There is also a byte string section containing + \ ServerOSName + \ ServerLANManagerName + \ ServerPrimaryDomain + \ We don't care about them, so we stop parsing here + \ BTW, in the setup response from WinXP, the Domain + \ string is one byte too short - the null word in the + \ Unicode string is really a null byte. + 2drop false +; + +: session-setup ( -- error? ) + 0 to msg# + send-setup if true exit then ( rem$ ) + parse-setup +; + +: empty-response ( true | rem$ false -- error? ) + if true exit then ( rem$ ) + 2drop false ( error? ) +; + +: tree-disconnect ( path$ -- error? ) + h# 71 smb{ --bytes-- }smb empty-response +; + +: tree-connect ( server+share$ -- error? ) + h# 75 smb{ + no-andx + 8 +xw \ Flags - 8 is set for some reason in mount.cifs, but is not defined + 1 +xw \ Password length - 1 for null-terminator since no share-level security + --bytes-- + 0 +xb \ Null share password + ( path$ ) +unicode$ + " ?????" +xbytes 0 +xb + }smb if true exit then ( rem$ ) + 2drop false + \ The tree connect response has several uninteresting fields +; + +: +path ( path$ -- ) 4 +xb +unicode$ ; \ 4 is buffer format + +: +path}smb ( path$ -- true | rem$ false ) + --bytes-- ( path$ ) + +path ( ) + }smb ( true | rem$ false ) +; + +0 instance value fid +0 instance value attributes \ 01:RO 02:Hidden 04:System 08:Volume 10:Directory 20:Archive + +: $create ( path$ -- error? ) + h# 03 smb{ ( path$ ) + attributes +xw ( path$ ) + 0 +xl \ Creation time ( path$ ) + +path}smb if true exit then ( rem$ ) + 1 expect-wcnt ( rem$ ) + -xw to fid ( rem$' ) + \ The byte array is supposed to be empty + 2drop false +; + +0. instance 2value size + +\ We should probably use the ANDX CREATE so we can handle large files +\ Good value for access: h# 0002 +\ Bits: 4000: WriteThrough 1000:DontCache 700:LocalityOfReference +\ 70: SharingMode 7: Access-0:RO,1:WO,2:RW,3:Exec +: open-file ( path$ access -- error? ) + h# 02 smb{ ( path$ access ) + +xw ( path$ ) + attributes +xw ( path$ ) + +path}smb if true exit then ( rem$ ) + + 7 expect-wcnt ( rem$ ) + -xw to fid ( rem$' ) + drop-w \ Attributes ( rem$' ) + drop-l \ Last write time ( rem$' ) + -xl u>d to size ( rem$' ) + drop-w \ Granted access ( rem$' ) + \ The byte array is supposed to be empty + 2drop false +; + +: $mkdir ( path$ -- error? ) + 0 smb{ +path}smb empty-response +; +: $rmdir ( path$ -- error? ) + 1 smb{ +path}smb empty-response +; + +: close-file ( -- error? ) + 4 smb{ + fid +xw + 0 +xl \ Time + --bytes-- + }smb + empty-response +; + +: $delete ( path$ -- error? ) + 6 smb{ ( path$ ) + attributes +xw ( path$ ) + +path}smb empty-response ( error? ) +; +: $delete! ( path$ -- error? ) + $delete +; +: $rename ( old-path$ new-path$ -- error? ) + 7 smb{ ( old-path$ new-path$ ) + attributes +xw ( old-path$ new-path$ ) + --bytes-- ( old-path$ new-path$ ) + 2swap +path +path ( ) + }smb empty-response ( error? ) +; + +: flush ( -- error? ) + 5 smb{ fid +xw --bytes-- }smb empty-response +; + +0. instance 2value position +: seek ( d.offset -- error? ) + size 2over d< if 2drop true exit then + to position + false +; + +: read-some ( adr len -- actual-len ) + max-data min + h# 2e smb{ + no-andx + fid +xw ( adr len ) + position drop +xl ( adr len ) + +xw ( adr ) + 0 +xw ( adr ) \ min count (reserved) + 0 +xl ( adr ) \ reserved + 0 +xw ( adr ) \ remaining (reserved) + position nip +xl ( adr ) + --bytes-- ( adr ) + }smb if drop -1 exit then ( adr rem$ ) + d# 12 expect-wcnt ( adr rem$' ) + drop-andx ( adr rem$' ) + drop-w \ Reserved ( adr rem$' ) + drop-w \ Data compaction mode ( adr rem$' ) + drop-w \ Reserved ( adr rem$' ) + -xw >r \ Actual length ( adr rem$' r: actual ) + drop-w \ Offset to data ( adr rem$' r: actual ) + drop-w drop-w drop-w drop-w drop-w ( adr rem$' r: actual ) + -xw if drop-b then ( adr rem$' r: actual ) \ Byte count and pad + drop swap r@ move r> ( actual ) + dup 0 position d+ to position ( actual ) +; +: read ( adr len -- actual ) + tuck ( len adr remlen ) + begin dup while ( len adr remlen ) + 2dup read-some ( len adr remlen thislen ) + dup -1 = if ( len adr remlen thislen ) + nip nip nip exit + then ( len adr remlen thislen ) + dup 0= if ( len adr remlen thislen ) + drop nip - exit ( actual ) + then ( len adr remlen thislen ) + /string ( len adr remlen' ) + repeat ( len adr remlen' ) + 2drop +; + +: write-some ( adr len -- actual-len ) + max-data min + h# 2f smb{ + no-andx + fid +xw ( adr len ) + position drop +xl ( adr len ) \ File offset low + 0 +xl ( adr len ) \ Reserved + 0 +xw ( adr len ) \ Write mode - 0 is write behind, 1 is write through, other bits for pipes + 0 +xw ( adr len ) \ Remaining - used for pipes when mode&8 is set + 0 +xw ( adr len ) \ Reserved + dup +xw ( adr len ) \ Data length + d# 64 +xw ( adr len ) \ offset to data byte + position nip +xl ( adr len ) \ File offset high + --bytes-- ( adr len ) + 0 +xb ( adr len ) \ Pad + +xbytes ( ) \ Data + }smb if -1 exit then ( rem$ ) + 6 expect-wcnt ( rem$' ) + drop-andx ( rem$' ) + -xw >r \ Actual length ( rem$' r: actual ) +\ We don't anything following +\ drop-w \ Remaining ( rem$' ) +\ drop-l \ Reserved ( rem$' ) + 2drop r> ( actual ) + dup 0 position d+ to position ( actual ) +; +: write ( adr len -- actual ) + tuck ( len adr remlen ) + begin dup while ( len adr remlen ) + 2dup write-some ( len adr remlen thislen ) + dup -1 = if ( len adr remlen thislen ) + nip nip nip exit + then ( len adr remlen thislen ) + dup 0= if ( len adr remlen thislen ) + drop nip - exit ( actual ) + then ( len adr remlen thislen ) + /string ( len adr remlen' ) + repeat ( len adr remlen' ) + 2drop +; + +0 [if] +: send-create-andx ( path$ access flags -- ) + h# a2 smb{ + words{ + no-andx ( path$ access flags ) + third 1+ 2* +xw ( path$ access flags ) \ Byte count for string + terminator + +xw ( path$ access ) \ Create flage + 0 +xw ( path$ access ) \ Root FID + + --bytes-- + 0 +xb \ Null share password + ( path$ ) +unicode$ + " ?????" +xbytes 0 +xb + }smb if true exit then + XXX +; +[then] + +: $interpose ( arg$ pkgname$ -- okay? ) + find-package if package-interpose true else 2drop false then +; + +: allocate-buffers ( -- ) + my-max-buf alloc-mem to session-buf +; +: free-buffers ( -- ) + session-buf my-max-buf free-mem + account$ dup if free-mem else 2drop then + challenge$ dup if free-mem else 2drop then +; + +: open ( -- okay? ) + my-args dup 0= if 2drop true exit then ( arg$ ) + allocate-buffers ( arg$ ) + + parse-server parse-share ( rem$ ) + server$ set-server ( rem$ ) + d# 139 " connect" $call-parent 0= if 2drop false exit then + " OFW" " *SMBSERVER " start-session if 2drop false exit then + negotiate if free-buffers 4drop false exit then ( rem$ ) + password$ set-password compute-password ( rem$ ) + session-setup if free-buffers 4drop false exit then ( rem$ ) + share$ server$ " \\\\%s\\%s" sprintf ( rem$ server+share$ ) + tree-connect if free-buffers 2drop false exit then ( rem$ ) + + parse-filename 2 open-file if ( rem$ ) + free-buffers 2drop false exit + then ( rem$ ) + + \ If any arguments remain, assume we are dealing with a ZIP + \ archive and interpose the ZIP handler + dup if ( rem$ ) + " zip-file-system" $interpose ( okay? ) + else ( rem$ ) + 2drop true ( okay? ) + then ( okay? ) +; +: close ( -- ) + close-file drop + tree-disconnect drop + free-buffers +; + +: dma-alloc ( #bytes -- adr ) alloc-mem ; +: dma-free ( adr #bytes -- ) free-mem ; + +: load ( adr -- len ) size drop read ;