initial comit of groups, users, and utmpx
Doug Coleman
parent
9228d367a1
commit
5916fcea75
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings io.encodings.utf8
|
||||
io.unix.backend kernel math sequences splitting unix strings
|
||||
combinators.short-circuit byte-arrays combinators qualified
|
||||
accessors math.parser fry assocs namespaces continuations ;
|
||||
IN: unix.groups
|
||||
|
||||
QUALIFIED: grouping
|
||||
|
||||
TUPLE: group id name passwd members ;
|
||||
|
||||
SYMBOL: group-cache
|
||||
|
||||
GENERIC: group-struct ( obj -- group )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: group-members ( group-struct -- seq )
|
||||
group-gr_mem
|
||||
[ dup { [ ] [ *void* ] } 1&& ]
|
||||
[
|
||||
dup *void* utf8 alien>string
|
||||
[ alien-address "char**" heap-size + <alien> ] dip
|
||||
] [ ] produce nip ;
|
||||
|
||||
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
|
||||
"group" <c-object> tuck 1024
|
||||
[ <byte-array> ] keep f <void*> ;
|
||||
|
||||
M: integer group-struct ( id -- group )
|
||||
(group-struct) getgrgid_r io-error ;
|
||||
|
||||
M: string group-struct ( string -- group )
|
||||
(group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
|
||||
|
||||
: group-struct>group ( group-struct -- group )
|
||||
[ \ group new ] dip
|
||||
{
|
||||
[ group-gr_name >>name ]
|
||||
[ group-gr_passwd >>passwd ]
|
||||
[ group-gr_gid >>id ]
|
||||
[ group-members >>members ]
|
||||
} cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: group-name ( id -- string )
|
||||
dup group-cache get [
|
||||
at
|
||||
] [
|
||||
group-struct group-gr_name
|
||||
] if*
|
||||
[ nip ] [ number>string ] if* ;
|
||||
|
||||
: group-id ( string -- id )
|
||||
group-struct group-gr_gid ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >groups ( byte-array n -- groups )
|
||||
[ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: user-groups ( string -- seq )
|
||||
#! first group is -1337, legacy unix code
|
||||
-1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
|
||||
<int> [ getgrouplist io-error ] 2keep
|
||||
[ 4 tail-slice ] [ *int 1- ] bi* >groups ;
|
||||
|
||||
: all-groups ( -- seq )
|
||||
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
|
||||
|
||||
: with-group-cache ( quot -- )
|
||||
all-groups [ [ id>> ] keep ] H{ } map>assoc
|
||||
group-cache rot with-variable ; inline
|
||||
|
||||
: real-group-id ( -- id )
|
||||
getgid ; inline
|
||||
|
||||
: real-group-name ( -- string )
|
||||
real-group-id group-name ; inline
|
||||
|
||||
: effective-group-id ( -- string )
|
||||
getegid ; inline
|
||||
|
||||
: effective-group-name ( -- string )
|
||||
effective-group-id group-name ; inline
|
||||
|
||||
GENERIC: set-real-group ( obj -- )
|
||||
|
||||
GENERIC: set-effective-group ( obj -- )
|
||||
|
||||
: with-real-group ( string/id quot -- )
|
||||
'[ _ set-real-group @ ]
|
||||
real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
|
||||
|
||||
: with-effective-group ( string/id quot -- )
|
||||
'[ _ set-effective-group @ ]
|
||||
effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (set-real-group) ( id -- )
|
||||
setgid io-error ; inline
|
||||
|
||||
: (set-effective-group) ( id -- )
|
||||
setegid io-error ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: string set-real-group ( string -- )
|
||||
group-id (set-real-group) ;
|
||||
|
||||
M: integer set-real-group ( id -- )
|
||||
(set-real-group) ;
|
||||
|
||||
M: integer set-effective-group ( id -- )
|
||||
(set-effective-group) ;
|
||||
|
||||
M: string set-effective-group ( string -- )
|
||||
group-id (set-effective-group) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators accessors kernel unix unix.users
|
||||
system ;
|
||||
IN: unix.users.bsd
|
||||
|
||||
TUPLE: bsd-passwd < passwd change class expire fields ;
|
||||
|
||||
M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ;
|
||||
|
||||
M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
|
||||
[ call-next-method ] keep
|
||||
{
|
||||
[ passwd-pw_change >>change ]
|
||||
[ passwd-pw_class >>class ]
|
||||
[ passwd-pw_shell >>shell ]
|
||||
[ passwd-pw_expire >>expire ]
|
||||
[ passwd-pw_fields >>fields ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings io.encodings.utf8
|
||||
io.unix.backend kernel math sequences splitting unix strings
|
||||
combinators.short-circuit grouping byte-arrays combinators
|
||||
accessors math.parser fry assocs namespaces continuations
|
||||
vocabs.loader system ;
|
||||
IN: unix.users
|
||||
|
||||
TUPLE: passwd username password uid gid gecos dir shell ;
|
||||
|
||||
HOOK: new-passwd os ( -- passwd )
|
||||
HOOK: passwd>new-passwd os ( passwd -- new-passwd )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: unix new-passwd ( -- passwd )
|
||||
passwd new ;
|
||||
|
||||
M: unix passwd>new-passwd ( passwd -- seq )
|
||||
[ new-passwd ] dip
|
||||
{
|
||||
[ passwd-pw_name >>username ]
|
||||
[ passwd-pw_passwd >>password ]
|
||||
[ passwd-pw_uid >>uid ]
|
||||
[ passwd-pw_gid >>gid ]
|
||||
[ passwd-pw_gecos >>gecos ]
|
||||
[ passwd-pw_dir >>dir ]
|
||||
[ passwd-pw_shell >>shell ]
|
||||
} cleave ;
|
||||
|
||||
: with-pwent ( quot -- )
|
||||
[ endpwent ] [ ] cleanup ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: all-users ( -- seq )
|
||||
[
|
||||
[ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
|
||||
] with-pwent ;
|
||||
|
||||
SYMBOL: passwd-cache
|
||||
|
||||
: with-passwd-cache ( quot -- )
|
||||
all-users [ [ uid>> ] keep ] H{ } map>assoc
|
||||
passwd-cache swap with-variable ; inline
|
||||
|
||||
GENERIC: user-passwd ( obj -- passwd )
|
||||
|
||||
M: integer user-passwd ( id -- passwd/f )
|
||||
passwd-cache get
|
||||
[ at ] [ getpwuid passwd>new-passwd ] if* ;
|
||||
|
||||
M: string user-passwd ( string -- passwd/f )
|
||||
getpwnam dup [ passwd>new-passwd ] when ;
|
||||
|
||||
: username ( id -- string )
|
||||
user-passwd username>> ;
|
||||
|
||||
: username-id ( string -- id )
|
||||
user-passwd username>> ;
|
||||
|
||||
: real-username-id ( -- string )
|
||||
getuid ; inline
|
||||
|
||||
: real-username ( -- string )
|
||||
real-username-id username ; inline
|
||||
|
||||
: effective-username-id ( -- string )
|
||||
geteuid username ; inline
|
||||
|
||||
: effective-username ( -- string )
|
||||
effective-username-id username ; inline
|
||||
|
||||
GENERIC: set-real-username ( string/id -- )
|
||||
|
||||
GENERIC: set-effective-username ( string/id -- )
|
||||
|
||||
: with-real-username ( string/id quot -- )
|
||||
'[ _ set-real-username @ ]
|
||||
real-username-id '[ _ set-real-username ]
|
||||
[ ] cleanup ; inline
|
||||
|
||||
: with-effective-username ( string/id quot -- )
|
||||
'[ _ set-effective-username @ ]
|
||||
effective-username-id '[ _ set-effective-username ]
|
||||
[ ] cleanup ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (set-real-username) ( id -- )
|
||||
setuid io-error ; inline
|
||||
|
||||
: (set-effective-username) ( id -- )
|
||||
seteuid io-error ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: string set-real-username ( string -- )
|
||||
username-id (set-real-username) ;
|
||||
|
||||
M: integer set-real-username ( id -- )
|
||||
(set-real-username) ;
|
||||
|
||||
M: integer set-effective-username ( id -- )
|
||||
(set-effective-username) ;
|
||||
|
||||
M: string set-effective-username ( string -- )
|
||||
username-id (set-effective-username) ;
|
||||
|
||||
os {
|
||||
{ [ dup bsd? ] [ drop "unix.users.bsd" require ] }
|
||||
{ [ dup linux? ] [ drop ] }
|
||||
} cond
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test unix.utmpx.macosx ;
|
||||
IN: unix.utmpx.macosx.tests
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.bsd.macosx ;
|
||||
IN: unix.utmpx.macosx
|
||||
|
||||
! empty
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test unix.utmpx.netbsd ;
|
||||
IN: unix.utmpx.netbsd.tests
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.utmpx unix.bsd.netbsd accessors
|
||||
unix.utmpx system kernel unix combinators ;
|
||||
IN: unix.utmpx.netbsd
|
||||
|
||||
TUPLE: netbsd-utmpx-record < utmpx-record termination exit
|
||||
sockaddr ;
|
||||
|
||||
M: netbsd new-utmpx-record ( -- utmpx-record )
|
||||
netbsd-utmpx-record new ;
|
||||
|
||||
M: netbsd utmpx>utmpx-record ( utmpx -- record )
|
||||
[ new-utmpx-record ] keep
|
||||
{
|
||||
[
|
||||
utmpx-ut_exit
|
||||
[ exit_struct-e_termination >>termination ]
|
||||
[ exit_struct-e_exit >>exit ] bi
|
||||
]
|
||||
[ utmpx-ut_ss >>sockaddr ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax combinators continuations
|
||||
io.encodings.string io.encodings.utf8 kernel sequences strings
|
||||
unix calendar system accessors unix.time calendar.unix
|
||||
vocabs.loader ;
|
||||
IN: unix.utmpx
|
||||
|
||||
: EMPTY 0 ; inline
|
||||
: RUN_LVL 1 ; inline
|
||||
: BOOT_TIME 2 ; inline
|
||||
: OLD_TIME 3 ; inline
|
||||
: NEW_TIME 4 ; inline
|
||||
: INIT_PROCESS 5 ; inline
|
||||
: LOGIN_PROCESS 6 ; inline
|
||||
: USER_PROCESS 7 ; inline
|
||||
: DEAD_PROCESS 8 ; inline
|
||||
: ACCOUNTING 9 ; inline
|
||||
: SIGNATURE 10 ; inline
|
||||
: SHUTDOWN_TIME 11 ; inline
|
||||
|
||||
FUNCTION: void setutxent ( ) ;
|
||||
FUNCTION: void endutxent ( ) ;
|
||||
FUNCTION: utmpx* getutxent ( ) ;
|
||||
FUNCTION: utmpx* getutxid ( utmpx* id ) ;
|
||||
FUNCTION: utmpx* getutxline ( utmpx* line ) ;
|
||||
FUNCTION: utmpx* pututxline ( utmpx* utx ) ;
|
||||
|
||||
TUPLE: utmpx-record user id line pid type timestamp host ;
|
||||
|
||||
HOOK: new-utmpx-record os ( -- utmpx-record )
|
||||
|
||||
HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record )
|
||||
|
||||
: memory>string ( alien n -- string )
|
||||
memory>byte-array utf8 decode [ 0 = ] trim-right ;
|
||||
|
||||
M: unix new-utmpx-record
|
||||
utmpx-record new ;
|
||||
|
||||
M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
|
||||
[ new-utmpx-record ] dip
|
||||
{
|
||||
[ utmpx-ut_user _UTX_USERSIZE memory>string >>user ]
|
||||
[ utmpx-ut_id _UTX_IDSIZE memory>string >>id ]
|
||||
[ utmpx-ut_line _UTX_LINESIZE memory>string >>line ]
|
||||
[ utmpx-ut_pid >>pid ]
|
||||
[ utmpx-ut_type >>type ]
|
||||
[ utmpx-ut_tv timeval>unix-time >>timestamp ]
|
||||
[ utmpx-ut_host _UTX_HOSTSIZE memory>string >>host ]
|
||||
} cleave ;
|
||||
|
||||
: with-utmpx ( quot -- )
|
||||
setutxent [ endutxent ] [ ] cleanup ; inline
|
||||
|
||||
: all-utmpx ( -- seq )
|
||||
[
|
||||
[ getutxent dup ]
|
||||
[ utmpx>utmpx-record ]
|
||||
[ drop ] produce
|
||||
] with-utmpx ;
|
||||
|
||||
os {
|
||||
{ macosx [ "unix.utmpx.macosx" require ] }
|
||||
{ netbsd [ "unix.utmpx.netbsd" require ] }
|
||||
} case
|
||||
Loading…
Reference in New Issue