From c9815b5deb66337756e1b7dacb3e9ca97d182cda Mon Sep 17 00:00:00 2001
From: Cyril Roelandt <tipecaml@gmail.com>
Date: Wed, 28 Jan 2015 19:49:53 +0100
Subject: lint: handle FTP URIs.

* guix/scripts/lint.scm (probe-uri): handle FTP URIs.
---
 guix/scripts/lint.scm | 32 ++++++++++++++++++++++++++++++--
 1 file changed, 30 insertions(+), 2 deletions(-)

(limited to 'guix/scripts/lint.scm')

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 9d5c689618..fef05635b3 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -21,6 +21,7 @@
 (define-module (guix scripts lint)
   #:use-module (guix base32)
   #:use-module (guix download)
+  #:use-module (guix ftp-client)
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix ui)
@@ -254,8 +255,29 @@ (define response
               (values key args))
              (else
               (apply throw key args))))))
+      ('ftp
+       (catch #t
+         (lambda ()
+           (let ((port (ftp-open (uri-host uri) 21)))
+             (define response
+               (dynamic-wind
+                 (const #f)
+                 (lambda ()
+                   (ftp-chdir port (dirname (uri-path uri)))
+                   (ftp-size port (basename (uri-path uri))))
+                 (lambda ()
+                   (ftp-close port))))
+             (values 'ftp-response #t)))
+         (lambda (key . args)
+           (case key
+             ((or ftp-error)
+              (values 'ftp-response #f))
+             ((getaddrinfo-error system-error gnutls-error)
+              (values key args))
+             (else
+              (apply throw key args))))))
       (_
-       (values 'not-http #f)))))
+       (values 'unknown-protocol #f)))))
 
 (define (validate-uri uri package field)
   "Return #t if the given URI can be reached, otherwise emit a
@@ -272,6 +294,12 @@ (define (validate-uri uri package field)
                                  (response-code argument)
                                  (response-reason-phrase argument))
                          field)))
+      ((ftp-response)
+       (when (not argument)
+         (emit-warning package
+                       (format #f
+                               (_ "URI ~a not reachable")
+                               (uri->string uri)))))
       ((getaddrinfo-error)
        (emit-warning package
                      (format #f
@@ -293,7 +321,7 @@ (define (validate-uri uri package field)
       ((invalid-http-response gnutls-error)
        ;; Probably a misbehaving server; ignore.
        #f)
-      ((not-http)                             ;nothing we can do
+      ((unknown-protocol)                             ;nothing we can do
        #f)
       (else
        (error "internal linter error" status)))))
-- 
cgit v1.2.3