-- © 2001 Peter Thiemann
module Main where

import Char
import Directory
import Fields
import List hiding (head)
import Maybe
import Random
import Prelude hiding (head)
import HTMLMonad
import CGI hiding (question)
import RawCGI
import Item

data MainAction = Submit | Revise | Withdraw
  deriving (Eq, Read, Show)

main = 
  runWithHook translator $
  standardQuery "Paper Submission Engine" $
  table $
    (tr (td (submit F0 submission (fieldVALUE "Start new submission")
              ## attr "align" "center")) ##
    tr (td (submit F0 rwsub (fieldVALUE "Revise/withdraw submission"
              ## attr "align" "center"))))

rwsub F0 =
  standardQuery "Revise/Withdraw Paper" $
  table $
  do emailF <- tr $ question "Email" (inputField (fieldSIZE 60))
     keyF   <- tr $ question "Password" (passwordInputField (fieldSIZE 20))
     submit (F2 emailF keyF) dispatch (fieldVALUE "Revise/withdraw paper")

dispatch :: F2 (InputField EmailAddress) (InputField NonEmpty) VALID -> CGI ()
dispatch (F2 emailF keyF) =
  revision emailF keyF

submission F0 =
  standardQuery "Paper Submission" $
  table $
  let standardField :: (Reason a, Read a) =>WithHTML CGI (InputField a INVALID)
      standardField = inputField (fieldSIZE 60) in
  do authorF      <- tr $ question "Authors"     	standardField
     titleF       <- tr $ question "Title of paper"	standardField
     affiliationF <- tr $ question "Affiliation" 	standardField
     emailF       <- tr $ question "Email"       	standardField
     tr $ (td empty ## td (text "(corresponding author only)"))
     _            <- tr ( td (text "Abstract" ## attr "colspan" "2")) 
     abstractF    <- tr ( td (makeTextarea "" (attr "rows" "10" ## attr "cols" "75")
     			      ## attr "colspan" "2"))
     paperF       <- tr $ question "Filename of paper" (fileInputField (fieldSIZE 40))
     tr (td (text "Acceptable file formats:") ## (td (text ".ps, .ps.gz and .pdf" )))
     tr $ td (attr "align" "center"
          ## submit (F6 authorF titleF affiliationF emailF abstractF paperF)
	            (processSubmission Nothing)
		    (fieldVALUE "Submit paper"))

--question :: Field input => String -> input -> [Element]
question str inf =
  td (text str) >> td inf

--answer :: Show a => String -> InputField a x -> [Element]
answer str inf =
  td (b (text str)) >> td (text (fromMaybe "" (ifString inf)))

processSubmission maybePassword
  (F6 authorF titleF affiliationF emailF abstractF paperF) = 
  let author = unNonEmpty (value authorF)
      title  = unNonEmpty (value titleF)
      affiliation = unNonEmpty (value affiliationF)
      paper = value paperF
      email = unEmailAddress (value emailF)
      extension = getFileSuffix (fileReferenceExternalName paper) 
      contentType = fileReferenceContentType paper
  in
--  if allOK then
  do password <- case maybePassword of
		   Just pw -> return pw
		   Nothing -> io inventPassword
     let fileName = password ++ extension
	 storeFile = storeDirectory ++ fileName
     io (readFile (fileReferenceName paper) >>= writeFile storeFile)
     ref <- makeRef fileName (text "view paper")
     io (addItem password author title affiliation email
		 (value abstractF)
		 extension)
     htell $
       standardPage "Paper Submission Acknowledgement" $ 
       (table
         (  tr (td (b $ text "Your password") ## td (text password))
	 ## tr ( answer "Authors" authorF)
    	 ## tr ( answer "Title of paper"   titleF)
	 ## tr ( answer "Affiliation" affiliationF)
	 ## tr ( answer "Email" emailF)
	 ## tr (td ( attr "colspan" "2" ## b (text "Abstract")))
	 ## tr (td (text (value abstractF) ## attr "colspan" "2"))
	 ## tr (td (b (text "File format")) ## td (analyseContentType contentType))
	 ## tr (td (b (text "View downloaded file"))
	     ## td ref))
       ## hr empty
       ## text "Please save this page for future reference. "
       ##  text "Using the password, you can revise and/or withdraw your paper and your submission information until the deadline is expired."
       ##  text "Double check that your e-mail address is correct because it is the only way that we can reach you.")

analyseContentType contentType =
  if contentType `elem` ["application/postscript", "application/pdf"] then
     text contentType
  else
     attr "bgcolor" "red" ## text contentType ## text " might be a problem"

revision emailF keyF = 
  let password = unNonEmpty (value keyF)
      email = unEmailAddress (value emailF)
  in
  do item <- io (extractSubmission password)
     ref <- makeRef (itemPassword item ++ itemExtension item) (text "view here")
     case item of
       DelItem _ ->
         htell $ standardPage "Error: invalid email/password" (text "No such paper.")
       _ ->
         let standardField val = inputField (fieldSIZE 60 ## fieldVALUE val)
	 in standardQuery  "Revision/Withdrawal of Submission" $
         do text "Previously submitted version: "
	    ref
	    br empty
	    table $
	      do authorF <- tr $ question "Authors" (standardField (NonEmpty $ itemAuthor item))
		 titleF  <- tr $ question "Title of paper" (standardField (NonEmpty $ itemTitle item))
		 affiliationF <- tr $ question "Affiliation" (standardField (NonEmpty $ itemAffiliation item))
		 emailF  <- tr $ question "Email" (standardField (EmailAddress (itemEmail item)))
		 tr $ (td empty ## td (text "(corresponding author only)"))
		 tr (td (text "Abstract" ## attr "colspan" "2"))
		 abstractF <- tr (td (makeTextarea (itemAbstract item) (attr "rows" "10" ## attr "cols" "75") ## attr "colspan" "2"))
		 paperF <- tr $ question "Filename of paper" (fileInputField (fieldSIZE 40))
		 tr (td (submit (F6 authorF titleF affiliationF emailF abstractF paperF)
		                (processSubmission (Just password))
				(fieldVALUE "Resubmit paper") ## attr "align" "center")
		  ## td (submit F0 (withdraw item) (fieldVALUE "Withdraw paper") ## attr "align" "center"))


withdraw item F0 =
  do let password = itemPassword item
     io (delItem password)
     let fullName = storeDirectory ++ password ++ itemExtension item
     io (writeFile fullName "")
     htell $ standardPage "Withdrawal complete" 
     	    (text "Your submitted file has been removed from the system.")

notImplemented =
  htell $ standardPage "Not yet implemented..." empty


getFileSuffix name 
 | ".ps"    `isSuffixOf` name = ".ps"
 | ".ps.gz" `isSuffixOf` name = ".ps.gz" 
 | ".pdf"   `isSuffixOf` name = ".pdf"
 | otherwise                  = ""