Skip to content

Commit 966dbe7

Browse files
ardumontardumont
committed
Sandboxable haskell-mode using haskell-process-wrapper
Following the discussion from haskell#350 (comment), creating a haskell-process-wrapper.
1 parent 5d60bdf commit 966dbe7

File tree

2 files changed

+176
-49
lines changed

2 files changed

+176
-49
lines changed

‎haskell-process.el

Lines changed: 59 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,30 @@ See `haskell-process-do-cabal' for more details."
111111
:type '(choice (const auto) (const ghci) (const cabal-repl) (const cabal-dev) (const cabal-ghci))
112112
:group 'haskell-interactive)
113113

114+
(defcustom haskell-process-wrapper
115+
nil
116+
"A wrapper to launch the Haskell process defined by `haskell-process-type`.
117+
Nix users may want to use the value (\"nix-shell\" \"--command\"),
118+
Docker users may want to use something like \"run-my-docker\"."
119+
:group 'haskell-interactive
120+
:type '(choice string (repeat string)))
121+
122+
(defun haskell-process-stringify-cmd (cmd &optional args)
123+
"Stringify the CMD with optional ARGS."
124+
(format "%s" (mapconcat 'identity (cons cmd args) " ")))
125+
126+
(defun haskell-process-wrapper-command (cmd &optional cmd-args)
127+
"Compute the haskell command to execute to launch the haskell-process type.
128+
if haskell-process-wrapper is set, return a wrapper of the CMD as list.
129+
Otherwise, return CMD as list.
130+
Deal with optional CMD-ARGS for the CMD."
131+
(if haskell-process-wrapper
132+
(let ((wrapped-cmd (haskell-process-stringify-cmd cmd cmd-args)))
133+
(if (stringp haskell-process-wrapper)
134+
(list haskell-process-wrapper wrapped-cmd)
135+
(append haskell-process-wrapper (list wrapped-cmd))))
136+
(cons cmd cmd-args)))
137+
114138
(defcustom haskell-process-log
115139
nil
116140
"Enable debug logging to \"*haskell-process-log*\" buffer."
@@ -1010,6 +1034,36 @@ from `module-buffer'."
10101034
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10111035
;; Building the process
10121036

1037+
(defun haskell-process-compute-process-log-and-command (session hptype)
1038+
"Compute the log and process to start command for the SESSION from the HPTYPE.
1039+
Do not actually start any process.
1040+
HPTYPE is the result of calling `'haskell-process-type`' function."
1041+
(let ((session-name (haskell-session-name session)))
1042+
(cl-ecase hptype
1043+
('ghci
1044+
(append (list (format "Starting inferior GHCi process %s ..." haskell-process-path-ghci)
1045+
session-name
1046+
nil)
1047+
(haskell-process-wrapper-command haskell-process-path-ghci haskell-process-args-ghci)))
1048+
('cabal-repl
1049+
(append (list (format "Starting inferior `cabal repl' process using %s ..." haskell-process-path-cabal)
1050+
session-name
1051+
nil)
1052+
(haskell-process-wrapper-command haskell-process-path-cabal (cons "repl" haskell-process-args-cabal-repl))
1053+
(let ((target (haskell-session-target session)))
1054+
(if target (list target) nil))))
1055+
('cabal-ghci
1056+
(append (list (format "Starting inferior cabal-ghci process using %s ..." haskell-process-path-cabal-ghci)
1057+
session-name
1058+
nil)
1059+
(haskell-process-wrapper-command haskell-process-path-cabal-ghci)))
1060+
('cabal-dev
1061+
(let ((dir (concat (haskell-session-cabal-dir session) "/cabal-dev")))
1062+
(append (list (format "Starting inferior cabal-dev process %s -s %s ..." haskell-process-path-cabal-dev dir)
1063+
session-name
1064+
nil)
1065+
(haskell-process-wrapper-command haskell-process-path-cabal-dev (list "ghci" "-s" dir))))))))
1066+
10131067
;;;###autoload
10141068
(defun haskell-process-start (session)
10151069
"Start the inferior Haskell process."
@@ -1026,58 +1080,14 @@ from `module-buffer'."
10261080
(haskell-process-set-session process session)
10271081
(haskell-process-set-cmd process nil)
10281082
(haskell-process-set (haskell-session-process session) 'is-restarting nil)
1029-
(let ((default-directory (haskell-session-cabal-dir session)))
1083+
(let ((default-directory (haskell-session-cabal-dir session))
1084+
(log-and-process-to-start (haskell-process-compute-process-log-and-command session (haskell-process-type))))
10301085
(haskell-session-pwd session)
10311086
(haskell-process-set-process
10321087
process
1033-
(cl-ecase (haskell-process-type)
1034-
('ghci
1035-
(haskell-process-log
1036-
(propertize (format "Starting inferior GHCi process %s ..."
1037-
haskell-process-path-ghci)
1038-
'face font-lock-comment-face))
1039-
(apply #'start-process
1040-
(append (list (haskell-session-name session)
1041-
nil
1042-
haskell-process-path-ghci)
1043-
haskell-process-args-ghci)))
1044-
('cabal-repl
1045-
(haskell-process-log
1046-
(propertize
1047-
(format "Starting inferior `cabal repl' process using %s ..."
1048-
haskell-process-path-cabal)
1049-
'face font-lock-comment-face))
1050-
1051-
(apply #'start-process
1052-
(append (list (haskell-session-name session)
1053-
nil
1054-
haskell-process-path-cabal)
1055-
'("repl") haskell-process-args-cabal-repl
1056-
(let ((target (haskell-session-target session)))
1057-
(if target (list target) nil)))))
1058-
('cabal-ghci
1059-
(haskell-process-log
1060-
(propertize
1061-
(format "Starting inferior cabal-ghci process using %s ..."
1062-
haskell-process-path-cabal-ghci)
1063-
'face font-lock-comment-face))
1064-
(start-process (haskell-session-name session)
1065-
nil
1066-
haskell-process-path-cabal-ghci))
1067-
('cabal-dev
1068-
(let ((dir (concat (haskell-session-cabal-dir session)
1069-
"/cabal-dev")))
1070-
(haskell-process-log
1071-
(propertize (format "Starting inferior cabal-dev process %s -s %s ..."
1072-
haskell-process-path-cabal-dev
1073-
dir)
1074-
'face font-lock-comment-face))
1075-
(start-process (haskell-session-name session)
1076-
nil
1077-
haskell-process-path-cabal-dev
1078-
"ghci"
1079-
"-s"
1080-
dir))))))
1088+
(progn
1089+
(haskell-process-log (propertize (car log-and-process-to-start) 'face font-lock-comment-face))
1090+
(apply #'start-process (cdr log-and-process-to-start)))))
10811091
(progn (set-process-sentinel (haskell-process-process process) 'haskell-process-sentinel)
10821092
(set-process-filter (haskell-process-process process) 'haskell-process-filter))
10831093
(haskell-process-send-startup process)

‎tests/haskell-process-tests.el

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,117 @@
1+
;;; haskell-process-tests.el
2+
3+
;;; Code:
4+
5+
(require 'ert)
6+
(require 'haskell-process)
7+
8+
;; HACK how to install deps in haskell-mode
9+
(progn (require 'package)
10+
(package-initialize)
11+
(add-to-list 'package-archives '("melpa" . "http://melpa.milkbox.net/packages/"))
12+
(package-refresh-contents)
13+
(package-install 'el-mock))
14+
15+
(require 'el-mock)
16+
17+
(ert-deftest haskell-process-stringify-cmd-no-arg ()
18+
"No wrapper, return directly the command (between string quote)."
19+
(should (equal "run"
20+
(let ((haskell-process-wrapper nil))
21+
(haskell-process-stringify-cmd "run")))))
22+
23+
(ert-deftest haskell-process-stringify-cmd-with-args ()
24+
"No wrapper, return directly the command."
25+
(should (equal "run -a b -c d"
26+
(let ((haskell-process-wrapper nil))
27+
(haskell-process-stringify-cmd "run" '("-a" "b" "-c" "d"))))))
28+
29+
(ert-deftest haskell-process-wrapper-command-nil ()
30+
"No wrapper, return directly the command."
31+
(should (equal '("ghci")
32+
(let ((haskell-process-wrapper nil))
33+
(haskell-process-wrapper-command "ghci")))))
34+
35+
(ert-deftest haskell-process-wrapper-command-with-string ()
36+
"Wrapper as a string, return the wrapping command as a string."
37+
(should (equal '("nix-shell" "cabal run")
38+
(let ((haskell-process-wrapper "nix-shell"))
39+
(haskell-process-wrapper-command "cabal run")))))
40+
41+
(ert-deftest haskell-process-wrapper-command-with-string-2 ()
42+
"Wrapper as a string, return the wrapping command as a string."
43+
(should (equal '("nix-shell" "cabal repl")
44+
(let ((haskell-process-wrapper "nix-shell"))
45+
(haskell-process-wrapper-command "cabal" '("repl"))))))
46+
47+
(ert-deftest haskell-process-wrapper-command-with-repeat-string ()
48+
"Wrapper as a list of string, return the wrapping command as a string."
49+
(should (equal '("nix-shell" "default.nix" "--command" "cabal build")
50+
(let ((haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
51+
(haskell-process-wrapper-command "cabal" '("build"))))))
52+
53+
(ert-deftest test-haskell-process--compute-process-log-and-command-ghci ()
54+
(should (equal '("Starting inferior GHCi process ghci ..." "dumses1" nil "ghci" "-ferror-spans")
55+
(let ((haskell-process-path-ghci "ghci")
56+
(haskell-process-args-ghci '("-ferror-spans"))
57+
(haskell-process-wrapper nil))
58+
(mocklet (((haskell-session-name "dummy-session") => "dumses1"))
59+
(haskell-process-compute-process-log-and-command "dummy-session" 'ghci))))))
60+
61+
(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-ghci ()
62+
(should (equal '("Starting inferior GHCi process ghci ..." "dumses1" nil "nix-shell" "default.nix" "--command" "ghci -ferror-spans")
63+
(let ((haskell-process-path-ghci "ghci")
64+
(haskell-process-args-ghci '("-ferror-spans"))
65+
(haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
66+
(mocklet (((haskell-session-name "dummy-session") => "dumses1"))
67+
(haskell-process-compute-process-log-and-command "dummy-session" 'ghci))))))
68+
69+
(ert-deftest test-haskell-process--compute-process-log-and-command-cabal-repl ()
70+
(should (equal '("Starting inferior `cabal repl' process using cabal ..." "dumses2" nil "cabal" "repl" "--ghc-option=-ferror-spans" "dumdum-session")
71+
(let ((haskell-process-path-cabal "cabal")
72+
(haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans"))
73+
(haskell-process-wrapper nil))
74+
(mocklet (((haskell-session-name "dummy-session2") => "dumses2")
75+
((haskell-session-target "dummy-session2") => "dumdum-session"))
76+
(haskell-process-compute-process-log-and-command "dummy-session2" 'cabal-repl))))))
77+
78+
(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-cabal-repl ()
79+
(should (equal '("Starting inferior `cabal repl' process using cabal ..." "dumses2" nil "nix-shell" "default.nix" "--command" "cabal repl --ghc-option=-ferror-spans" "dumdum-session")
80+
(let ((haskell-process-path-cabal "cabal")
81+
(haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans"))
82+
(haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
83+
(mocklet (((haskell-session-name "dummy-session2") => "dumses2")
84+
((haskell-session-target "dummy-session2") => "dumdum-session"))
85+
(haskell-process-compute-process-log-and-command "dummy-session2" 'cabal-repl))))))
86+
87+
(ert-deftest test-haskell-process--compute-process-log-and-command-cabal-ghci ()
88+
(should (equal '("Starting inferior cabal-ghci process using cabal-ghci ..." "dumses3" nil "cabal-ghci")
89+
(let ((haskell-process-path-ghci "ghci")
90+
(haskell-process-wrapper nil))
91+
(mocklet (((haskell-session-name "dummy-session3") => "dumses3"))
92+
(haskell-process-compute-process-log-and-command "dummy-session3" 'cabal-ghci))))))
93+
94+
(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-cabal-ghci ()
95+
(should (equal '("Starting inferior cabal-ghci process using cabal-ghci ..." "dumses3" nil "nix-shell" "default.nix" "--command" "cabal-ghci")
96+
(let ((haskell-process-path-ghci "ghci")
97+
(haskell-process-wrapper '("nix-shell" "default.nix" "--command")))
98+
(mocklet (((haskell-session-name "dummy-session3") => "dumses3"))
99+
(haskell-process-compute-process-log-and-command "dummy-session3" 'cabal-ghci))))))
100+
101+
(ert-deftest test-haskell-process--compute-process-log-and-command-cabal-dev ()
102+
(should (equal '("Starting inferior cabal-dev process cabal-dev -s directory/cabal-dev ..." "dumses4" nil "cabal-dev" "ghci" "-s" "directory/cabal-dev")
103+
(let ((haskell-process-path-cabal-dev "cabal-dev")
104+
(haskell-process-wrapper nil))
105+
(mocklet (((haskell-session-name "dummy-session4") => "dumses4")
106+
((haskell-session-cabal-dir "dummy-session4") => "directory"))
107+
(haskell-process-compute-process-log-and-command "dummy-session4" 'cabal-dev))))))
108+
109+
(ert-deftest test-haskell-process--with-wrapper-compute-process-log-and-command-cabal-dev ()
110+
(should (equal '("Starting inferior cabal-dev process cabal-dev -s directory/cabal-dev ..." "dumses4" nil "run-with-docker" "cabal-dev ghci -s directory/cabal-dev")
111+
(let ((haskell-process-path-cabal-dev "cabal-dev")
112+
(haskell-process-wrapper "run-with-docker"))
113+
(mocklet (((haskell-session-name "dummy-session4") => "dumses4")
114+
((haskell-session-cabal-dir "dummy-session4") => "directory"))
115+
(haskell-process-compute-process-log-and-command "dummy-session4" 'cabal-dev))))))
116+
117+
;;; haskell-process-tests.el ends here

0 commit comments

Comments
 (0)