#lang racket
(require (planet cobbe/functional-command:1))
(require racket/serialize)
(require racket/match)
(require srfi/1)
(require srfi/13/string)
(require srfi/19)

(require "common.rkt")
(require "config.rkt")

(require "create.rkt")
(require "extend.rkt")
(require "collect.rkt")
(require "alloc.rkt")
(require "list.rkt")
(require "grade.rkt")

(define server-host "localhost")
(define server-port 6666)

(define (send-request req)
  (define-values (in out) (tcp-connect server-host server-port))
  (write req out)
  (close-output-port out) ;; to make sure we flush the port immediately
  (display (string-append (port->string in) "\n") (current-output-port))
  (close-input-port in))

(define (string-to-key str)
  (let*
      ([str (string-downcase str)]
       [str (regexp-replace #rx"lab " (string-downcase str) "lab")]
       [str (regexp-replace #rx"homework " (string-downcase str) "hw")])
    str))

(define functional-banana
  (functional-command-line
   `("banana" "Student management tool"
     
     [create "create a new assignment"
             "" ; no extended help string
             (name . due-date)
             #:once-each
             [ ("--key" "-k") #:key
               "key to associate with the assignment" key ]
             [ ("--collection-date" "-c") #:collection-date
               "date the assignment was given, defaults to due date" collection-date ]
             [ ("--max-score" "-m") #:max-score
               "max score for the assignment" max-score ]
             ,(lambda (#:key [ key (list (string-to-key name)) ]
                       #:collection-date [ collection-date (list #f) ]
                       #:max-score [max-score (list #f)]
                       . name
                       . due-date)
                (cons
                 (determine-metadata)
                 ;; FIXME: These shouldn't need to be car'd
                 (make-create name (car key) (car collection-date) due-date (car max-score))))]
     
     [extend "request an extension for a particular assignment"
             "" ; no extended help string
             assignment-key
             #:once-each
             [ ("--student" "-s") #:student
               "student to request the extension for" student ]
             [ ("--extension-type" "-e") #:extension-type
               "type of extension to request (voucher or other: XXX)" extension-type ]
             [ ("--duration" "-d") #:duration
               "the duration (in hours) of the extension" duration ]
             ,(lambda (#:student [student (list (whoami))]
                       #:extension-type [extension-type (list "voucher") ]
                       #:duration [duration (list #f)]
                       assignment-key)
                (cons 
                 (determine-metadata)
                 (make-extend
                  (car student)
                  assignment-key
                  (car extension-type)
                  (if (boolean? (car duration))
                      (car duration)
                      (string->number (car duration))))))]
     
     [extend-status "get the voucher extension status (optionally of a particular student)"
             "" ; no extended help string
             ()
             #:once-each
             [ ("--student" "-s") #:student
               "student to request the extension for" student ]
             ,(lambda (#:student [student (list (whoami))])
                (cons 
                 (determine-metadata)
                 (make-extend-status
                  (car student))))]

     [extant "list all outstanding extensions (optionally for a particular assignment)"
             "" ; no extended help string
             ()
             #:once-each
             [ ("--assignment", "-a") #:assignment-key
               "assignment to list outstanding extensions for" assignment-key ]
             ,(lambda (#:assignment-key [assignment-key (list #f)])
                (cons
                 (determine-metadata)
                 (make-outstanding-extensions (car assignment-key))))]
     
     [alloc "allocate due dates and graders for an assignment"
            "" ; no extended help string
            assignment-key
            #:multi
            [ ("--grader-allocation" "-g") #:allocations
              "grader-integer pair denoting the number of assignments each grader is responsible for"
              grader number-of-assignments ]
            ,(lambda (#:allocations [allocations #f]
                      assignment-key)
               (cons 
                (determine-metadata)
                (make-alloc assignment-key
                            (zip (car allocations)
                                 (map (lambda (s) (string->number s)) (cadr allocations))))))]

     [collect "output a list of students that a specific grader is responsible for in the context of an assignment"
              "" ; no extended help string
              assignment-key
              #:once-each
              [ ("--grader" "-g") #:grader
                "grader to identify as, defaults to (whoami), also accepts 'all'" grader ]
              ,(lambda (#:grader [grader (list (whoami))]
                        assignment-key)
                 (cons
                  (determine-metadata)
                  (make-collect assignment-key (car grader))))]
     
     [list "list tables from the banana database (students, assignments, extensions, graders, grades)"
           "" ; no extended help string
           (table-name)
           #:once-each
           [ ("--assignment" "-a") #:assignment
             "assignment to limit the results to if relevant" assignment ]
           ,(lambda (table-name #:assignment [assignment #f])
              (let [(request-struct (match table-name
                                      ["grades" (make-list-grades assignment)]
                                      [_ (make-list-table table-name)]))]
                (cons
                 (determine-metadata)
                 request-struct)))]
     
     [grade "add or update a grade for a particular student and assignment"
              "" ; no extended help string
              (student assignment grade)
              ,(lambda (student assignment grade)
                 (cons
                  (determine-metadata)
                  (make-add-grade student assignment grade)))]
     
     [crosstab "cross-tabulate students and assignments"
              "" ; no extended help string
              ()
             #:once-each
             [ ("--student" "-s") #:student
               "student to fetch the grades for, defaults to all" student ]
              #:multi
              [ ("--assignment" "-a") #:assignments
                "assignment(s), defaults to all assignments which have any submitted grades"
                assignment ]
            ,(lambda (#:assignments [assignments (list #f)]
                      #:student     [student     (list #f)])
               (cons 
                (determine-metadata)
                (make-crosstab (car student) (car assignments))))]
     
     [cumul "show cumulative grades for a list of assignments (optionally limiting to a particular student)"
              "" ; no extended help string
              ()
             #:once-each
             [ ("--student" "-s") #:student
               "student to fetch the grades for, defaults to all" student ]
              #:multi
              [ ("--assignment" "-a") #:assignments
                "assignment(s), defaults to all assignments which have any submitted grades"
                assignment ]
            ,(lambda (#:assignments [assignments (list #f)]
                      #:student     [student     (list #f)])
               (cons 
                (determine-metadata)
                (make-cumul-grade (car student) (car assignments))))]
     
     ) (current-command-line-arguments)))

(send-request functional-banana)