Scan path example

Lisp example scanning a path and subpath for php files inside media or image folders, changed within the last 24 hours.

Shows off mail, command line, compiling and more.

(ql:quickload "cl-fad")
(ql:quickload "cl-smtp")
(ql:quickload "split-sequence")
(ql:quickload "command-line-arguments")
(ql:quickload :log4cl)

;
; helpers
;

(defmacro aif (test-form then-form &optional else-form)
    "Anaphoric Macro
    makes it possible to use value of if calculation without let assignment first"
    `(let ((it ,test-form))
        (if it ,then-form ,else-form)))

(defun find-part (part sequence)
    "Find part as as substring in sequence elements, return first occurence or nil
    (find-part \"abc\" (list \"x\" \"yabc\" \"z\")) ==> (list \"yabc\" \"z\")"
    (member part sequence :test (lambda (a b) (search a b))))

(defun get-cmdline-opt (name) 
    "Handle arguments like -x y -p w
    (get-cmdline-opt -x) => y"
    (second (member name  (command-line-arguments:get-command-line-arguments) :test 'equal )))

(defun split-and-lower (str)
    "Lowercase and split around / and return all but first item"
    (cdr (split-sequence:split-sequence #\/ (string-downcase str))))

(defun file-age-days (path)
 (/ (- (get-universal-time) (file-write-date path)) (* 60.0 60.0 24.0) ) )

;
; scanning
;


(defun file-scan (path)

 (let (files)

     (defun scan-files (path)
                    (if (null path ) 
                        (log:info "no path supplied")
            (cl-fad:walk-directory path 'check-file)))

     (defun check-file (pathname)
         (check-parts pathname (split-and-lower (namestring pathname))))

     (defun check-parts (pathname parts)
         (aif (find-part ".php" (cdr (find-part "media" parts)))
                        (prog ()
                            (if (< (file-age-days pathname) 20)
                                ;(format t "found ~a in ~a~&" it pathname)
                                (push (namestring pathname) files)
                            ))))

                (scan-files path)
                (return-from file-scan files)
 ))

(defun generate-report (files)
 (format nil "Suspect files found:
~% ~{ - ~a 
~% ~}" files))

(defun send-report (files recipient)
    " Accepts a list of filenames. Builds an apropriate mail and send it "
    (log:info "sending mail")
    (cl-smtp:send-email "mail.infoserv.dk"
        "msj@infoserv.dk" recipient
        "Suspicious files" (generate-report files)
        :extra-headers '(("Content-type" "text/html; charset=\"iso-8859-1\""))
        :authentication '("msj@infoserv.dk" "******")
        :port 366
       )
    )

;
; main
;

(defun main ()
    (aif (get-cmdline-opt "--path") 
        (send-report (file-scan it) "msj@infoserv.dk")
        (format t "supply a path using --path path")
     )
    (quit))

(log:config :daily "log.txt")
(main)

(defun compileme ()
    (sb-ext:save-lisp-and-die "scandir" :executable t :toplevel 'main :purify t))

Common Lisp error handling example

; Error  handling example.

(define-condition some-error (error)
    ((what :initarg :what :initform "something" :reader what))
    (:report (lambda (condition stream)
                        (format stream "Agh! ~@(~A~) error." (what condition))))
    (:documentation "Some-error condition."))

(defun ignore-some-error1 ()
 " Restart function "
 (print "some error 1")
 T)

(defun function-with-error ()
    " Test function which generate an error. Called directly this will start the debugger/repl. "
    (restart-case (error 'some-error :what "test")
          (use-value (value) value) ; first restart function
          (ignore-some-error1 () (ignore-some-error1)))) ; second restart function

(defun higher-function ()
    " This funtion calls a function which contains an error, but invokes the desired restart.
    Other higher-functions could select different restart or none at all, so the behaviour of 
    the function-with-error under error conditions is controlled on the higher-functions level. "
    (handler-bind ((some-error
                  #'(lambda (c)
                      (invoke-restart 'ignore-some-error1))))
                      (function-with-error )))