content: -- Reduced from Codec.MIME.String.Headers from mime-string-0.5
  module T17516 (get_addr_spec, get_to) where
  
  import Prelude hiding ( (<*>), (<$>), (<*), (<$) )
  import Data.Char
  import Data.List (intersperse)
  
  import T17516A
  
  -----------------------
  -- Utils
  
  ignore :: Parser inp a -> Parser inp ()
  ignore p = () <$  p
  
  boxp :: Parser inp a -> Parser inp [a]
  boxp p = box <$> p
  
  -----------------------
  -- RFC 2234
  
  p_CTL :: Parser Char Char
  p_CTL = pPred (\c -> ord c < 32 || ord c == 127)
  
  p_SP :: Parser Char Char
  p_SP = pChar ' '
  
  p_HTAB :: Parser Char Char
  p_HTAB = pChar '\t'
  
  p_WSP :: Parser Char Char
  p_WSP = p_SP <|> p_HTAB
  
  -----------------------
  -- RFC 2822
  
  p_NO_WS_CTL :: Parser Char Char
  p_NO_WS_CTL = pPred (\c -> let o = ord c in 1 <= o && o <= 8
                                           || o == 11
                                           || o == 12
                                           || 14 <= o && o <= 31
                                           || o == 127)
  
  -- If we follow the spec precisely then we get pMany (pMany), and hence
  -- non-termination, so we merge the definition of p_obs_text in.
  p_text :: Parser Char String
  p_text = concat
       <$> pMany (
                      p_encoded_words
                  <|  boxp (pPred (\c -> let o = ord c in 0 <= o && o <= 9
                                                       || o == 11
                                                       || o == 12
                                                       || 14 <= o && o <= 127))
                 )
  
  -- We are lax about checking they have any necessary surrounding
  -- whitespace
  p_encoded_words :: Parser Char String
  p_encoded_words = (\x xs -> x ++ concat xs)
                <$> p_encoded_word
                <*> pMany (id <$  cws <*> p_encoded_word)
  
  -- XXX What happens if iconv doesn't understand the charset "cs"?
  p_encoded_word :: Parser Char String
  p_encoded_word = (\_ dec text -> dec text)
               <$  pString "=?"
               <*> p_charset
               <*  pChar '?'
               <*> p_encoding
               <*  pChar '?'
               <*> p_encoded_text
               <*  pString "?="
  
  -- token definition inlined as they use a different one to p_token.
  p_charset :: Parser Char String
  p_charset = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_especials))
  
  p_especials :: Parser Char Char
  p_especials = pPred (`elem` "()<>@,;:\\\"/[]?.=")
  
  -- This is much stricter than specified, but if it's not [qQbB] then
  -- we'd want to fall back to showing it as a string anyway.
  p_encoding :: Parser Char (String -> String)
  p_encoding = id <$  (pChar 'Q' <|> pChar 'q')
           <|> id <$  (pChar 'B' <|> pChar 'b')
  
  p_encoded_text :: Parser Char String
  p_encoded_text = pMany (pPred (\c -> isAsciiPrint c && c /= '?' && c /= ' '))
  
  p_quoted_pair :: Parser Char String
  p_quoted_pair = id <$  pChar '\\' <*> p_text <|> boxp p_obs_qp
  
  p_obs_qp :: Parser Char Char
  p_obs_qp = id <$  pChar '\\' <*> pPred isAscii
  
  -- Done differently as the newlines are already gone
  p_FWS :: Parser Char String
  p_FWS = pMany p_WSP
  
  p_ctext :: Parser Char Char
  p_ctext = p_NO_WS_CTL
        <|> pPred (\c -> let o = ord c in 33 <= o && o <= 39
                                       || 42 <= o && o <= 91
                                       || 93 <= o && o <= 126)
  
  p_ccontent :: Parser Char ()
  p_ccontent = ignore p_ctext <|> ignore p_quoted_pair <|> p_comment
  
  p_comment :: Parser Char ()
  p_comment = ()
          <$  pChar '('
          <*  pMany (() <$  pMany p_NO_WS_CTL <*  p_ccontent)
          <*  pMany p_NO_WS_CTL
          <*  pChar ')'
  
  -- We might want to keep the result. If we do then we also need to
  -- handle encoded words properly.
  -- This isn't quite CFWS as we need to be able to accept "1.0"
  -- as a MIME version with cws between all the characters.
  -- Also, we've already removed all the newlines in the headers.
  cws :: Parser Char ()
  cws = ignore $ pMany (ignore (pAtLeast 1 p_WSP) <|> p_comment)
  
  p_qtext :: Parser Char Char
  p_qtext = p_NO_WS_CTL
        <|> pPred (\c -> let o = ord c in o == 33
                                       || 35 <= o && o <= 91
                                       || 93 <= o && o <= 126)
  
  p_qcontent :: Parser Char String
  p_qcontent = boxp p_qtext
           <|> p_quoted_pair
  
  p_quoted_string :: Parser Char String
  p_quoted_string = (++)
                <$  cws
                <*  pChar '"'
                <*> (concat <$> pMany ((++) <$> pOptDef "" p_FWS <*> p_qcontent))
                <*> pOptDef "" p_FWS
                <*  pChar '"'
  
  p_dcontent :: Parser Char String
  p_dcontent = boxp p_dtext <|> p_quoted_pair
  
  p_dtext :: Parser Char Char
  p_dtext = p_NO_WS_CTL
        <|> pPred (\c -> let o = ord c in 33 <= o && o <= 90
                                       || 94 <= o && o <= 126)
  
  p_atom :: Parser Char String
  p_atom = id
       <$  cws
       <*> pAtLeast 1 p_atext
       <*  cws
  
  p_atext :: Parser Char Char
  p_atext = pPred (\c -> isAsciiAlphaNum c || c `elem` "!#$%&'+-/=?^_`{|}~")
  
  p_dot_atom :: Parser Char String
  p_dot_atom = id
           <$  cws
           <*> p_dot_atom_text
           <*  cws
  
  p_word :: Parser Char String
  p_word = p_atom <|> p_quoted_string
  
  -- This incorporates obs-phrase
  p_phrase :: Parser Char [String]
  p_phrase = (:)
         <$> (p_encoded_words <|  p_word)
         <*> pMany (id <$  cws <*> (p_encoded_words <|  p_word <|  pString "."))
     <|> boxp p_quoted_string
  
  p_dot_atom_text :: Parser Char String
  p_dot_atom_text = (\x xs -> x ++ concat xs)
                <$> pAtLeast 1 p_atext
                <*> pMany ((:) <$> pChar '.' <*> pAtLeast 1 p_atext)
  
  p_local_part :: Parser Char String
  p_local_part = p_dot_atom <|> p_quoted_string <|> p_obs_local_part
  
  p_obs_local_part :: Parser Char String
  p_obs_local_part = (\x xs -> x ++ concat xs)
                 <$> p_word
                 <*> pMany ((:) <$> pChar '.' <*> p_word)
  
  p_domain :: Parser Char Domain
  p_domain = Domain <$> p_dot_atom <|> p_domain_literal <|> p_obs_domain
  
  p_domain_literal :: Parser Char Domain
  p_domain_literal = (LiteralDomain . concat)
                 <$  cws
                 <*  pChar '['
                 <*> pMany (    id
                            <$  p_FWS
                            <*> p_dcontent)
                 <*  p_FWS
                 <*  pChar ']'
                 <*  cws
  
  p_obs_domain :: Parser Char Domain
  p_obs_domain = (\x xs -> Domain (x ++ concat xs))
             <$> p_atom
             <*> pMany ((:) <$> pChar '.' <*> p_atom)
  
  data Domain = Domain String | LiteralDomain String
      deriving (Show, Read, Eq)
  
  newtype To = To [Address]
      deriving (Show, Read)
  
  data Address = Address Mailbox
               | Group String [Mailbox]
      deriving (Show, Read)
  
  get_to :: String -> Maybe To
  get_to xs
   = case parse ph_to xs of
         Left t -> Just t
         Right _ -> Nothing
  
  ph_to :: Parser Char To
  ph_to = To <$  cws <*> p_address_list <*  cws <*  pEOI
  
  -- obs-addr-list merged in
  p_address_list :: Parser Char [Address]
  p_address_list = (:)
               <$  pMany (() <$  pChar ',' <*  cws)
               <*> p_address
               <*> pMany (    id
                          <$  pAtLeast 1 (() <$  cws <*  pChar ',')
                          <*  cws
                          <*> p_address)
               <*  pMany (() <$  cws <*  pChar ',')
  
  p_address :: Parser Char Address
  p_address = Address <$> p_mailbox
          <|> p_group
  
  p_group :: Parser Char Address
  p_group = Group
        <$> p_display_name
        <*  cws
        <*  pChar ':'
        <*  cws
        <*> pOptDef [] p_mailbox_list
        <*  cws
        <*  pChar ';'
  
  -- obs-mbox-list merged in
  p_mailbox_list :: Parser Char [Mailbox]
  p_mailbox_list = (:)
               <$  pMany (() <$  pChar ',' <*  cws)
               <*> p_mailbox
               <*> pMany (    id
                          <$  pAtLeast 1 (() <$  cws <*  pChar ',')
                          <*  cws
                          <*> p_mailbox)
               <*  pMany (() <$  cws <*  pChar ',')
  
  data Mailbox = Mailbox (Maybe String) RoutedEmailAddress
      deriving (Show, Read, Eq)
  
  p_mailbox :: Parser Char Mailbox
  p_mailbox = p_name_addr
          <|> (Mailbox Nothing . NormalEmailAddress) <$> p_addr_spec
  
  p_name_addr :: Parser Char Mailbox
  p_name_addr = Mailbox
            <$> pMaybe p_display_name
            <*  cws
            <*> p_angle_addr
  
  data EmailAddress = EmailAddress String Domain
      deriving (Show, Read, Eq)
  
  data RoutedEmailAddress = NormalEmailAddress          EmailAddress
                          | RoutedEmailAddress [Domain] EmailAddress
      deriving (Show, Read, Eq)
  
  p_angle_addr :: Parser Char RoutedEmailAddress
  p_angle_addr = ($)
             <$  pChar '<'
             <*  cws
             -- This next makes us also satisfy obs-angle-addr
             <*> pOptDef NormalEmailAddress
                         (RoutedEmailAddress <$> p_obs_route <*  cws)
             <*> p_addr_spec
             <*  cws
             <*  pChar '>'
  
  get_addr_spec :: String -> Maybe EmailAddress
  get_addr_spec xs
   = case parse p_addr_spec xs of
         Left e -> Just e
         Right _ -> Nothing
  
  p_addr_spec :: Parser Char EmailAddress
  p_addr_spec  = EmailAddress
             <$> p_local_part
             <*  cws
             <*  pChar '@'
             <*  cws
             <*> p_domain
  
  p_display_name :: Parser Char String
  p_display_name = (concat . intersperse " ") <$> p_phrase
  
  p_obs_route :: Parser Char [Domain]
  p_obs_route = id <$> p_obs_domain_list <*  pChar ':'
  
  p_obs_domain_list :: Parser Char [Domain]
  p_obs_domain_list = (:)
                  <$  pChar '@'
                  <*  cws
                  <*> p_domain
                  <*> pMany (    id
                             <$  pMaybe (() <$  cws <*  pChar ',')
                             <*  cws
                             <*  pChar '@'
                             <*  cws
                             <*> p_domain)
  
  -- Utils
  
  isAsciiPrint :: Char -> Bool
  isAsciiPrint c = isAscii c && isPrint c
  
  isAsciiAlphaNum :: Char -> Bool
  isAsciiAlphaNum c = isAscii c && isAlphaNum c
  
  box :: a -> [a]
  box x = [x]
  