-- © 2002 Peter Thiemann
module Main where

import CGI hiding (map, div, span, head)
import DiskImages
import Monad

helloCGI = 
  standardQuery "Welcome to TinyShop" $
  table_T $
  do tr_S (td_S (attr_SS "colspan" "2"
          ## text_S "If you are already a customer, \
                  \enter your email address and password"))
     emailF <- promptedInput "Email Address" (fieldSIZE 40) 
     passwF <- promptedPassword "Password" (fieldSIZE 40)
     tr_T (td_S (submit (F2 emailF passwF)
                    loginCGI
		    (fieldVALUE "LOGIN")))
     tr_T (td_S (submit F0
                    newCustomerCGI
		    (fieldVALUE "REGISTER NEW")))
     
promptedInput txt attrs =
  tr_T (td_S (text txt) >> td_S (inputField attrs))

promptedPassword txt attrs =
  tr_T (td_S (text txt) >> td_S (passwordInputField attrs))

-- ---------------------------------------------------------
newCustomerCGI F0 =
  standardQuery "TinyShop: New Customer" $
  table_T $
  do nameF <- promptedInput "Name " (fieldSIZE 40)
     strtF <- promptedInput "Street " (fieldSIZE 40)
     townF <- promptedInput "Town " (fieldSIZE 40)
     stateF<- promptedInput "State " (fieldSIZE 20)
     zipcF <- promptedInput "Zip " (fieldSIZE 10)
     countF<- promptedInput "Country " (fieldSIZE 20)
     birthF<- promptedInput "Date of Birth " (fieldSIZE 10)
     emailF<- promptedInput "Email address " (fieldSIZE 40)
     passF <- promptedPassword "Password " (fieldSIZE 40)
     tr_S $ td_S $ 
        submit (F5 nameF (F5 strtF townF stateF zipcF countF) birthF emailF passF)
     	registerCGI empty

-- -------------------------------------------------------
registerCGI (F5 nameF (F5 strtF townF stateF zipcF countF) birthF emailF passF) =
  let name = unNonEmpty (value nameF)
      street =  unNonEmpty (value strtF)
      town = unNonEmpty (value townF)
      state = unText (value stateF)
      zipc  = unNonEmpty (value zipcF)
      country = unNonEmpty (value countF)
      birthdate = unNonEmpty (value birthF)
      email = unEmailAddress (value emailF)
      pass = unNonEmpty (value passF)
  in
  -- verify and store information
  salesCGI email

-- -------------------------------------------------------
loginCGI (F2 emailF passF) =
  let email = unEmailAddress $ value emailF
      passw = unNonEmpty $ value passF
  in
  -- verify login information
  salesCGI email
  
-- -------------------------------------------------------
salesCGI email =
  standardQuery "Current Sales Items" $ do
  p_T (do text_S "Hi, "
	  text email
	  text_S " here are today's specials for you!")
  salesItems <- table_T $ do
    attr_SS "frame" "border"
    attr_SS "border" "2"
    thead_S $ tr_S (th_S (text_S "amount")
             ## th_S (text_S "image")
	     ## th_S (text_S "unit price"))
    mapM listItem inventory >>= (return . FL)
  p_T (text_S "Enter your selection and press FINISH to proceed to the cashier")
  submit salesItems billingCGI (fieldVALUE "FINISH")
    
listItem diskDesc =
  let ffImage = diskImage diskDesc in
  tr_T $ do 
    im <- internalImage ffImage (ffName ffImage)
    amountF <- td_S (inputField (fieldSIZE 5 ## fieldVALUE 0)) 
    td_S (makeImg im empty)
    td_S (text $ showCurrency (diskPrice diskDesc))
    return amountF
    
-- -------------------------------------------------------
billingCGI salesItemsF =
  let FL salesItemsH = salesItemsF
      salesItems = map value $ salesItemsH
  in
  standardQuery "Your bill" $ do
    p_T (text_S "modified items are listed in red")
    hdl <- table_T $ do
      attr_SS "frame" "border"
      attr_SS "border" "2"
      thead_S $ tr_S (th_S (text "amount") 
               ## th_S (text_S "image")
	       ## th_S (text_S "unit price")
	       ## th_S (text_S "total price"))
      prices <- mapM billItem (zip salesItems inventory)
      let totalPrice = sum prices
      tr_S (td_S empty
       ## td_S (text_S "total price") 
       ## td_S empty
       ## td_S (text $ showCurrency totalPrice))
      tr_S empty
      rg <- radioGroup
      tr_S (td_S (radioButton rg PayCredit empty)
       ## td_S (text_S "Pay by Credit Card"))
      ccnrF <- tr_T ((td_S empty >> td_S (inputField (fieldSIZE 16))) ## td_S (text_S "Card No"))
      ccexF <- tr_T ((td_S empty >> td_S (inputField (fieldSIZE  5))) ## td_S (text_S "Expires"))
      tr_S (td_S (radioButton rg PayTransfer empty)
       ## td_S (text_S "Pay by Bank Transfer"))
      acctF <- tr_T ((td_S empty >> td_S (inputField (fieldSIZE 10))) ## td_S (text_S "Acct No"))
      routF <- tr_T ((td_S empty >> td_S (inputField (fieldSIZE  8))) ## td_S (text_S "Routing"))
      let next paymodeF =
	    case value paymodeF of
	      PayCredit   -> dtnode (F2 ccnrF ccexF) (dtleaf . payCredit totalPrice)
	      PayTransfer -> dtnode (F2 acctF routF) (dtleaf . payTransfer totalPrice)
      return $ dtnode rg next
    submitx hdl empty
    
billItem (amount, diskDesc) =
  let actualAmount = max 0 (min amount (diskInStock diskDesc))
      actualPrice  = fromIntegral actualAmount * diskPrice diskDesc
      amountStyle | actualAmount == amount = ("color" :=: "blue")
                  | otherwise = ("color" :=: "red")
  in tr_T $ do
     using amountStyle td_S (text $ show actualAmount)
     im <- internalImage (diskImage diskDesc) (ffName (diskImage diskDesc))
     td_S (makeImg im empty)
     td_S (text_S $ showCurrency (diskPrice diskDesc))
     when (actualAmount > 0) $
       td_T (text $ showCurrency actualPrice)
     return actualPrice

-- -------------------------------------------------------
payCredit amount (F2 ccnrF ccexF) =
  let ccnr = unCreditCardNumber (value ccnrF)
      expMonth = cceMonth (value ccexF)
  in
  standardQuery "Confirm Credit Payment" $
  do p_T $ do text_S "Received credit card payment of "
	      text $ showCurrency amount
     p_T $ text_S "Thanks for shopping at TinyShop.Com!"

payTransfer amount (F2 acctF routF) = 
  let acct = unAllDigits (value acctF)
      rout = unAllDigits (value routF)
  in
  standardQuery "Confirm Transfer Payment" $ 
  do p_T $ do text_S "Received transfer payment of "
	      text $ showCurrency amount
     p_T $ text_S "Thanks for shopping at TinyShop.Com!"

-- -------------------------------------------------------
main = runWithHook [] (docTranslator (map diskImage inventory) lastTranslator) helloCGI

data ModeOfPayment = PayCredit | PayTransfer
  deriving (Read, Show)


showCurrency n =
  show (n `div` 100) ++ '.' : reverse (take 2 (reverse (show (n+100))))