1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
;;; lsp-docker.el --- LSP Docker integration -*- lexical-binding: t; -*-
;; Copyright (C) 2019 Ivan Yonchovski
;; Author: Ivan Yonchovski <yyoncho@gmail.com>
;; URL: https://github.com/emacs-lsp/lsp-docker
;; Keywords: languages langserver
;; Version: 1.0.0
;; Package-Requires: ((emacs "28.1") (dash "2.14.1") (lsp-mode "6.2.1") (f "0.20.0") (s "1.13.0") (yaml "0.2.0") (ht "2.0"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Run language servers in containers
;;; Code:
(require 'lsp-mode)
(require 'dash)
(require 'f)
(require 's)
(require 'yaml)
(require 'ht)
(defgroup lsp-docker nil
"Language Server Protocol dockerized servers support."
:group 'lsp-mode
:tag "Language Server in docker (lsp-docker)")
(defcustom lsp-docker-log-docker-supplemental-calls nil
"If non-nil, all docker command supplemental-calls will be logged to a buffer."
:group 'lsp-docker
:type 'boolean)
(defcustom lsp-docker-log-docker-supplemental-calls-buffer-name "*lsp-docker-supplemental-calls*"
"Log docker supplemental calls using this particular buffer."
:group 'lsp-docker
:type 'string)
;; top node keys
(defconst lsp-docker--lsp-key 'lsp
"Main key associated to the root-node of the containerized language servers")
;; 1st sub-node keys
(defconst lsp-docker--server-key 'server
"LSP sub-key holding a single (or a group of) server(s)")
(defconst lsp-docker--mappings-key 'mappings
"Collection of mappings between host-paths and
containerized-paths (host paths must be within the project)")
;; 2nd sub-node keys
;; supported keys in YAML configuration file(s)
(defconst lsp-docker--srv-cfg-type-key 'type
"The type of server (at the moment only `docker' is supported).")
(defconst lsp-docker--srv-cfg-subtype-key 'subtype
"For type container it can be:
- `container': attach to an already running container
- `image': when the image does not exist, try to build it based on the dockerfile
found in the project-scope An image might feature an optional tag, i.e.
`<image>:<tag>'. the If a tagless image is indicated `latest' will be assumed")
(defconst lsp-docker--srv-cfg-name-key 'name
"Depending on the `lsp-docker--srv-cfg-subtype-key' it holds the
name of the container/image for the described language server.")
(defconst lsp-docker--srv-cfg-server-key 'server
"Server ID of a registered LSP server. You can find the list of
registered servers evaluating: `(ht-keys lsp-clients)'.")
(defconst lsp-docker--srv-cfg-launch-parameters-key 'launch_parameters
"Command parameters (docker or podman) to launch the language server with.
Pay attention that these parameters have to be supported by the selected subtype.")
(defconst lsp-docker--srv-cfg-launch-command-key 'launch_command
"Command to launch the language server in stdio mode. This key is
not used when the `lsp-docker--srv-cfg-subtype-key' is set to
container, as the server command shall be the entrypoint.")
(defun lsp-docker--log-docker-supplemental-calls-p ()
"Return non-nil if should log docker invocation commands"
lsp-docker-log-docker-supplemental-calls)
(defun lsp-docker--uri->path (path-mappings docker-container-name uri)
"Turn docker URI into host path.
Argument PATH-MAPPINGS dotted pair of (host-path . container-path).
Argument DOCKER-CONTAINER-NAME name to use when running container.
Argument URI the uri to translate."
(let ((path (lsp--uri-to-path-1 uri)))
(-if-let ((local . remote) (-first (-lambda ((_ . docker-path))
(s-contains? docker-path path))
path-mappings))
(replace-regexp-in-string (format "\\(%s\\).*" remote) local path nil nil 1)
(format "/docker:%s:%s" docker-container-name path))))
(defun lsp-docker--path->uri (path-mappings path)
"Turn host PATH into docker uri.
Argument PATH-MAPPINGS dotted pair of (host-path . container-path).
Argument PATH the path to translate."
(lsp--path-to-uri-1
(-if-let ((local . remote) (-first (-lambda ((local-path . _))
(s-contains? local-path path))
path-mappings))
(replace-regexp-in-string (format "\\(%s\\).*" local) remote path nil nil 1)
(user-error "The path %s is not under path mappings" path))))
(defvar lsp-docker-container-name-suffix 0
"Used to prevent collision of container names.")
(defvar lsp-docker-command "docker"
"The docker command to use.")
(defun lsp-docker-launch-new-container (docker-container-name path-mappings launch-parameters docker-image-id server-command)
"Return the docker command to be executed on host.
Argument DOCKER-CONTAINER-NAME name to use for container.
Argument PATH-MAPPINGS dotted pair of (host-path . container-path).
Argument DOCKER-IMAGE-ID the docker container to run language servers with.
Argument LAUNCH-PARAMETERS parameters (for docker or podman) to run language servers with.
Argument SERVER-COMMAND the language server command to run inside the container."
(-remove #'s-blank?
(split-string
(format "%s run --name %s --rm -i %s %s %s %s"
lsp-docker-command
docker-container-name
(->> path-mappings
(-map (-lambda ((path . docker-path))
(format "-v %s:%s" path docker-path)))
(s-join " "))
(s-join " " launch-parameters)
docker-image-id
server-command)
" ")))
(defun lsp-docker-exec-in-container (docker-container-name server-command)
"Return command to exec into running container.
Argument DOCKER-CONTAINER-NAME name of container to exec into.
Argument SERVER-COMMAND the command to execute inside the running container."
(split-string
(format "%s exec -i %s %s" lsp-docker-command docker-container-name server-command)))
(defun lsp-docker--attach-container-name-global-suffix (container-name)
"Attach a user-specified or a default suffix (properly changing it) to the container name"
(if lsp-docker-container-name-suffix
(format "%s-%d"
container-name
(if (numberp lsp-docker-container-name-suffix)
(cl-incf lsp-docker-container-name-suffix)
lsp-docker-container-name-suffix))
container-name))
(cl-defun lsp-docker-register-client (&key server-id
docker-server-id
path-mappings
launch-parameters
docker-image-id
docker-container-name
priority
server-command
launch-server-cmd-fn)
"Registers docker clients with lsp"
(if-let ((client (copy-lsp--client (gethash server-id lsp-clients))))
(progn
(let ((docker-container-name-full (lsp-docker--attach-container-name-global-suffix docker-container-name)))
(setf (lsp--client-server-id client) docker-server-id
(lsp--client-uri->path-fn client) (-partial #'lsp-docker--uri->path
path-mappings
docker-container-name-full)
(lsp--client-path->uri-fn client) (-partial #'lsp-docker--path->uri path-mappings)
(lsp--client-new-connection client) (plist-put
(lsp-stdio-connection
(lambda ()
(funcall (or launch-server-cmd-fn #'lsp-docker-launch-new-container)
docker-container-name-full
path-mappings
launch-parameters
docker-image-id
server-command)))
:test? (lambda (&rest _)
(-any?
(-lambda ((dir))
(f-ancestor-of? dir (buffer-file-name)))
path-mappings)))
(lsp--client-priority client) (or priority (lsp--client-priority client))))
(lsp-register-client client))
(user-error "No such client %s" server-id)))
(defvar lsp-docker-default-client-packages
'(lsp-bash
lsp-clangd
lsp-css
lsp-dockerfile
lsp-go
lsp-html
lsp-javascript
lsp-pylsp)
"Default list of client packages to load.")
(defvar lsp-docker-default-client-configs
(list
(list :server-id 'bash-ls :docker-server-id 'bashls-docker :server-command "bash-language-server start")
(list :server-id 'clangd :docker-server-id 'clangd-docker :server-command "ccls")
(list :server-id 'css-ls :docker-server-id 'cssls-docker :server-command "css-languageserver --stdio")
(list :server-id 'dockerfile-ls :docker-server-id 'dockerfilels-docker :server-command "docker-langserver --stdio")
(list :server-id 'gopls :docker-server-id 'gopls-docker :server-command "gopls")
(list :server-id 'html-ls :docker-server-id 'htmls-docker :server-command "html-languageserver --stdio")
(list :server-id 'pylsp :docker-server-id 'pyls-docker :server-command "pylsp")
(list :server-id 'ts-ls :docker-server-id 'tsls-docker :server-command "typescript-language-server --stdio"))
"Default list of client configurations.")
(cl-defun lsp-docker-init-clients (&key
path-mappings
(docker-image-id "emacslsp/lsp-docker-langservers")
(docker-container-name "lsp-container")
(priority 10)
(client-packages lsp-docker-default-client-packages)
(client-configs lsp-docker-default-client-configs))
"Loads the required client packages and registers the required clients to run with docker.
:path-mappings is an alist of local paths and their mountpoints
in the docker container.
Example: '((\"/path/to/projects\" . \"/projects\"))
:docker-image-id is the identifier for the docker image to be
used for all clients, as a string.
:docker-container-name is the name to use for the container when
it is started.
:priority is the priority with which to register the docker
clients with lsp. (See the library ‘lsp-clients’ for details.)
:client-packages is a list of libraries to load before registering the clients.
:client-configs is a list of configurations for the various
clients you wish to use with ‘lsp-docker’. Each element takes
the form
'(:server-id 'example-ls
:docker-server-id 'examplels-docker
:docker-image-id \"examplenamespace/examplels-docker:x.y\"
:docker-container-name \"examplels-container\"
:server-command \"run_example_ls.sh\")
where
:server-id is the ID of the language server, as defined in the
library ‘lsp-clients’.
:docker-server-id is any arbitrary unique symbol used internally
by ‘lsp’ to distinguish it from non-docker clients for the same
server.
:docker-image-id is an optional property to override this
function's :docker-image-id argument for just this client. If
you specify this, you MUST also specify :docker-container-name.
:docker-container-name is an optional property to override this
function's :docker-container-name argument for just this client.
This MUST be specified if :docker-image-id is specified, but is
otherwise optional.
:server-command is a string specifying the command to run inside
the docker container to run the language server."
(seq-do (lambda (package) (require package nil t)) client-packages)
(let ((default-docker-image-id docker-image-id)
(default-docker-container-name docker-container-name))
(seq-do (-lambda ((&plist :server-id :docker-server-id :docker-image-id :docker-container-name :server-command))
(when (and docker-image-id (not docker-container-name))
(user-error "Invalid client definition for server ID %S. You must specify a container name when specifying an image ID."
server-id))
(lsp-docker-register-client
:server-id server-id
:priority priority
:docker-server-id docker-server-id
:docker-image-id (or docker-image-id default-docker-image-id)
:docker-container-name (if docker-image-id
docker-container-name
default-docker-container-name)
:server-command server-command
:path-mappings path-mappings
:launch-parameters nil
:launch-server-cmd-fn #'lsp-docker-launch-new-container))
client-configs)))
(defvar lsp-docker-default-priority
100
"Default lsp-docker containerized servers priority (it needs to
be bigger than default servers in order to override them)")
(defcustom lsp-docker-persistent-default-config
(ht (lsp-docker--server-key (ht (lsp-docker--srv-cfg-type-key "docker")
(lsp-docker--srv-cfg-subtype-key "image")
(lsp-docker--srv-cfg-name-key "emacslsp/lsp-docker-langservers")
(lsp-docker--srv-cfg-server-key nil)
(lsp-docker--srv-cfg-launch-command-key nil)))
(lsp-docker--mappings-key (vector
(ht ('source ".")
('destination "/projects")))))
"Default configuration for all language servers with persistent configurations"
:type 'hash-table
:group 'lsp-docker)
(defun lsp-docker-get-config-from-project-config-file (project-config-file-path)
"Get the LSP configuration based on a project configuration file"
(if (f-exists? project-config-file-path)
(if-let* ((whole-config (yaml-parse-string (f-read project-config-file-path)))
(lsp-config (gethash lsp-docker--lsp-key whole-config)))
;; use default values for missing fields in the provided configuration
(if (vectorp (gethash lsp-docker--server-key lsp-config))
lsp-config ; DO NOT merge to the persistent configuration when a multi-server one is detected
(ht-merge (ht-copy lsp-docker-persistent-default-config) lsp-config)))))
(defun lsp-docker--find-project-config-file-from-lsp ()
"Get the LSP configuration file path (project-local configuration, using lsp-mode)"
(let ((config-file-path-candidates (list)))
(when (lsp-workspace-root)
(push (f-join (lsp-workspace-root) ".lsp-docker.yml") config-file-path-candidates)
(push (f-join (lsp-workspace-root) ".lsp-docker.yaml") config-file-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") ".lsp-docker.yml") config-file-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") ".lsp-docker.yaml") config-file-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") "lsp-docker.yml") config-file-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") "lsp-docker.yaml") config-file-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") "config.yml") config-file-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") "config.yaml") config-file-path-candidates)
(--first (f-exists? it) config-file-path-candidates))))
(defun lsp-docker--find-project-dockerfile-from-lsp ()
"Get the LSP server building Dockerfile path using lsp-mode"
(let ((dockerfile-path-candidates (list)))
(when (lsp-workspace-root)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") "Dockerfile") dockerfile-path-candidates)
(push (f-join (f-join (lsp-workspace-root) ".lsp-docker") "Dockerfile.lsp") dockerfile-path-candidates)
(--first (f-exists? it) dockerfile-path-candidates))))
(defun lsp-docker--find-building-path-from-dockerfile (dockerfile-path)
"Get the LSP server building folder path using an explicit dockerfile path"
(when dockerfile-path
(f-dirname (f-dirname dockerfile-path))))
(defun lsp-docker-get-config-from-lsp ()
"Get the LSP configuration based on a project-local configuration (using lsp-mode)"
(let ((project-config-file-path (lsp-docker--find-project-config-file-from-lsp)))
(if project-config-file-path
(lsp-docker-get-config-from-project-config-file project-config-file-path)
(ht-copy lsp-docker-persistent-default-config))))
(defvar lsp-docker-supported-server-types-subtypes
(ht ('docker (list 'container 'image)))
"A list of all supported server types and subtypes, currently only docker is supported")
(defun lsp-docker-get-server-type-subtype (server-config)
"Get the server type & sub-type from the SERVER-CONFIG hash-table"
(let* ((lsp-server-type (gethash lsp-docker--srv-cfg-type-key server-config))
(lsp-server-subtype (gethash lsp-docker--srv-cfg-subtype-key server-config)))
(cons (if (stringp lsp-server-type)
(intern lsp-server-type)
lsp-server-type)
(if (stringp lsp-server-subtype)
(intern lsp-server-subtype)
lsp-server-subtype))))
(defun lsp-docker-get-server-container-name (server-config)
"Get the server container name from the SERVER-CONFIG hash-table"
(let* ((lsp-server-subtype (gethash 'subtype server-config)))
(if (equal lsp-server-subtype "container")
(gethash 'name server-config))))
(defun lsp-docker-get-server-image-name (server-config)
"Get the server image name from the SERVER-CONFIG hash-table"
(let* ((lsp-server-subtype (gethash 'subtype server-config)))
(if (equal lsp-server-subtype "image")
(gethash 'name server-config))))
(defun lsp-docker--get-server-launch-parameters (server-config)
"Get the server launch parameters from the SERVER-CONFIG hash-table"
(let ((launch-parameters (gethash lsp-docker--srv-cfg-launch-parameters-key server-config)))
(if (or (vectorp launch-parameters)
(not launch-parameters))
launch-parameters
(user-error "Cannot find the right launch parameters"))))
(defun lsp-docker-get-server-id (server-config)
"Get the server id from the SERVER-CONFIG hash-table"
(let ((server-id (gethash lsp-docker--srv-cfg-server-key server-config)))
(if (stringp server-id)
(intern server-id)
server-id)))
(defun lsp-docker--get-base-client (base-server-id)
"Get the base lsp client associated to BASE-SERVER-ID key for
dockerized client to be built upon"
(if-let* ((base-client (gethash base-server-id lsp-clients)))
base-client
(user-error "Cannot find the specified base lsp client (%s)!
Make sure the '%s' sub-key is set to one of the lsp registered clients:\n\n%s"
base-server-id lsp-docker--srv-cfg-server-key (ht-keys lsp-clients))))
(defun lsp-docker-get-path-mappings (config project-directory)
"Get the server path mappings from the top project hash-table CONFIG"
(if-let ((lsp-mappings-info (gethash lsp-docker--mappings-key config)))
(--map (cons (f-canonical (f-expand (gethash 'source it)
project-directory))
(gethash 'destination it))
lsp-mappings-info)
(user-error "No path mappings specified!")))
(defun lsp-docker-get-launch-command (server-config)
"Get the server launch command from the SERVER-CONFIG hash-table"
(gethash lsp-docker--srv-cfg-launch-command-key server-config))
(defun lsp-docker-check-server-type-subtype (supported-server-types-subtypes server-type-subtype)
"Verify that the combination of server (type . subtype) is supported by the current implementation"
(if (not server-type-subtype)
(user-error "No server type and subtype specified!"))
(if (ht-find (lambda (type subtypes)
(let ((server-type (car server-type-subtype))
(server-subtype (cdr server-type-subtype)))
(and (equal server-type type)
(-contains? subtypes server-subtype))))
supported-server-types-subtypes)
server-type-subtype
(user-error "No compatible server type and subtype found!")))
(defun lsp-docker-check-path-mappings (path-mappings)
"Verify that specified path mappings are all inside the project directory"
(--all? (or (f-descendant-of? (f-canonical (car it)) (f-canonical (lsp-workspace-root)))
(f-same? (f-canonical (car it)) (f-canonical (lsp-workspace-root))))
path-mappings))
(defun lsp-docker-launch-existing-container (docker-container-name &rest _unused)
"Return the docker command to be executed on host.
Argument DOCKER-CONTAINER-NAME name to use for container."
(split-string
(format "%s start -ia %s"
lsp-docker-command
docker-container-name)
" "))
(defun lsp-docker-create-activation-function-by-project-dir (project-dir)
`(lambda (&rest unused)
(let ((current-project-root (lsp-workspace-root))
(registered-project-root ,project-dir))
(f-same? current-project-root registered-project-root))))
(defun lsp-docker--create-activation-function-by-project-dir-and-base-client (project-dir base-lsp-client)
`(lambda (current-file-name current-major-mode)
(let ((current-project-root (lsp-workspace-root))
(registered-project-root ,project-dir)
(base-activation-fn ,(lsp--client-activation-fn base-lsp-client))
(base-major-modes ',(lsp--client-major-modes base-lsp-client)))
(and (f-same? current-project-root registered-project-root)
(or (if (functionp base-activation-fn)
(funcall base-activation-fn current-file-name current-major-mode)
nil)
(-contains? base-major-modes current-major-mode))))))
(defun lsp-docker-generate-docker-server-id (server-config project-root)
"Generate the docker-server-id from the SERVER-CONFIG"
(let ((original-server-id (symbol-name (lsp-docker-get-server-id server-config)))
(project-path-server-id-part (s-chop-prefix "-" (s-replace-all '(("/" . "-") ("." . "")) project-root))))
(intern (s-join "-" (list project-path-server-id-part original-server-id "docker")))))
(defun lsp-docker--generate-docker-server-container-name (server-config project-root)
"Generate the docker-container-name from the SERVER-CONFIG"
(let ((docker-server-id (lsp-docker-generate-docker-server-id server-config project-root)))
(if (symbolp docker-server-id)
(symbol-name docker-server-id)
docker-server-id)))
(defun lsp-docker--finalize-docker-server-container-name (config-specified-server-name server-config project-root)
"Get or generate the container name.
If CONFIG-SPECIFIED-SERVER-NAME is non-nil, return it as
container name. Otherwise generate a unique container name from
SERVER-CONFIG and PROJECT-ROOT.
"
(cond ((stringp config-specified-server-name) config-specified-server-name)
('t (lsp-docker--attach-container-name-global-suffix (lsp-docker--generate-docker-server-container-name server-config project-root)))))
(defun lsp-docker--encode-single-quoted-parameters (raw-token-command)
"Encode single quoted tokens (with base64 encoding) so they won't be split"
(let* ((tokens-to-encode (--remove (s-blank-str? (cadr it)) (s-match-strings-all "'\\([^']+\\)'" raw-token-command)))
(replacement-pairs (--mapcat (list (cons (car it) (format "'%s'" (base64-encode-string (cadr it))))) tokens-to-encode)))
(s-replace-all replacement-pairs raw-token-command)))
(defun lsp-docker--decode-single-quoted-parameters (encoded-token-command)
"Decode single quoted tokens (base64-encoded) so they can be used again"
(let* ((tokens-to-decode (--remove (s-blank-str? (cadr it)) (s-match-strings-all "'\\([^']+\\)'" encoded-token-command)))
(replacement-pairs (--mapcat (list (cons (car it) (format "'%s'" (base64-decode-string (cadr it))))) tokens-to-decode)))
(s-replace-all replacement-pairs encoded-token-command)))
(defun lsp-docker--decode-single-quoted-tokens (command-tokens)
"Decode single quoted tokens (base64-encoded) from a token list"
(--map-when (s-match "'\\([^']+\\)'" it) (format "'%s'" (base64-decode-string (cadr (s-match "'\\([^']+\\)'" it)))) command-tokens))
(defun lsp-docker--run-docker-command (command-arguments)
"Run a command (with a configurable command itself: docker or
podman) and get its exit code and output as a pair (exit-code .
output)"
(lsp-docker--run-external-command (format "%s %s" lsp-docker-command command-arguments)))
(defun lsp-docker--get-build-command (image-name dockerfile-path)
"Get a building command string"
(format "%s build --tag %s --file %s %s" lsp-docker-command image-name dockerfile-path (lsp-docker--find-building-path-from-dockerfile dockerfile-path)))
(defun lsp-docker--run-image-build (image-name dockerfile-path buffer-name)
"Build the specified image using a particular dockerfile (with its output redirected to a specified buffer)"
(-let ((
(command-program . command-arguments)
(lsp-docker--decode-single-quoted-tokens (s-split " " (lsp-docker--encode-single-quoted-parameters (lsp-docker--get-build-command image-name dockerfile-path))))))
(with-current-buffer (get-buffer-create buffer-name)
(message "Building the image %s, please open the %s buffer for details" image-name buffer-name)
(apply #'call-process command-program nil (current-buffer) nil command-arguments))))
(defun lsp-docker--run-external-command (command)
"Run a command and get its output and exit code"
(-let ((
(command-program . command-arguments)
(lsp-docker--decode-single-quoted-tokens (s-split " " (lsp-docker--encode-single-quoted-parameters command)))))
(progn
(lsp-docker--conditionally-log-docker-supplemental-call command-program command-arguments)
(lsp-docker--launch-command-internal command-program command-arguments))))
(defun lsp-docker--launch-command-internal (command-program command-arguments)
"Run a command using 'call-process' function and return a pair of exit code and raw output"
(with-temp-buffer
(cons
(apply #'call-process command-program nil (current-buffer) nil command-arguments)
(buffer-string))))
(defun lsp-docker--conditionally-log-docker-supplemental-call (command-program command-arguments)
"Log a command into a buffer set in lsp-docker settings group"
(if (lsp-docker--log-docker-supplemental-calls-p)
(with-current-buffer (get-buffer-create lsp-docker-log-docker-supplemental-calls-buffer-name)
(goto-char (point-max))
(insert (format "LOG: calling %s %s\n" command-program (s-join " " command-arguments))))))
(defun lsp-docker--get-existing-images ()
"Get available docker images already existing on the host"
(-let ((
(exit-code . raw-output)
(lsp-docker--run-docker-command "image list --format '{{.Repository}}:{{.Tag}}'")))
(if (equal exit-code 0)
;; filter out the list of tagged images from cmd output
(--remove (s-blank? it) (--map (s-chop-suffix "'" (s-chop-prefix "'" it)) (s-lines raw-output)))
(user-error "Cannot get the existing images list from the host, exit code: %d" exit-code))))
(defun lsp-docker--get-existing-containers ()
"Get available docker images already existing on the host"
(-let ((
(exit-code . raw-output)
(lsp-docker--run-docker-command "container list --all --format '{{.Names}}'")))
(if (equal exit-code 0)
(--remove (s-blank? it) (--map (s-chop-suffix "'" (s-chop-prefix "'" it)) (s-lines raw-output)))
(user-error "Cannot get the existing containers list from the host, exit code: %d" exit-code))))
(defun lsp-docker--check-image-exists (image-name)
"Check that the specified image already exists on the host"
;; automatically add "latest" tag when `image-name' is an untagged image name
(let ((target-image (if (not (string-match "[:]" image-name))
(format "%s:latest" image-name)
image-name)))
(--any? (s-equals? it target-image) (lsp-docker--get-existing-images))))
(defun lsp-docker--check-container-exists (container-name)
"Check that the specified container already exists on the host"
(--any? (s-equals? it container-name) (lsp-docker--get-existing-containers)))
(defun lsp-docker--generate-build-buffer-name (image-name dockerfile-path)
"Generate a buffer name used when building the specified image"
(let ((image-part image-name)
(dockerfile-path-part (s-chop-prefix "-" (s-replace-all '(("/" . "-") ("." . "")) dockerfile-path))))
(s-join "-" (list image-part dockerfile-path-part "build"))))
(defun lsp-docker--build-image-if-necessary (image-name dockerfile-path)
"Check that the specified image exists, otherwise build it (if possible)"
(unless (lsp-docker--check-image-exists image-name)
(if dockerfile-path
(if (y-or-n-p (format "Image %s is missing but can be built (Dockerfile was found), do you want to build it?" image-name))
(let ((build-buffer-name (lsp-docker--generate-build-buffer-name image-name dockerfile-path)))
(lsp-docker--run-image-build image-name dockerfile-path build-buffer-name))
(user-error "Cannot register a server with a missing image!"))
(user-error "Cannot find the image %s but cannot build it too (missing Dockerfile)" image-name))))
(defun lsp-docker--create-building-process-sentinel (
server-id
docker-server-id
path-mappings
launch-parameters
image-name
docker-container-name
activation-fn
server-command)
`(lambda (proc _message)
(when (eq (process-status proc) 'exit)
(lsp-docker-register-client-with-activation-fn
:server-id ',server-id
:docker-server-id ',docker-server-id
:path-mappings ',path-mappings
:launch-parameters ,launch-parameters
:docker-image-id ',image-name
:docker-container-name ',docker-container-name
:activation-fn ,activation-fn
:priority lsp-docker-default-priority
:server-command ',server-command
:launch-server-cmd-fn #'lsp-docker-launch-new-container))))
(cl-defun lsp-docker--build-image-and-register-server-async (&key image-name
dockerfile-path
server-id
docker-server-id
path-mappings
launch-parameters
docker-container-name
activation-fn
server-command
;; TODO: keep these inputs for future feature
;; implementation, see
;; https://github.com/sfavazza/lsp-docker/pull/1#discussion_r1367081991
;; project-root
;; docker-image-id
;; priority
;; launch-server-cmd-fn
)
"Build an image asynchronously and register it afterwards"
(unless (lsp-docker--check-image-exists image-name) ;; Check again whether we have to build a new image
(if dockerfile-path
(if (y-or-n-p (format "Image %s is missing but can be built (Dockerfile was found), do you want to build it?" image-name))
(let* ((build-buffer-name (lsp-docker--generate-build-buffer-name image-name dockerfile-path))
(build-command (lsp-docker--get-build-command image-name dockerfile-path))
(build-command-decoded (lsp-docker--decode-single-quoted-tokens (s-split " " (lsp-docker--encode-single-quoted-parameters build-command)))))
(with-current-buffer (get-buffer-create build-buffer-name)
(lsp-docker--conditionally-log-docker-supplemental-call (car build-command-decoded) (cdr build-command-decoded))
(message "Building the image %s, please open the %s buffer for details" image-name build-buffer-name)
(make-process
:name "lsp-docker-build"
:buffer (current-buffer)
:command build-command-decoded
:sentinel (lsp-docker--create-building-process-sentinel
server-id
docker-server-id
path-mappings
launch-parameters
image-name
docker-container-name
activation-fn
server-command))))
(user-error "Cannot register a server with a missing image!"))
(user-error "Cannot find the image %s but cannot build it too (missing Dockerfile)" image-name))))
(cl-defun lsp-docker-register-client-with-activation-fn (&key server-id
docker-server-id
path-mappings
launch-parameters
docker-image-id
docker-container-name
activation-fn
priority
server-command
launch-server-cmd-fn)
"Registers docker clients with lsp (by persisting configuration)"
(if-let ((client (copy-lsp--client (gethash server-id lsp-clients))))
(progn
(setf (lsp--client-server-id client) docker-server-id
(lsp--client-uri->path-fn client) (-partial #'lsp-docker--uri->path
path-mappings
docker-container-name)
(lsp--client-activation-fn client) activation-fn
(lsp--client-path->uri-fn client) (-partial #'lsp-docker--path->uri path-mappings)
(lsp--client-new-connection client) (plist-put
(lsp-stdio-connection
(lambda ()
(funcall (or launch-server-cmd-fn #'lsp-docker-launch-new-container)
docker-container-name
path-mappings
launch-parameters
docker-image-id
server-command)))
:test? (lambda (&rest _)
t))
(lsp--client-priority client) (or priority (lsp--client-priority client)))
(lsp-register-client client)
(message "Registered a language server with id: %s and container name: %s" docker-server-id docker-container-name))
(user-error "No such client %s" server-id)))
(defun lsp-docker--register-single-server (server-config project-root path-mappings)
"Register a single dockerized language server.
Its description is provided via the SERVER-CONFIG hash-table. It
must represents the fields defined under the `server' (single
server configuration) or `multi-server/<dockerized-server-name>'
(multi-server configuration) node. The PROJECT-ROOT must be a
path pointing to the top-level folder of the project the
configuration file resides into. The PATH-MAPPINGS provides a
hash-table to translate the paths between the host and the
dockerized server."
(let* ((server-type-subtype (lsp-docker-get-server-type-subtype server-config))
(config-specified-server-container-name (lsp-docker-get-server-container-name server-config))
(server-image-name (lsp-docker-get-server-image-name server-config))
(regular-server-id (lsp-docker-get-server-id server-config))
(server-id (lsp-docker-generate-docker-server-id server-config (lsp-workspace-root)))
(server-launch-parameters (lsp-docker--get-server-launch-parameters server-config))
(server-launch-command (lsp-docker-get-launch-command server-config))
(base-client (lsp-docker--get-base-client regular-server-id))
(activation-fn (lsp-docker--create-activation-function-by-project-dir-and-base-client
(lsp-workspace-root)
base-client))
(server-container-name (lsp-docker--finalize-docker-server-container-name
config-specified-server-container-name server-config project-root)))
(if (and (lsp-docker-check-server-type-subtype lsp-docker-supported-server-types-subtypes
server-type-subtype)
(lsp-docker-check-path-mappings path-mappings))
(let ((container-type (car server-type-subtype))
(container-subtype (cdr server-type-subtype)))
(pcase container-type
('docker (pcase container-subtype
('image (if (lsp-docker--check-image-exists server-image-name)
(lsp-docker-register-client-with-activation-fn
:server-id regular-server-id
:docker-server-id server-id
:path-mappings path-mappings
:launch-parameters server-launch-parameters
:docker-image-id server-image-name
:docker-container-name server-container-name
:activation-fn activation-fn
:priority lsp-docker-default-priority
:server-command server-launch-command
:launch-server-cmd-fn #'lsp-docker-launch-new-container)
(lsp-docker--build-image-and-register-server-async
:image-name server-image-name
:dockerfile-path (lsp-docker--find-project-dockerfile-from-lsp)
:server-id regular-server-id
:docker-server-id server-id
:path-mappings path-mappings
:launch-parameters server-launch-parameters
:docker-container-name server-container-name
:activation-fn activation-fn
:server-command server-launch-command)))
('container (if (lsp-docker--check-container-exists server-container-name)
(lsp-docker-register-client-with-activation-fn
:server-id regular-server-id
:docker-server-id server-id
:path-mappings path-mappings
:launch-parameters nil
:docker-image-id nil
:docker-container-name server-container-name
:activation-fn activation-fn
:priority lsp-docker-default-priority
:server-command server-launch-command
:launch-server-cmd-fn #'lsp-docker-launch-existing-container)
(user-error "Invalid LSP docker config: cannot find the specified container: %s" server-container-name)))
(user-error "Invalid LSP docker config: unsupported server type and/or subtype")))
(user-error "Invalid LSP docker config: unsupported server type and/or subtype")))
(user-error "Language server registration failed, check input parameters"))))
(defun lsp-docker-register ()
"Register one or more dockerized language servers for the current project"
(interactive)
(if (lsp-workspace-root)
(let* ((config (lsp-docker-get-config-from-lsp))
(project-root (lsp-workspace-root))
(path-mappings (lsp-docker-get-path-mappings config (lsp-workspace-root)))
(server-config (gethash lsp-docker--server-key config)))
;; check whether a single or multiple servers are described in the configuration
(cond
((vectorp server-config)
(message "registering multiple servers")
;; NOTE: if multiple language server descriptions share the same name "server" field, the latest entry
;; will be enforced.
(--map (lsp-docker--register-single-server it
project-root
path-mappings)
server-config))
(server-config
(message "registering a single server")
(lsp-docker--register-single-server server-config
project-root
path-mappings))
(t
(user-error "no `%s' node found in configuration, see README for reference"
lsp-docker--server-key))))
(user-error
(format (concat "Current file: %s is not in a registered project! "
"Try adding your project with `lsp-workspace-folders-add'")
(buffer-file-name)))))
(defun lsp-docker-start ()
"Register and launch a server to use LSP mode in a container for the current project"
(interactive)
(lsp-docker-register)
(lsp))
(provide 'lsp-docker)
;;; lsp-docker.el ends here
|
