Anew NTNetLib  \ administration of a network of Windows NT workstations

: (")  ((")) 1+ rel>abs ;
: "    STATE @ IF  compile (") ,"
               ELSE  [compile] z" rel>abs
               THEN ; immediate

1000 constant MAXSbuffer  \ maximum size of any security related buffer

   :Class Registry <Super Object  \ to modify registry

         absRecord: connect
                int connectHandle
                    ;Record

         absRecord: Key
                int Handle
                    ;Record

         absRecord: Data
                int DWORDdata
                    ;Record

         absRecord: Disposition  \ superflous return value
                int dummy
                    ;Record


           : OpenKey { keyName -- }
                        key
                        KEY_WRITE
                        0
                        keyName
                        connectHandle
                        Call RegOpenKeyEx 0=win-abort" Failed to open key."
           ;

           : SetValue   ( len data type valueName -- )
                        0         \ reserved
                        swap      \ valueName
                        Handle
                        Call RegSetValueEx  0=win-abort" Failed to set value."

                        Handle
                        Call RegCloseKey  0=win-abort" Failed to close key."
           ;

           :M SetDWORD: { keyName valueName valueData -- }
                        keyName OpenKey

                        valueData to DWORDdata
                        4              \ 4 bytes of data
                        Data
                        REG_DWORD      \ type is dword
                        valueName SetValue

                        ;M

           :M SetSZ: { keyName valueName valueString -- }
                        keyName OpenKey

                        valueString asciiz->asc-len nip 1+ \ length of string
                        valueString
                        REG_SZ              \ type is null-terminated string
                        valueName SetValue

                        ;M

           :M SetESZ: { keyName valueName valueString -- }
                        keyName OpenKey

                        valueString asciiz->asc-len nip 1+ \ length of string
                        valueString
                        REG_EXPAND_SZ       \ type is expanded string
                        valueName SetValue

                        ;M


            :M NewKey: { keyName -- }
                        Disposition              \ result key disposition value
                        key                      \ result key handle
                        0                        \ default security structure
                        KEY_ALL_ACCESS           \ total access desired
                        REG_OPTION_NON_VOLATILE  \ special options flag
                        0                        \ class string
                        0                        \ reserved
                        keyName                  \ full key name
                        connectHandle
                        Call RegCreateKeyEx  0=win-abort" Failed to create key."
                        ;M

            : ClientName ( n -- zstr )
                 S>D <# # # #> DROP  z" \\ENGSW00" TUCK 7 + 2 CMOVE REL>ABS ;

            :M Connect:  ( n hkey -- )
                        connect
                        swap
                        rot ClientName
                        Call RegConnectRegistry  0=win-abort" Failed to connect."
                        ;M

            :M Disconnect:  ( -- )
                        connectHandle
                        Call RegCloseKey  0=win-abort" Failed to disconnect."
                        ;M

  ;Class


  :Class Process <Super Object      \ process privileges

          absRecord: Need  \ needed buffer length
               int Needed
             ;Record

          absRecord: Token
               int TokenHandle
             ;Record

          absRecord: TokenPrivileges \ process priviledge adjustment buffer
               int PrivilegeCount
              dint LUID
           4 bytes Attribute
       12 constant LUID_AND_ATTRIBUTES_size
     30 LUID_AND_ATTRIBUTES_size * bytes LUID_AND_ATTRIBUTES
             ;RecordSize: TokenPrivilegesSize

     :M All:   \ enable all process privileges

       Token
       TOKEN_ALL_ACCESS
       Call GetCurrentProcess
       Call OpenProcessToken  win-abort" Failed to open process token."

       Need
       TokenPrivilegesSize
       TokenPrivileges
       3               \ TOKEN_INFORMATION_CLASS enumerator TokenPrivileges
       TokenHandle
       Call GetTokenInformation   win-abort" Failed to get token privileges."

       \ enable all attributes in the token
       Attribute
       PrivilegeCount 0 DO
         SE_PRIVILEGE_ENABLED SE_PRIVILEGE_ENABLED_BY_DEFAULT or over !
         LUID_AND_ATTRIBUTES_size +
       LOOP drop

       0         \ ReturnLength not needed
       0         \ PreviousState not needed
       0         \ BufferLength not needed
       TokenPrivileges  \ address of list of privileges to be changed
       0         \ do not disable privileges
       TokenHandle
       Call AdjustTokenPrivileges  win-abort" Failed to adjust privilege."
     ;M

  ;Class


  :Class FileSecurity <Super Object    \ to configure file security
                                       \ ownership and access rights
        MAXSbuffer absbytes fileSD     \ file security descriptor
        MAXSbuffer absbytes accessSD   \ security descriptor access rights
        MAXSbuffer absbytes ownerSID   \ security identifier for owner
        MAXSbuffer absbytes accessSID  \ security identifier for access control entry
        MAXSbuffer absbytes Domain     \ buffer for domain name
        MAXSbuffer absbytes ACL        \ access control list

          absRecord: Need  \ needed buffer length
               int Needed
             ;Record

          absRecord: DomainLength   \ length of name in domain name buffer
               int DomainLengthAvailable
             ;Record

          absRecord: pFileSID    \ pointer to file security identifier
               int FileSID
             ;Record

          absRecord: pType    \ some superflous type value
               int type
             ;Record

          absRecord: Default  \ another superfluous return value
               int lixo
             ;Record

     : LookupName { AccountName SID -- }   \ get SID from account name
        pType
        MAXSbuffer to DomainLengthAvailable  DomainLength
        Domain
        MAXSbuffer to Needed  Need
        SID
        AccountName
        0                    \ local machine
        Call LookupAccountName win-abort" Failed to get SID for account name."
        Needed MAXSbuffer <> abort" SID buffer too small."
     ;

     :M Owner: ( Accountname -- )
               ownerSID LookupName


               ;M

     :M OwnerOk?: { FileName -- f }
               Need
               MAXSbuffer
               fileSD
               OWNER_SECURITY_INFORMATION
               FileName 
               Call GetFileSecurity 0=
               IF  Call GetLastError ERROR_ACCESS_DENIED =
                   IF    False           \ owner not o.k. if access denied
                   ELSE  0 win-abort" Failed to get file owner SD."
                   THEN
               ELSE
                   Needed abort" SD buffer too small."

                   Default
                   pFileSID
                   fileSD
                   Call GetSecurityDescriptorOwner
                                       win-abort" Failed to get file SD Owner."

                   FileSID
                   ownerSID
                   Call EqualSid
               THEN
              ;M

     : Access { AccountName mask -- }  \ create SD containing new ACL
           \ the ACL contains an ACE for total access for the owner SID
           \              and an ACE for masked access for AccountName

        ACL_REVISION
        MAXSbuffer
        ACL
        Call InitializeAcl  win-abort" Failed to initialize ACL."

        ownerSID
        FILE_ALL_ACCESS
        ACL_REVISION
        ACL
        Call AddAccessAllowedAce  win-abort" Failed to add owner ACE."

        AccountName accessSID LookupName

        accessSID         \ accessSID has access determined by mask
        mask
        ACL_REVISION
        ACL
        Call AddAccessAllowedAce  win-abort" Failed to add accessor ACE."

        \ create new absolute security descriptor
        SECURITY_DESCRIPTOR_REVISION
        accessSD
        Call InitializeSecurityDescriptor
                               win-abort" Failed to initialize access SD."

        0            \ default
        ownerSID     \ new owner
        accessSD
        Call SetSecurityDescriptorOwner
                                      win-abort" Failed to set SD Owner."
        0       \ default
        ACL
        1       \ present
        accessSD
        Call SetSecurityDescriptorDacl  win-abort" Failed to set SD DACL."
     ;

     :M   Change: FILE_GENERIC_READ  FILE_EXECUTE or
                  FILE_GENERIC_WRITE or
                  DELETE or
                  Access ;M

     :M    Read: FILE_GENERIC_READ FILE_EXECUTE or
                 Access ;M

     :M Set: { FileName -- }
        accessSD
        DACL_SECURITY_INFORMATION  OWNER_SECURITY_INFORMATION  or
        FileName
        Call SetFileSecurity  win-abort" Failed to set file access SD."
     ;M

  ;Class


  :Class DirBrowse <Super Object    \ to browse directory tree

      absRecord: FIND_DATA

            int dwFileAttributes
           dint ftCreationTime
           dint ftLastAccessTime
           dint ftLastWriteTime
            int nFileSizeHigh
            int nFileSizeLow
            int dwReserved0
            int dwReserved1
 max-path bytes cFileName
       14 bytes cAlternateFileName

        ;Record

            int FileProcess>   \ holds word to be performed on each file
            int AvoidList      \ holds list of directories and files to be avoided
        1 bytes NullList       \ empty list
 max-path bytes CdName         \ current directory
            int CutoffFromDirectoryPath  \ number of characters to discard from
                                         \ start of current directory path
                                         \ before comparing to avoid list
            int DirectoryProcess>    \ holds word to be performed on each directory
            int DirectoryProcessed   \ flag set if directory process is executed
                                     \ from within file process

   :M Dir?:  ( -- f )   \ is it a directory ?
             dwFileAttributes FILE_ATTRIBUTE_DIRECTORY and
             ;M

   :M Name: ( -- addr )
             cFileName REL>ABS ;M

   :M Show:  ( -- )          \ display last found file
                cFileName max-path 2dup 0 scan nip - type
                start/stop
                ;M

   :M Size: ( -- n ) nFileSizeLow ;M   \ bom para até 4 GB

   :M Cd:  ( -- addr len )
              CdName CdName REL>ABS max-path Call GetCurrentDirectory
              ;M

   :M Root?:  ( -- f )  \ are we in the root directory ?
              Cd: self nip 3 =  \ path name has 3 letters
              ;M


     : nextAvoidFile? ( str -- next_str f )
        count + 1+ aligned
        dup C@ ;

     : EqualName? ( str -- f )
        count cFileName asciiz->asc-len COMPARE 0= ;

     : avoidfile?  ( list -- nextlist f )   \ search for match in one directory
        dup count                                 \ directory name as addr,len
        Cd: self CutoffFromDirectoryPath /String  \ cut off the "\\ENGSWnn\" part
        COMPARE 0=                                \ direcory match ?
        IF             \ compare sublist to found file name
            False swap
            BEGIN nextAvoidFile? WHILE
                  dup EqualName?
                  rot or swap
            REPEAT
        ELSE           \ go to end of sublist
            False swap
            BEGIN nextAvoidFile? WHILE
            REPEAT
        THEN
        cell + swap  \ go to next sublist
     ;

     : avoid?  ( -- f )    \ search for matches in all directories of AvoidList
        cFileName W@  z" ."  W@ =                          \ is '.'
        cFileName  @  z" .."  @ xor 0xFFFFFF and 0=   or   \ or '..'
        AvoidList
        BEGIN  dup C@  WHILE
               avoidfile? rot or swap
        REPEAT
        drop
     ;

  :M Avoid: ( addr -- )
            to AvoidList
            ;M

  : ProcessFiles ( -- )            \ browse one level
              FIND_DATA
              z" *.*" REL>ABS
              call FindFirstFile
                 DUP INVALID_HANDLE_VALUE = not win-abort" Invalid file handle"
              avoid? not IF  FileProcess> execute  THEN

              BEGIN                  \ TOS is find handle
                 FIND_DATA
                 OVER
                 Call FindNextFile 1 =
              WHILE
                 avoid? not IF  Dir?: self not to DirectoryProcessed
                                FileProcess> execute
                                DirectoryProcessed not
                                IF  DirectoryProcess> execute  THEN
                            THEN
              REPEAT
              Call GetLastError
                 ERROR_NO_MORE_FILES <> not win-abort" File search error."

              Call FindClose win-abort" FindClose failed."
   ;
   
   : (ProcessDirectory)
             cFileName REL>ABS
             Call SetCurrentDirectory win-abort" Down directory failed."
             ProcessFiles
             " .." Call SetCurrentDirectory win-abort" Up directory failed."
   ;

   :M ProcessFiles: ( cfa -- )
              to FileProcess>
              ProcessFiles
              ;M

   :M ProcessDirectory:    \ descend into directory and browse
             DirectoryProcess> execute
             TRUE to DirectoryProcessed
             ;M

   :M ClassInit:  ( -- )
                  0 NullList C!
                  NullList to AvoidList
                  0 to CutoffFromDirectoryPath
                  ['] noop to FileProcess>
                  ['] (ProcessDirectory) to DirectoryProcess>
                  ;M

  ;Class


  :Class StudentDirBrowse <Super DirBrowse \ to browse student directory tree

     :M StudentDir?: ( -- f )   \ is it a student's directory ?
                     Dir?: self
                     \ directory name has 8 characters ?
                     Name: self  asciiz->asc-len nip 8 =       and
                     \ directory name starts with letter 'g' ?
                     cFileName C@  ASCII g  =                  and
                     \ second to eighth character is a digit ?
                     8 1 DO   cFileName I + C@ is-digit        and    LOOP
                     ;M

     :M Extension?: ( addr -- f )    \ is file extension in list addr ?
                     Name: self asciiz->asc-len 4 - + @   \ file extension
                     False                                \ flag
                     rot count bounds                     \ extension list
                     DO  over I @ = or  4 +LOOP
                     nip   \ discard file extension
                     ;M

  ;Class



  :Class  RemoteDirBrowse  <Super DirBrowse \ to browse remote system disc

            int computer#

     : ClientC$ ( n -- zstr )
         10 to CutoffFromDirectoryPath
         S>D <# # # #> DROP  z" \\ENGSW__\C$" TUCK 7 + 2 CMOVE ;

    :M ShowC$: ( -- )
              computer# ClientC$ ASCIIz->ASC-LEN TYPE ;M

    :M SetC$: ( n -- )
              dup to computer#
              ClientC$ REL>ABS
              Call SetCurrentDirectory win-abort" Client C: disc off line."
              ;M

    :M SeeC$: ( n -- )
              dup to computer#
              ClientC$ REL>ABS
              Call SetCurrentDirectory 0=
              IF   CR ShowC$: self ."  off line."
              THEN
              ;M

  ;Class

\S End of NTNetLib

