package Debian::AdduserCreateHomedir 3.157;
use 5.36.0;
use utf8;

use strict;
use warnings;
use Debian::AdduserLogging 3.157;
use Debian::AdduserCommon 3.157;
use Debian::AdduserRetvalues 3.157;

# Adduser module to create home dir and to copy skel
#
# Copyright (C) 2026 Marc Haber <mh+debian-packages@zugschlus.de>
#
# License: GPL-2+

use parent qw(Exporter);

use vars qw(@EXPORT $VAR1);

@EXPORT = (
   'create_homedir',
); 

sub create_homedir {
    my %params = @_;
    my $new_name = $params{new_name};
    my $home_dir = $params{home_dir};
    my $new_uid = $params{uid};
    my $primary_gid = $params{gid};
    my $copy_skeleton = $params{copy_skeleton};
    my $force_home = $params{force_home};
    my $authorized_keys = $params{authorized_keys} // [];
    my $system_user = $params{system_user};
    my $no_create_home = $params{no_create_home};
    my $encrypt_home = $params{encrypt_home};
    my $config = $params{config};

    log_trace("create_homedir(home_dir=%s, new_uid=%s, primary_gid=%s, copy_skeleton=%s, force_home=%s, system_user=%s, no_create_home=%s", $home_dir, $new_uid, $primary_gid, $copy_skeleton, $force_home, $system_user, $no_create_home);

    my $ecryptfs_setup_private;
    if (defined($encrypt_home)) {
        log_trace("encrypt_home is set");
        $ecryptfs_setup_private = &which('ecryptfs-setup-private', 1);
        unless (defined $ecryptfs_setup_private) {
            log_fatal("encrypt_home set but ecryptfs-setup-private not found. Package missing?");
            return( RET_EXEC_NOT_FOUND );
        }
    }

    if ($home_dir =~ /^\/+nonexistent(\/|$)/) {
        log_info(mtx("Not creating `%s'."), $home_dir);
        warn_no_keys($home_dir, $authorized_keys);
        return 0;
    }

    if ($no_create_home) {
        log_info(mtx("Not creating home directory `%s' as requested."), $home_dir);
        warn_no_keys($home_dir, $authorized_keys);
        return 0;
    }

    if (-e $home_dir) {
        log_trace("home_dir %s does already exist", $home_dir);
        if (!$system_user && !$force_home) {
            log_warn(mtx("The home directory `%s' already exists. Not touching this directory."), $home_dir);
            my @homedir_stat = stat($home_dir);
            if (($homedir_stat[4] != $new_uid) || ($homedir_stat[5] != $primary_gid)) {
                log_warn(mtx("Warning: The home directory `%s' does not belong to the user you are currently creating."), $home_dir);
            }
            warn_no_keys($home_dir, $authorized_keys);
            return 0;
        }
    }

    if( $force_home ) {
        log_info(mtx("Forcing home directory `%s' to new user as requested ..."), $home_dir);
    } else {
        log_info(mtx("Creating home directory `%s' ..."), $home_dir);
        mktree($home_dir) or do {
            log_err(gtx("Couldn't create home directory `%s': %s."), $home_dir, $!);
            return RET_INVALID_HOME_DIRECTORY;
        };
    }

    mktree($home_dir) or do {
        log_err(gtx("Couldn't create home directory `%s': %s."), $home_dir, $!);
        return RET_INVALID_HOME_DIRECTORY;
    };

    chown($new_uid, $primary_gid, $home_dir) or do {
        log_err("chown %s:%s %s: %s", $new_uid, $primary_gid, $home_dir, $!);
        return RET_WRONG_OBJECT_PROPERTIES;
    };

    # Determine if setgid bit should be applied
    my $setgid =  (defined $config->{setgid_home} && $config->{setgid_home} =~ /yes/i) ? 1 : 0;

    # Pick the correct dir_mode for the newly created home directory.
    # We can assume that both dir_mode and sys_dir_mode are valid octal,
    # with defaults already applied (AdduserCommon, read_config)
    my $dir_mode = $system_user ? $config->{"sys_dir_mode"} : $config->{"dir_mode"};

    # Convert to numeric octal
    $dir_mode = oct($dir_mode);

    # Apply setgid if requested
    $dir_mode |= 02000 if $setgid;

    chmod($dir_mode, $home_dir) or do {
        log_err("chmod %s %s: %s", $dir_mode, $home_dir, $!);
        return RET_WRONG_OBJECT_PROPERTIES;
    };

    if (defined($encrypt_home)) {
        log_info( mtx("Setting up encryption ...\n"));
        &systemcall($ecryptfs_setup_private, '-b', '-u', $new_name);
    }

    if ($config->{skel} && $copy_skeleton) {
        log_info(mtx("Copying files from `%s' ..."), $config->{skel});
        copy_skel(
            $config->{skel},
            $home_dir,
            $new_uid,
            $primary_gid,
            $setgid,
            $config->{skel_ignore_regex}
        ) and return RET_FILE_ERROR;
    }

    if (@$authorized_keys) {
        my $ret = install_authorized_keys($home_dir, $authorized_keys,
            $new_uid, $primary_gid, $dir_mode);
        return $ret if ($ret);
    }

    if (defined($encrypt_home)) {
        &systemcall("/bin/umount", $home_dir);
    }

    return RET_OK;
}

sub mktree {
    my ($tree) = @_;
    log_trace("mktree(tree=%s)", $tree);
    $tree =~ m{^(/[\w./-]*\$?)$} or return 0;
    $tree = $1;
    $tree =~ s{/+$}{};

    my $done = "";
    foreach my $part (split(m{/+}, $tree)) {
        log_trace("mktree tree part %s", $part);
        next if $part eq '';
        $done .= '/' . $part;
        next if -d $done;
        mkdir($done, 0755) or return 0;
    }
    return 1;
}

sub byte_string {
    my ($s) = @_;
    return pack("C*", unpack("C*", $s));  # force raw bytes
}

sub copy_skel {
    my ($skel, $home, $uid, $gid, $sgid, $ignore_re) = @_;
    log_trace("copy_skel(skel=%s, home=%s, uid=%s, gid=%s, sgid=%s, ignore_re=%s)", $skel, $home, $uid, $gid, $sgid, $ignore_re);

    # Convert base paths to raw bytes to prevent double UTF-8 encoding
    my $skel_bytes = byte_string($skel);
    my $home_bytes  = byte_string($home);

    return recurse_copy($skel_bytes, $home_bytes, "", $uid, $gid, $sgid, $ignore_re);
}

# this must handle UTF-8 file names just as byte strings without being
# smart. We can't do proper UTF-8 here.
sub recurse_copy {
    my ($src_base, $dst_base, $rel, $uid, $gid, $sgid, $ignore_re) = @_;

    log_trace("recurse_copy(src_base=%s, dst_base=%s, rel=%s, uid=%s, gid=%s, sgid=%s, ignore_re=%s)", $src_base, $dst_base, $rel // '', $uid, $gid, $sgid, $ignore_re);

    my $src = $rel ? "$src_base/$rel" : $src_base;

    # Untaint source path (allow any bytes except / or null)
    $src =~ m{^(/[^/\0]+(?:/[^/\0]+)*)$} or do {
        log_err("Invalid source path: %s", $src);
        return RET_INVALID_HOME_DIRECTORY;
    };
    $src = $1;
    log_trace("Processing directory: %s", $src);

    opendir(my $dh, $src) or do {
        log_err("opendir %s: %s", $src, $!);
        return RET_SYSTEMCALL_ERROR;
    };

    my @entries = grep { $_ ne '.' && $_ ne '..' && (!$ignore_re || !/$ignore_re/) } readdir($dh);
    closedir($dh);
    log_trace("Found entries: %s", join(", ", @entries));

    foreach my $entry (@entries) {
        log_trace("Processing entry: %s", $entry);

        # Untaint entry (allow any bytes except / or null)
        $entry =~ m{^([^/\0]+)$} or do {
            log_err("Invalid filename: %s", $entry);
            next;
        };
        $entry = $1;

        my $src_path = "$src/$entry";
        my $dst_path = ($rel ? "$dst_base/$rel" : $dst_base) . "/$entry";

        # Untaint destination path
        $dst_path =~ m{^(/[^/\0]+(?:/[^/\0]+)*)$} or do {
            log_err("Invalid destination path: %s", $dst_path);
            return RET_INVALID_HOME_DIRECTORY;
        };
        $dst_path = $1;
        log_trace("src_path=%s dst_path=%s", $src_path, $dst_path);

        if (-l $src_path) {
            # Symlink
            my $target = readlink($src_path) or do {
                log_err("readlink %s: %s", $src_path, $!);
                return RET_SYSTEMCALL_ERROR
            };
            $target =~ m{^([^/\0]+(?:/[^/\0]+)*)$} or do {
                log_err("Unsafe symlink: %s", $target);
                return RET_WRONG_OBJECT_PROPERTIES;
            };
            my ($cu, $cg) = ($>, $));
            ($>, $)) = ($uid, $gid);
            my $ok = symlink($1, $dst_path);
            my $err = $!;
            ($>, $)) = ($cu, $cg);
            if (!$ok) {
                log_err("error creating symlink %s: %s", $dst_path, $err);
                return RET_SYSTEMCALL_ERROR;
            }
            log_trace("Created symlink: %s -> %s", $dst_path, $target);

        } elsif (-d $src_path) {
            # Directory
            if (!-d $dst_path) {
                mkdir($dst_path, 0700) or do {
                    log_err("error in mkdir %s: %s", $dst_path, $!);
                    return RET_INVALID_HOME_DIRECTORY;
                };
                log_trace("Created directory: %s", $dst_path);
            }
            set_perms($src_path, $dst_path, $uid, $gid, $sgid) or return 0;
            recurse_copy($src_base, $dst_base, $rel ? "$rel/$entry" : $entry, $uid, $gid, $sgid, $ignore_re) and return 0;

        } elsif (-f $src_path) {
            # Regular file
            open(my $in, '<', $src_path) or do {
                log_err("error read-opening %s: %s", $src_path, $!);
                return RET_FILE_ERROR;
            };
            open(my $out, '>', $dst_path) or do {
                close($in);
                log_err("error write-opening %s: %s", $dst_path, $!);
                return RET_FILE_ERROR;
            };
            binmode($in);
            binmode($out);
            print $out $_ while <$in>;
            close($in);
            close($out) or do {
                log_err("error closing %s: %s", $dst_path, $!);
                return RET_FILE_ERROR;
            };
            set_perms($src_path, $dst_path, $uid, $gid, 0) or return 0;
            log_trace("Copied file: %s", $dst_path);
        }
    }

    log_trace("Finished processing directory: %s", $src);
    return RET_OK;
}


sub set_perms {
    my ($src, $dst, $uid, $gid, $sgid) = @_;
    log_trace("set_perms(src=%s, dst=%s, uid=%s, gid=%s, sgid=%s)", $src, $dst, $uid, $gid, $sgid);
    chown($uid, $gid, $dst) or do {
        log_err("chown %s: %s", $dst, $!);
        return 0;
    };
    my $perm = (stat($src))[2] & 07777;
    $perm |= 02000 if -d $src && ($perm & 010) && $sgid;
    chmod($perm, $dst) or do {
        log_err("chmod %s: %s", $dst, $!);
        return 0;
    };
    return 1;
}

sub warn_no_keys {
    my ($home_dir, $authorized_keys) = @_;
    return if (!@$authorized_keys);
    log_warn(mtx("Not installing authorized key(s) into `%s'."), $home_dir);
}

sub collect_authorized_keys {
    my ($authorized_keys) = @_;
    my @lines;

    foreach my $arg (@$authorized_keys) {
        if (! -f $arg) {
            push @lines, $arg;
            next;
        }
        my $fh;
        if (!open($fh, '<', $arg)) {
            log_warn(mtx("Cannot open `%s': %s. Not installing this key."),
                sanitize_string($arg, '[-_./a-zA-Z0-9]+', 1), $!);
            next;
        }
        while (my $line = <$fh>) {
            chomp $line;
            next if ($line =~ /^\s*$/);
            push @lines, $line;
        }
        close($fh);
    }

    return @lines;
}

sub install_authorized_keys {
    my ($home_dir, $authorized_keys, $new_uid, $primary_gid, $dir_mode) = @_;

    my @keys = collect_authorized_keys($authorized_keys);
    return RET_OK if (!@keys);

    my $sshdir = "$home_dir/.ssh";
    my $keyfile = "$sshdir/authorized_keys";
    log_info(mtx("Adding %d authorized key(s) to `%s' ..."), scalar(@keys), $keyfile);

    if (! -d $sshdir) {
        mkdir($sshdir, 0700) or do {
            log_err("mkdir %s: %s", $sshdir, $!);
            return RET_FILE_ERROR;
        };
    }

    my $fh;
    open($fh, '>>', $keyfile) or do {
        log_err("open %s: %s", $keyfile, $!);
        return RET_FILE_ERROR;
    };
    print {$fh} "$_\n" foreach (@keys);
    close($fh) or do {
        log_err("close %s: %s", $keyfile, $!);
        return RET_FILE_ERROR;
    };

    chown($new_uid, $primary_gid, $sshdir, $keyfile) == 2 or do {
        log_err("chown %s:%s %s: %s", $new_uid, $primary_gid, $sshdir, $!);
        return RET_WRONG_OBJECT_PROPERTIES;
    };
    chmod($dir_mode, $sshdir) or do {
        log_err("chmod %s %s: %s", $dir_mode, $sshdir, $!);
        return RET_WRONG_OBJECT_PROPERTIES;
    };
    chmod(0600, $keyfile) or do {
        log_err("chmod 0600 %s: %s", $keyfile, $!);
        return RET_WRONG_OBJECT_PROPERTIES;
    };

    return RET_OK;
}

1;

# Local Variables:
# mode:cperl
# End:

# vim: tabstop=4 shiftwidth=4 expandtab
