;;; cl-openbsd-security.lisp -- CL support for unveil(2) and pledge(2)

;; Maintainer: Philip Kaludercic <philip.kaludercic@fau.de>
;; Version: $Id: cl-openbsd-security.lisp,v 1.16 2024/08/01 13:08:36 oj14ozun Exp $
;; URL: https://wwwcip.cs.fau.de/~oj14ozun/src+etc/cl-openbsd-security.lisp

;; Copyright (c) 2019   Vaclav Synacek
;; Copyright (c) 2024   Philip Kaludercic

;; Permission to use, copy, modify, and distribute this software for any
;; purpose with or without fee is hereby granted, provided that the above
;; copyright notice and this permission notice appear in all copies.

;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

;;; Commentary

;; This script adds support for the hardening OpenBSD-specific
;; system-calls pledge(2) and unveil(2).  Consult the OpenBSD
;; documentation for details on how/when to use these functions.

;; Note that this file is a fork of [0], and is intentionally not
;; backwards compatible!
;; 
;; [0] https://github.com/VaclavSynacek/cl-openbsd-security/

;;; Code:

(ql:quickload :cffi)			;https://cffi.common-lisp.dev/

(defpackage :cl-openbsd-security
  (:nicknames :openbsd)
  (:use :common-lisp :cffi)
  (:export :pledge :unveil))

(in-package :cl-openbsd-security)

(defmacro ensure (expr)
  `(unless (zerop ,expr)
     (let ((errno (mem-ref (foreign-funcall "__errno" (:pointer :int)) :int)))
       (error "~A: ~A" ',(first expr) (foreign-funcall "strerror" :int errno :string)))))


;; pledge(2), https://man.openbsd.org/pledge

(defconstant +pledges+
  (loop :for arg :in '(:audio :bpf :chown :cpath :disklabel :dns :dpath :drm
		       :error :exec :fattr :flock :getpw :id :inet :mcast :pf
		       :proc (:prot-exec . "prot_exec") :ps :recvfd :route
		       :rpath :sendfd :settime :stdio :tape :tmppath :tty :unix
		       :unveil :video :vminfo :vmm :wpath :wroute)
	:collect (if (consp arg) arg (cons arg (symbol-name arg)))))

(defcfun (pledge-raw "pledge") :int
  "Restrict system operations to promises."
  (promises :string)
  (execpromises :string))

(defun pledge (promises &optional exec-promises)
  "Announce which kinds of system-calls to restrict execution to.
PLEDGE and EXEC-PROMISES are both lists that may contain the keys
listed in `+pledges+'."
  (labels ((translate (pledge)
             (cdr (or (assoc pledge +pledges+)
                      (error "Unknown pledge ~A" pledge))))
           (translate* (pledges)
             (cond ((not (listp pledges))
                    (string-downcase (translate pledges)))
                   ((not (null pledges))
                    (format nil "~(~{~A~^ ~}~)" (mapcar #'translate pledges)))
                   ((null-pointer)))))
    (ensure
     (pledge-raw
      (translate* promises)
      (translate* exec-promises)))))


;; unveil(2), https://man.openbsd.org/unveil

(defcfun (unveil-raw "unveil") :int
  "unveil parts of a restricted filesystem view"
  (path :string)
  (permissions :string))

(defun unveil (path &rest permisions)
  "Restrict the visibility and access of PATH to a set of PERMISSIONS.
PERMISSIONS may be one of :read, :write, :execute or :create."
  (ensure
   (unveil-raw (namestring (pathname path))
               (map 'string (lambda (p) (ecase p
                                          (:read #\r)
                                          (:write #\w)
                                          (:execute #\x)
                                          (:create #\c)))
                    (delete-duplicates permisions)))))