Start to visualise derivations

guix-data-service/model/derivation.scm

@@ -7,7 +7,10 @@
   #:use-module (guix inferior)
   #:use-module (guix derivations)
   #:use-module (guix-data-service model utils)
-  #:export (select-existing-derivations
+  #:export (select-derivation-by-file-name
+            select-derivation-outputs-by-derivation-id
+            select-derivation-inputs-by-derivation-id
+            select-existing-derivations
             select-derivations-by-id
             select-derivations-and-build-status-by-id
             insert-into-derivations
@@ -122,6 +125,19 @@
 
     derivation-output-ids))
 
+(define (select-derivation-by-file-name conn file-name)
+  (define query
+    (string-append
+     "SELECT id, file_name, builder, args, env_vars, system "
+     "FROM derivations "
+     "WHERE file_name = $1"))
+
+  (match (exec-query conn query (list file-name))
+    (()
+     #f)
+    ((result)
+     result)))
+
 (define (select-derivation-output-id conn name path)
   (match (exec-query
           conn
@@ -138,6 +154,35 @@
              #f "cannot find derivation-output with name ~A and path ~A"
              name path)))))
 
+(define (select-derivation-outputs-by-derivation-id conn id)
+  (define query
+    (string-append
+     "SELECT derivation_outputs.name, derivation_output_details.path, "
+     "derivation_output_details.hash_algorithm, derivation_output_details.hash, "
+     "derivation_output_details.recursive "
+     "FROM derivation_outputs "
+     "INNER JOIN derivation_output_details ON "
+     "derivation_outputs.derivation_output_details_id = derivation_output_details.id "
+     "WHERE derivation_id = $1"))
+
+  (exec-query conn query (list id)))
+
+(define (select-derivation-inputs-by-derivation-id conn id)
+  (define query
+    (string-append
+     "SELECT derivations.file_name, derivation_outputs.name, "
+     "derivation_output_details.path "
+     "FROM derivation_inputs "
+     "INNER JOIN derivation_outputs"
+     " ON derivation_outputs.id = derivation_inputs.derivation_output_id "
+     "INNER JOIN derivation_output_details"
+     " ON derivation_outputs.derivation_output_details_id = derivation_output_details.id "
+     "INNER JOIN derivations"
+     " ON derivation_outputs.derivation_id = derivations.id "
+     "WHERE derivation_inputs.derivation_id = $1"))
+
+  (exec-query conn query (list id)))
+
 (define (insert-derivation-input conn derivation-id derivation-input)
   (define (insert-into-derivation-inputs output-ids)
     (string-append "INSERT INTO derivation_inputs "

guix-data-service/web/controller.scm

@@ -29,6 +29,7 @@
   #:use-module (guix-data-service comparison)
   #:use-module (guix-data-service model guix-revision)
   #:use-module (guix-data-service model package)
+  #:use-module (guix-data-service model derivation)
   #:use-module (guix-data-service model build)
   #:use-module (guix-data-service jobs load-new-guix-revision)
   #:use-module (guix-data-service web render)
@@ -200,6 +201,27 @@
               base-packages-vhash
               target-packages-vhash))))))
 
+(define (render-derivation conn derivation-file-name)
+  (let ((derivation (select-derivation-by-file-name conn
+                                                    derivation-file-name)))
+    (if derivation
+        (let ((derivation-inputs (select-derivation-inputs-by-derivation-id
+                                  conn
+                                  (first derivation)))
+              (derivation-outputs (select-derivation-outputs-by-derivation-id
+                                   conn
+                                   (first derivation))))
+          (apply render-html
+                 (view-derivation derivation
+                                  derivation-inputs
+                                  derivation-outputs)))
+        #f ;; TODO
+        )))
+
+(define (render-store-item conn filename)
+  (apply render-html
+         (view-store-item filename)))
+
 (define (controller request body conn)
   (match-lambda
     ((GET)
@@ -215,10 +237,10 @@
             (view-revision commit-hash
                            (select-packages-in-revision conn
                                                         commit-hash))))
-    ((GET "derivation" derivation-file-name ...)
+    ((GET "gnu" "store" filename)
-     (apply render-html
+     (if (string-suffix? ".drv" filename)
-            (view-derivation (string-append
+         (render-derivation conn (string-append "/gnu/store/" filename))
-                              "/" (string-join derivation-file-name "/")))))
+         (render-store-item conn (string-append "/gnu/store/" filename))))
     ((GET "compare")
      (with-base-and-target-commits
       request conn

guix-data-service/web/view/html.scm

@@ -27,6 +27,7 @@
             view-revision
             view-builds
             view-derivation
+            view-store-item
             compare
             compare/derivations
             compare/packages
@@ -253,7 +254,19 @@
                         "View build on " ,build-server-url)))))
             builds))))))))
 
-(define (view-derivation derivation-file-name)
+(define (display-store-item-short item)
+  `((span (@ (style "font-size: small; font-family: monospace; display: block;"))
+          ,(string-take item 44))
+    (span (@ (style "font-size: x-large; font-family: monospace;"))
+          ,(string-drop item 44))))
+
+(define (display-store-item item)
+  `((span (@ (style "font-size: small; font-family: monospace;"))
+          ,(string-take item 44))
+    (span (@ (style "font-size: x-large; font-family: monospace;"))
+          ,(string-drop item 44))))
+
+(define (view-store-item filename)
   (layout
    #:extra-headers
    '((cache-control . ((max-age . 60))))
@@ -263,7 +276,56 @@
       (@ (class "container"))
       (div
        (@ (class "row"))
-       (h1 "Derivation " (samp ,derivation-file-name)))))))
+       (h1 (samp ,filename)))))))
+
+(define (view-derivation derivation derivation-inputs derivation-outputs)
+  (layout
+   #:extra-headers
+   '((cache-control . ((max-age . 60))))
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      ,(match derivation
+         ((id file-name builder args env-vars system)
+          `(div
+            (@ (class "row"))
+            (h1 "Derivation " (samp ,file-name)))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-md-4"))
+        (h3 "Inputs")
+        (table
+         (@ (class "table"))
+         (thead
+          (tr
+           (th "File name")))
+         (tdata
+          ,@(map (match-lambda
+                   ((file-name output-name path)
+                    `(tr
+                      (td (a (@ (href ,file-name))
+                             ,(display-store-item-short path))))))
+                 derivation-inputs))))
+       (div
+        (@ (class "col-md-4"))
+        "Details")
+       (div
+        (@ (class "col-md-4"))
+        (h3 "Outputs")
+        (table
+         (@ (class "table"))
+         (thead
+          (tr
+           (th "File name")))
+         (tdata
+          ,@(map (match-lambda
+                   ((output-name path hash-algorithm hash recursive?)
+                    `(tr
+                      (td (a (@ (href ,path))
+                             ,(display-store-item-short path))))))
+                 derivation-outputs)))))))))
 
 (define (compare base-commit
                  target-commit
@@ -434,7 +496,8 @@
             (match-lambda
               ((id file-name build-status)
                `(tr
-                 (td ,file-name)
+                 (td (a (@ (href ,file-name))
+                        ,(display-store-item file-name)))
                  (td ,build-status))))
             base-derivations))))
       (div
@@ -454,7 +517,8 @@
             (match-lambda
               ((id file-name build-status)
                `(tr
-                 (td ,file-name)
+                 (td (a (@ (href ,file-name))
+                        ,(display-store-item file-name)))
                  (td ,build-status))))
             target-derivations))))))))