# systemd user units (as home-manager models them) -> GNU Shepherd services.
#
# Fail-closed by design: every [Section] Key must be either translated with
# the same semantics, or on the explicit `ignoredKeys` list below (keys that
# don't change what runs or with what privileges). Anything else is an
# eval-time error, unless the user acknowledges it per unit via
# `targets.guix.shepherd.unenforced`, in which case it's dropped *with a
# build warning*. Sandboxing (Protect*, Private*, SystemCallFilter, ...) is
# deliberately never translated: a service that declares it is relying on it.
{ lib, setpriv }:
let
  inherit (lib)
    concatStringsSep concatMapStringsSep concatMapStrings concatMap mapAttrs mapAttrsToList
    filterAttrs attrNames hasSuffix removeSuffix optional optionals
    optionalString elem toList last unique;

  # ---------------------------------------------------------------- helpers

  # JSON string escapes are a subset of Guile's (\" \\ \n \uXXXX).
  q = builtins.toJSON;
  sym = s: "(string->symbol ${q s})";

  # HM's unit types leave null / [] placeholders for typed-but-unset keys
  # (Description, Documentation, X-*-Triggers, Environment, ExecStart); HM's
  # own INI renderer drops them, so do the same.
  clean = unit:
    filterAttrs (_: s: s != { })
      (mapAttrs (_: filterAttrs (_: v: v != null && v != [ ])) unit);

  str = v: if builtins.isBool v then (if v then "true" else "false") else toString v;
  # Scalar keys: systemd's last assignment wins.
  scalar = v: str (last (toList v));
  isTrue = v: elem (scalar v) [ "true" "yes" "on" "1" ];

  # ------------------------------------------------------- key allowlists

  # Keys with no effect on what runs, how, or with what privileges.
  ignoredKeys = {
    Unit = [
      "Description" # consumed as #:documentation
      "Documentation"
      "After" # pure ordering; dependencies below imply ordering in Shepherd
      "Before"
      "RefuseManualStart"
      "RefuseManualStop"
      "X-SwitchMethod"
    ];
    Service = [ "ExecReload" ]; # only reachable via `systemctl reload`
    Socket = [ ];
    Install = [ ];
  };

  limitMap = {
    LimitCPU = "cpu"; LimitFSIZE = "fsize"; LimitDATA = "data";
    LimitSTACK = "stack"; LimitCORE = "core"; LimitRSS = "rss";
    LimitNOFILE = "nofile"; LimitAS = "as"; LimitNPROC = "nproc";
    LimitMEMLOCK = "memlock";
  };

  translatedKeys = {
    # Triggers are embedded in the generated file, so a trigger change is a
    # content change and activation reloads the service (reload -> restart,
    # the conservative direction).
    Unit = [ "Wants" "Requires" "BindsTo" "PartOf" "X-Restart-Triggers" "X-Reload-Triggers" ];
    Service = [
      "Type" "ExecStart" "Environment" "WorkingDirectory" "Restart"
      "RestartSec" "UMask" "NoNewPrivileges"
    ] ++ attrNames limitMap;
    Socket = [
      "ListenStream" "FileDescriptorName" "Service" "Accept"
      "SocketMode" "DirectoryMode"
    ];
    Install = [ "WantedBy" ];
  };

  sectionsFor = kind: [ "Unit" "Install" (if kind == "service" then "Service" else "Socket") ];

  # ----------------------------------------------------- systemd specifiers

  specExprs = {
    t = ''(getenv "XDG_RUNTIME_DIR")'';
    h = ''(getenv "HOME")'';
    U = "(number->string (getuid))";
    u = "(passwd:name (getpwuid (getuid)))";
    "%" = q "%";
  };
  specParts = s: builtins.split "%(.)" s;
  badSpecs = s:
    concatMap
      (p: optional (builtins.isList p && !(specExprs ? ${builtins.head p})) "%${builtins.head p}")
      (specParts s);
  # -> Scheme expression, evaluated at service start (not at load).
  expand = s:
    let
      exprs = concatMap
        (p: if builtins.isList p then [ specExprs.${builtins.head p} ] else optional (p != "") (q p))
        (specParts s);
    in
    if exprs == [ ] then q ""
    else if builtins.length exprs == 1 then builtins.head exprs
    else "(string-append ${concatStringsSep " " exprs})";

  # ------------------------------------------------- command-line splitting

  # systemd quoting, minus the parts we refuse: backslash escapes (C-style in
  # systemd, so not a literal-char escape) and $VAR expansion are rejected by
  # cmdErrors rather than approximated.
  tokenize = s:
    let
      ws = c: c == " " || c == "\t" || c == "\n";
      step = st: c:
        if st.q != null then
          (if c == st.q then st // { q = null; } else st // { cur = st.cur + c; })
        else if c == "\"" || c == "'" then
          st // { q = c; cur = if st.cur == null then "" else st.cur; }
        else if ws c then
          (if st.cur == null then st else st // { out = st.out ++ [ st.cur ]; cur = null; })
        else
          st // { cur = (if st.cur == null then "" else st.cur) + c; };
      end = builtins.foldl' step { out = [ ]; cur = null; q = null; }
        (lib.stringToCharacters s);
    in
    {
      tokens = end.out ++ optional (end.cur != null) end.cur;
      unterminated = end.q != null;
    };

  cmdErrors = what: s:
    let t = tokenize s; first = if t.tokens == [ ] then "" else builtins.head t.tokens;
    in
    optional (t.tokens == [ ]) "${what} is empty"
    ++ optional t.unterminated "${what} has an unterminated quote"
    ++ optional (lib.hasInfix "\\" s) "${what} uses backslash escapes (not translated)"
    ++ optional (lib.hasInfix "$" s) "${what} uses $VAR expansion (not translated)"
    ++ optional (builtins.match "[-@:+!|].*" first != null)
      "${what} uses an executable prefix (${builtins.substring 0 1 first}) with no Shepherd equivalent"
    ++ map (sp: "${what} uses unsupported specifier ${sp}") (badSpecs s);

  # ----------------------------------------------------------- validation

  octal = s: builtins.match "0?[0-7]{3,4}" s != null;
  limitVal = s: builtins.match "(infinity|[0-9]+)(:(infinity|[0-9]+))?" s != null;
  seconds = s: builtins.match "([0-9]+)s?" s;

  keyErrors = { kind, name, unit, unenforced }:
    let
      full = "${name}.${kind}";
      allowed = sectionsFor kind;
    in
    concatMap
      (sec:
        if !(elem sec allowed) then
          optional (!(elem "${sec}.*" unenforced)) "${full}: section [${sec}] has no Shepherd equivalent"
        else
          concatMap
            (key: optional
              (!(elem key (translatedKeys.${sec} ++ ignoredKeys.${sec}))
                && !(elem "${sec}.${key}" unenforced))
              "${full}: ${sec}.${key} has no Shepherd equivalent")
            (attrNames unit.${sec}))
      (attrNames unit);

  # Names Shepherd knows about, used to resolve dependency edges.
  graphicalSym = "hm-graphical-session";

  # Which service a socket unit activates (systemd default: same name).
  socketTarget = sname: sock:
    removeSuffix ".service" (scalar (sock.Socket.Service or "${sname}.service"));

  resolveDep = { self, services, sockets }: dep:
    if dep == "graphical-session.target" then { ok = graphicalSym; }
    else if hasSuffix ".service" dep && services ? ${removeSuffix ".service" dep} then
      { ok = removeSuffix ".service" dep; }
    else if hasSuffix ".socket" dep && sockets ? ${removeSuffix ".socket" dep} then
      let target = socketTarget (removeSuffix ".socket" dep) sockets.${removeSuffix ".socket" dep};
      in if target == self then { skip = true; } else { ok = target; }
    else { err = "dependency ${dep} is not a translated unit"; };

  serviceErrors = { name, unit, services, sockets, unenforced }:
    let
      full = "${name}.service";
      svc = unit.Service or { };
      exec = toList (svc.ExecStart or [ ]);
      deps = concatMap (k: toList (unit.Unit.${k} or [ ])) [ "Wants" "Requires" "BindsTo" "PartOf" ];
      envTokens = concatMap (e: (tokenize (str e)).tokens) (toList (svc.Environment or [ ]));
      limits = filterAttrs (k: _: limitMap ? ${k}) svc;
    in
    keyErrors { kind = "service"; inherit name unit unenforced; }
    ++ optional (!(elem (scalar (svc.Type or "simple")) [ "simple" "exec" ]))
      "${full}: Type=${scalar svc.Type} is not translated (only simple/exec)"
    ++ optional (builtins.length exec != 1)
      "${full}: needs exactly one ExecStart (has ${toString (builtins.length exec)})"
    ++ concatMap (cmdErrors "${full}: ExecStart") (map str exec)
    ++ concatMap (e: optional (!(lib.hasInfix "=" e)) "${full}: Environment entry '${e}' is not K=V") envTokens
    ++ concatMap (e: map (sp: "${full}: Environment uses unsupported specifier ${sp}") (badSpecs e)) envTokens
    ++ optional (lib.any (e: lib.hasInfix "$" e || lib.hasInfix "\\" e) (map str (toList (svc.Environment or [ ]))))
      "${full}: Environment uses escapes or $VAR (not translated)"
    ++ optionals (svc ? WorkingDirectory) (
      let d = scalar svc.WorkingDirectory; in
      optional (lib.hasPrefix "-" d) "${full}: WorkingDirectory=-... (ignore-missing) is not translated"
      ++ map (sp: "${full}: WorkingDirectory uses unsupported specifier ${sp}") (badSpecs d))
    ++ optional (svc ? Restart && !(elem (scalar svc.Restart) [ "no" "always" "on-failure" "on-abnormal" ]))
      "${full}: Restart=${scalar svc.Restart} is not translated"
    ++ optional (svc ? RestartSec && seconds (scalar svc.RestartSec) == null)
      "${full}: RestartSec must be whole seconds"
    ++ optional (svc ? UMask && !(octal (scalar svc.UMask))) "${full}: UMask must be octal"
    ++ mapAttrsToList (k: v: "${full}: ${k}=${scalar v} is not a plain integer/infinity limit")
      (filterAttrs (_: v: !(limitVal (scalar v))) limits)
    ++ concatMap (d: let r = resolveDep { self = name; inherit services sockets; } d;
                     in optional (r ? err) "${full}: ${r.err}") deps
    ++ concatMap (t: optional (!(elem t [ "default.target" "graphical-session.target" ]))
                   "${full}: WantedBy=${t} is not translated")
      (toList (unit.Install.WantedBy or [ ]));

  socketErrors = { name, unit, services, unenforced }:
    let
      full = "${name}.socket";
      sock = unit.Socket or { };
      target = socketTarget name unit;
      paths = map str (toList (sock.ListenStream or [ ]));
      dirMode = if sock ? DirectoryMode then scalar sock.DirectoryMode else null;
    in
    keyErrors { kind = "socket"; inherit name unit unenforced; }
    ++ optional (!(services ? ${target})) "${full}: activates ${target}.service, which is not translated"
    ++ optional (paths == [ ]) "${full}: no ListenStream"
    ++ concatMap (p: optional (builtins.match "(/|%t|%h).*" p == null)
                   "${full}: ListenStream=${p} is not a unix socket path (TCP/UDP not translated)")
      paths
    ++ concatMap (p: map (sp: "${full}: ListenStream uses unsupported specifier ${sp}") (badSpecs p)) paths
    ++ optional (sock ? Accept && isTrue sock.Accept) "${full}: Accept=yes (inetd-style) is not translated"
    ++ optional (dirMode != null && !(octal dirMode)) "${full}: DirectoryMode must be octal"
    # Shepherd can set the parent directory's mode but not the socket's. A
    # 0700 parent makes the socket's own mode moot; anything looser doesn't.
    ++ optional (sock ? SocketMode && !(elem dirMode [ "0700" "700" ]))
      "${full}: SocketMode is only honoured with DirectoryMode=0700 (Shepherd can't chmod the socket)"
    ++ concatMap (t: optional (t != "sockets.target") "${full}: WantedBy=${t} is not translated")
      (toList (unit.Install.WantedBy or [ ]));

  # ------------------------------------------------------------- emission

  prelude = ''
    (use-modules (shepherd service))

    ;; Unit Environment= first, then Shepherd's *current* environment (which
    ;; the compositor bridge updates via `herd eval root (setenv ...)`).
    (define (hm-env overrides)
      (let ((keys (map (lambda (kv) (substring kv 0 (string-index kv #\=)))
                       overrides)))
        (append overrides
                (filter (lambda (kv)
                          (let ((i (string-index kv #\=)))
                            (not (and i (member (substring kv 0 i) keys)))))
                        (environ)))))
  '';

  limitExpr = v:
    let
      parts = lib.splitString ":" (scalar v);
      one = x: if x == "infinity" then "#f" else x;
    in
    if builtins.length parts == 1 then "${one (builtins.head parts)} ${one (builtins.head parts)}"
    else "${one (builtins.elemAt parts 0)} ${one (builtins.elemAt parts 1)}";

  octalExpr = s: "#o${lib.removePrefix "0" s}";

  emitService = { name, unit, services, sockets }:
    let
      svc = unit.Service or { };
      mySockets = filterAttrs (sn: s: socketTarget sn s == name) sockets;
      socketActivated = mySockets != { };

      argv0 = (tokenize (str (builtins.head (toList svc.ExecStart)))).tokens;
      argv = optionals (svc ? NoNewPrivileges && isTrue svc.NoNewPrivileges)
          [ "${setpriv}/bin/setpriv" "--no-new-privs" ]
        ++ argv0;
      cmd = "(list ${concatMapStringsSep " " expand argv})";

      env = concatMap (e: (tokenize (str e)).tokens) (toList (svc.Environment or [ ]));
      envExpr = "(hm-env (list ${concatMapStringsSep " " (kv:
          let i = lib.stringLength (builtins.head (lib.splitString "=" kv)); in
          "(string-append ${q (builtins.substring 0 (i + 1) kv)} ${expand (builtins.substring (i + 1) (-1) kv)})")
        env}))";

      deps = unique (concatMap
        (d: let r = resolveDep { self = name; inherit services sockets; } d;
            in optional (r ? ok) r.ok)
        (concatMap (k: toList (unit.Unit.${k} or [ ])) [ "Wants" "Requires" "BindsTo" "PartOf" ]));
      wantedBy = toList (unit.Install.WantedBy or [ ]);
      graphical = elem "graphical-session.target" wantedBy || elem graphicalSym deps;
      requirement = unique (deps ++ optional graphical graphicalSym);
      autostart = elem "default.target" wantedBy
        || lib.any (s: elem "sockets.target" (toList (s.Install.WantedBy or [ ]))) (lib.attrValues mySockets);

      limits = filterAttrs (k: _: limitMap ? ${k}) svc;
      opts = concatStringsSep "\n                "
        ([ "#:environment-variables ${envExpr}" ]
          ++ optional (svc ? WorkingDirectory)
            "#:directory ${let d = scalar svc.WorkingDirectory; in if d == "~" then specExprs.h else expand d}"
          ++ optional (svc ? UMask) "#:file-creation-mask ${octalExpr (scalar svc.UMask)}"
          ++ optional (limits != { }) "#:resource-limits (list ${concatStringsSep " "
                (mapAttrsToList (k: v: "(list '${limitMap.${k}} ${limitExpr v})") limits)})");

      endpoints = concatStringsSep "\n                     " (concatMap
        (sn:
          let
            s = mySockets.${sn}.Socket;
            fdName = scalar (s.FileDescriptorName or sn);
            dirMode = if s ? DirectoryMode then octalExpr (scalar s.DirectoryMode) else "#o755";
          in
          map (p: "(endpoint (make-socket-address AF_UNIX ${expand (str p)}) #:name ${q fdName} #:socket-directory-permissions ${dirMode})")
            (toList s.ListenStream))
        (attrNames mySockets));

      # Socket units keep listening after the daemon exits regardless of
      # Restart= (that's socket-activation semantics), hence respawn? here.
      respawn = socketActivated || elem (scalar (svc.Restart or "no")) [ "always" "on-failure" "on-abnormal" ];
      restartSec = if svc ? RestartSec then builtins.head (seconds (scalar svc.RestartSec)) else null;

      constructor =
        if socketActivated then ''
          (make-systemd-constructor ${cmd}
                 (list ${endpoints})
                 #:lazy-start? #t
                 ${opts})''
        else ''
          (make-forkexec-constructor ${cmd}
                 ${opts})'';
    in
    {
      inherit graphical autostart;
      text = ''
        ;; Generated by home-manager (targets.guix) from ${name}.service${
          optionalString socketActivated " + ${concatMapStringsSep ", " (s: "${s}.socket") (attrNames mySockets)}"
        }.
        ;; Do not edit; regenerated on every activation.${
          concatMapStrings (t: "\n;; trigger: ${str t}")
            (concatMap (k: toList (unit.Unit.${k} or [ ])) [ "X-Restart-Triggers" "X-Reload-Triggers" ])}
        ${prelude}
        (register-services
         (list
          (service (list ${sym name})
            #:documentation ${q (scalar (unit.Unit.Description or "${name} (from home-manager)"))}
            #:requirement (list ${concatMapStringsSep " " sym requirement})
            #:respawn? ${if respawn then "#t" else "#f"}${
              optionalString (restartSec != null) "\n    #:respawn-delay ${restartSec}"}
            ;; Constructed at start time so specifiers and the inherited
            ;; environment reflect the session at that moment.
            #:start (lambda args
                      (apply ${constructor}
                             args))
            #:stop ${if socketActivated then "(make-systemd-destructor)" else "(make-kill-destructor)"})))
        ${optionalString (autostart && !graphical) "\n(start-in-the-background (list ${sym name}))"}
      '';
    };

  graphicalSessionFile = ''
    ;; Generated by home-manager (targets.guix). Marker for graphical-session.target:
    ;; started by the compositor bridge after it pushes its environment into
    ;; Shepherd; stopping it stops every graphical service.
    (use-modules (shepherd service))
    (register-services
     (list (service (list ${sym graphicalSym})
             #:documentation "Graphical session (home-manager graphical-session.target)"
             #:start (const #t)
             #:stop (const #f))))
  '';
in
{
  inherit graphicalSym;

  # -> { errors, warnings, files = { "<name>.scm" = text; }, graphical = [ names ] }
  translate = { systemdUser, unenforced, ignoreUnits }:
    let
      keep = kind: units: filterAttrs (n: _: !(elem "${n}.${kind}" ignoreUnits)) (mapAttrs (_: clean) units);
      services = keep "service" (systemdUser.services or { });
      sockets = keep "socket" (systemdUser.sockets or { });
      unen = full: unenforced.${full} or [ ];

      # Units that make things happen on their own. Targets and slices are
      # inert unless something references them, and any such reference
      # (Wants=/WantedBy=/PartOf=/Slice=) is already an error above.
      otherKinds = [ "timers" "paths" "mounts" "automounts" ];
      otherErrors = concatMap
        (k: map (n: "${n}.${removeSuffix "s" k}: ${removeSuffix "s" k} units are not translated (add to targets.guix.shepherd.ignoreUnits to skip)")
          (attrNames (keep (removeSuffix "s" k) (systemdUser.${k} or { }))))
        otherKinds;

      errors =
        concatMap (n: serviceErrors { name = n; unit = services.${n}; inherit services sockets; unenforced = unen "${n}.service"; }) (attrNames services)
        ++ concatMap (n: socketErrors { name = n; unit = sockets.${n}; inherit services; unenforced = unen "${n}.socket"; }) (attrNames sockets)
        ++ otherErrors
        ++ concatMap (full: optional (!(services ? ${removeSuffix ".service" full}) && !(sockets ? ${removeSuffix ".socket" full}))
                       "targets.guix.shepherd.unenforced: ${full} is not a defined service/socket")
          (attrNames unenforced);

      warnings = concatMap
        (full: map (k: "targets.guix: ${full}: ${k} dropped (not enforced under Shepherd)") unenforced.${full})
        (attrNames unenforced);

      emitted = mapAttrs (n: u: emitService { name = n; unit = u; inherit services sockets; }) services;
    in
    {
      inherit errors warnings;
      graphical = attrNames (filterAttrs (_: e: e.graphical) emitted);
      files = { "${graphicalSym}.scm" = graphicalSessionFile; }
        // lib.mapAttrs' (n: e: lib.nameValuePair "${n}.scm" e.text) emitted;
    };
}