CipherMyText/ciphermytext-cli.scm

#!/usr/bin/env scheme-r7rs

(import (scheme base)
        (scheme load)
        (scheme write)
        (scheme process-context)
        (scheme cxr)
        (scheme file)
        (macduffie cipher)
        (srfi 1))

(define (usage)
  (display "Usage: ciphermytext [options] [-e] <algorithm> <plaintext/[-f=?]> <key>
       ciphermytext [options] -d <algorithm> <ciphertext/[-f=?]> <key>

Algorithms:
  autokey
  caesar
  mono
  reptkey

Options:
  -f=? Read from a file instead of an inline string.
  -h   Display this help text.
  -i=? Set the number of iterations.
  -p   Preserve the punctuation of the original message.
  -v   Display the version of the software.\n")
  (exit))

(define (version)
  (display "Version: 0.0.1\n")
  (exit))

(define (extract-parameterized-arg args param-char default)
  (let loop ((list-out '())
             (list-in args))
    (if (null? list-in)
        (values args default)
        (let ((value (car list-in)))
          (if (and (char=? (string-ref value 0) #\-)
                   (char=? (string-ref value 1) param-char))
              (if (not (char=? (string-ref value 2) #\=))
                  (usage)
                  (values (append (reverse list-out)
                                  (cdr list-in))
                          (substring value 3 (string-length value))))
              (loop (cons value list-out) (cdr list-in)))))))

(define (extract-iterations args)
  (define-values (a b) (extract-parameterized-arg args #\i "1"))
  (values a (string->number b)))

(define (extract-file-type args)
  (extract-parameterized-arg args #\f #f))

(define (extract-mode args)
  (if (member "-d" args)
      (values (delete "-d" args)
              'decipher)
      (values (if (member "-e" args)
                  (delete "-e" args)
                  args)
              'encipher)))

(define (extract-punct args)
  (if (member "-p" args)
      (values (delete "-p" args)
              #t)
      (values args #f)))

(define (check-algorithm algo)
  (if (not (member (string->symbol algo) (map car algos)))
      (usage)))

(define (check-undetected args file-type)
  (for-each (lambda (x)
              (if (char=? (string-ref x 0) #\-)
                  (usage)))
            args)
  (if (not (or (and (not file-type)
                    (= (length args) 3))
               (and file-type
                    (= (length args) 2))))
      (usage)))

(define algos
  `((autokey ,autokey-encipher ,autokey-decipher)
    (caesar ,caesar-encipher ,caesar-decipher)
    (mono ,mono-encipher ,mono-decipher)
    (reptkey ,reptkey-encipher ,reptkey-decipher)))

(define (get-cipher-type algo mode)
  (if (eq? mode 'encipher)
      (cadr (assq (string->symbol algo) algos))
      (caddr (assq (string->symbol algo) algos))))

(define (read-entire-file file-name)
  (define port-in
    ;; A single dash means read from stdin
    (if (string=? file-name "-")
        (current-input-port)
        (open-input-file file-name)))

  (let loop ((result '())
             (next-line (read-line port-in)))
    (if (string? next-line)
        (loop (cons "\n" (cons next-line result))
              (read-line port-in))
        (begin
          (close-port port-in)
          (apply string-append (reverse result))))))

(define (xcipher algo text key mode iters punct)
  (define key-cast (if (equal? algo "caesar") (string->number key) key))
  (define (cipher-once current-text)
    (apply-cipher (get-cipher-type algo mode) punct current-text key-cast))

  (let loop ((i 0)
             (current-text text))
    (if (< i iters)
        (let ((a (cipher-once current-text)))
          (loop (+ i 1) a))
        current-text)))

(define (main-prog args)
  (define-values (arg-iter iters)
    (extract-iterations args))
  (define-values (arg-file-type file-type)
    (extract-file-type arg-iter))
  (define-values (arg-mode cipher-mode)
    (extract-mode arg-file-type))
  (define-values (new-args punctuate)
    (extract-punct arg-mode))
  (if (< iters 1)
      (error "ciphermytext-cli" "Iterations must be at least 1."))
  (if (or (member "--help" new-args)
          (member "-h" new-args))
      (usage))
  (if (or (member "--version" new-args)
          (member "-v" new-args))
      (version))
  (check-undetected new-args file-type)
  (check-algorithm (car new-args))
  (let ((result (if file-type
                    (xcipher (car new-args) (read-entire-file file-type) (cadr new-args) cipher-mode iters punctuate)
                    (xcipher (car new-args) (cadr new-args) (caddr new-args) cipher-mode iters punctuate))))
    (display result)
    (unless (and punctuate file-type) (newline))))

(main-prog (cdr (command-line)))