{-# OPTIONS_GHC -F -pgmF ixdopp #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Concurrent.FullSession

-- SMTP commands
newtype EHLO = EHLO String -- domain
newtype R2yz = R2yz [String]
newtype R4yz = R4yz [String]
newtype R5yz = R5yz [String]
newtype MAIL = MAIL String -- reverse-path
newtype RCPT = RCPT String -- recipient addrs
newtype R220 = R220 String
data DATA = DATA
newtype R354 = R354 String
newtype MailBody = MailBody [String]
data QUIT = QUIT

-- SMTP protocol
type SMTP = 
  Recv R2yz (Send EHLO (Recv R2yz 
    (Rec Z (SelectN 
            (Send MAIL (Recv R2yz (Rec (S Z) (SelectN (Send RCPT (OfferN (Recv R2yz (Var (S Z))) (Recv R5yz (Send QUIT Close))))
                                                      (Send DATA (Recv R354 (Send MailBody (Recv R2yz (Var Z)))))))))
            (Send QUIT Close)))))
    
mkSMTP str port = mkNwService str port (undefined::SMTP)

receive_200 ch = ixdo
  R2yz str <- recv ch
  io_ $ putStrLn (unlines (map ("server ack:"++) str))

receive_500 ch = ixdo
  R5yz str <- recv ch
  io_ $ putStrLn (unlines (map ("server ack:"++) str))

send_receive_200 ch mes = ixdo
  send ch mes
  receive_200 ch

send_receive_354 ch mes = ixdo
  send ch mes
  R354 str <- recv ch
  io_ $ putStrLn ("server ack:"++ str)


sendMailBody sv body = ixdo
  send_receive_354 sv DATA         
  send_receive_200 sv (MailBody body)

  unwind0 sv
  sel2N sv

  send sv QUIT
  close sv

-- | send a mail
sendMail str port from to = ixdo
  sv <- connectNw (mkSMTP str port)
  sendMail' str port from to sv

sendMail' str port from to sv = ixdo
  receive_200 sv

  send_receive_200 sv (EHLO "mydomain")
  unwind0 sv; sel1N sv

  send_receive_200 sv (MAIL from)
  unwind1 sv; sel1N sv
  
  send sv (RCPT to)

  offerN sv (ixdo  
      receive_200 sv
      unwind1 sv
      sel2N sv
      
      sendMailBody sv ["hello full-sessions, for "++to, "-- from "++from]

    ) (ixdo
        receive_500 sv
        send sv QUIT
        close sv
    )

{-
*Main> :t \x y z w -> typecheck1 $ sendMail' x y z w
\x y z w -> typecheck1 $ sendMail' x y z w
  :: (SList ss l) =>
     t1
     -> t11
     -> String
     -> String
     -> Session
          t
          (ss
           :> Recv
                R2yz
                (Send
                   EHLO
                   (Recv
                      R2yz
                      (Rec
                         Z
                         (SelectN
                            (Send
                               MAIL
                               (Recv
                                  R2yz
                                  (Rec
                                     (S Z)
                                     (SelectN
                                        (Send
                                           RCPT
                                           (OfferN
                                              (Recv R2yz (Var (S Z)))
                                              (Recv R5yz (Send QUIT Close))))
                                        (Send
                                           DATA (Recv R354 (Send MailBody (Recv R2yz (Var Z)))))))))
                            (Send QUIT Close))))))
          (ss :> End)
          ()
*Main> 
-}

sender ch = ixdo
  unwind0 ch
  offer ch (ixdo
      sv <- recvS ch
      body <- recv ch
      sendMailBody sv body
      recur1 sender ch
    ) (ixdo
      close ch
    )

-- | send a mail (involves channel-passing between processes)
sendMail_channelpassing str port from to = ixdo
  ch <- new
  sv <- connectNw (mkSMTP str port)
  sendMail_channelpassing' str port from to sv ch

sendMail_channelpassing' str port from to sv ch = ixdo
  
  forkIOs (sender ch)
  
  unwind0 ch
  receive_200 sv

  send_receive_200 sv (EHLO "mydomain")
  unwind0 sv; sel1N sv

  send_receive_200 sv (MAIL from)
  unwind1 sv; sel1N sv
  
  send sv (RCPT to)

  offerN sv (ixdo  
      receive_200 sv
      unwind1 sv
      sel2N sv
      
      sel1 ch
      sendS ch sv
      send ch ["hello full-sessions, for "++to, "-- from "++from]
      
      unwind0 ch
      sel2 ch
      close ch

      io_ (putStrLn "exiting...")

    ) (ixdo
        receive_500 sv
        send sv QUIT
        close sv
        sel2 ch; close ch        
    )

{-
*Main> :t \x y z w -> typecheck2 $ sendMail_channelpassing' x y z w
\x y z w -> typecheck2 $ sendMail_channelpassing' x y z w
  :: (Ended l ss', SList ss'1 l) =>
     t1
     -> t11
     -> String
     -> String
     -> Session
          t
          ((ss'1 :> Bot)
           :> Recv
                R2yz
                (Send
                   EHLO
                   (Recv
                      R2yz
                      (Rec
                         Z
                         (SelectN
                            (Send
                               MAIL
                               (Recv
                                  R2yz
                                  (Rec
                                     (S Z)
                                     (SelectN
                                        (Send
                                           RCPT
                                           (OfferN
                                              (Recv R2yz (Var (S Z)))
                                              (Recv R5yz (Send QUIT Close))))
                                        (Send
                                           DATA (Recv R354 (Send MailBody (Recv R2yz (Var Z)))))))))
                            (Send QUIT Close))))))
          ((ss'1 :> End) :> End)
          ()
*Main> 
-}

instance Message EHLO where
  showMessage (EHLO domain) = "EHLO " ++ domain ++ "\r\n"
  parseMessage = undefined

instance Message MAIL where
  showMessage (MAIL revpath) = "MAIL FROM:<"++revpath++">\r\n"
  parseMessage = undefined

instance Message R2yz where
  showMessage = undefined
  parseMessage r = case readRes r of
    (ls@(('2':_):_),r') -> Just (R2yz ls,r')
    _ -> Nothing
 
instance Message R4yz where
  showMessage = undefined
  parseMessage r = case readRes r of
    (ls@(('4':_):_),r') -> Just (R4yz ls,r')
    _ -> Nothing

instance Message R5yz where
  showMessage = undefined
  parseMessage r = case readRes r of
    (ls@(('5':_):_),r') -> Just (R5yz ls,r')
    _ -> Nothing

instance Message R220 where
  showMessage = undefined
  parseMessage r = case readRes r of
    ([l@('2':'2':'0':_)],r') -> Just (R220 l,r')
    _ -> Nothing

instance Message R354 where
  showMessage = undefined
  parseMessage r = case readRes r of
    ([l@('3':'5':'4':_)],r') -> Just (R354 l,r')
    _ -> Nothing

instance Message RCPT where
  showMessage (RCPT addr) = "RCPT TO:<"++addr++">\r\n"
  parseMessage = undefined

instance Message DATA where
  showMessage DATA = "DATA\r\n"
  parseMessage = undefined

instance Message MailBody where
  showMessage (MailBody ls) = mailBody ls
  parseMessage = undefined

instance Message QUIT where
  showMessage QUIT = "QUIT\r\n"
  parseMessage = undefined

cut :: Char -> String -> (String, String)
cut c s = let (l,r) = span (/=c) s in (l,safetail r)
  where
    safetail (_:s) = s
    safetail []    = []

line :: String -> (String, String)
line = cut '\n'

code_line s = splitAt 3 s

readRes :: String -> ([String],String)
readRes s =
      let (l, r)       = line s
          (code,l')    = code_line l      
      in 
        case head l' of 
           '-' -> let (ls,r') = readRes r in (l:ls,r')
           _   -> ([l],r)
{- 
http://tools.ietf.org/html/rfc2821#section-4.5.2
4.5.2 Transparency


   Without some provision for data transparency, the character sequence
   "<CRLF>.<CRLF>" ends the mail text and cannot be sent by the user.
   In general, users are not aware of such "forbidden" sequences.  To
   allow all user composed text to be transmitted transparently, the
   following procedures are used:

   -  Before sending a line of mail text, the SMTP client checks the
      first character of the line.  If it is a period, one additional
      period is inserted at the beginning of the line.

   -  When a line of mail text is received by the SMTP server, it checks
      the line.  If the line is composed of a single period, it is
      treated as the end of mail indicator.  If the first character is a
      period and there are other characters on the line, the first
      character is deleted.
-}
-- each line should be 7 bit strings
mailBody :: [String] -> String
mailBody ls = mb ls []
  where
    mb (l@('.':_):ls) s = '.':l ++ "\r\n"++mb ls s
    mb (l:ls) s   = l ++ "\r\n" ++ mb ls s
    mb [] s = ".\r\n" ++ s

main = do
  putStrLn "host name of SMTP server:"
  host <- getLine
  putStrLn "port number:"
  portstr <- getLine
  putStrLn "from:"
  from <- getLine
  putStrLn "to:"
  to <- getLine
  runS $ sendMail host (read portstr) from to
  -- runS $ sendMail_channelpassing host (read portstr) from to