module ToHtml(toHtml) where
import Data.Maybe(listToMaybe,mapMaybe)
import Control.Monad(mplus,guard)
import HtmlParser2
import URL
import URLencode(encode)
import Http
import Html
import HtmlTags
import HtmlFuns(extractElements,mapHtmlChars,mapHtmlTags)
import HtmlConOps
import Gemini
--import ParsOps(Error(..))
import MimeMessage as M(parseMessage,MimeMessage(..),orig,normal,contentType,parseParams)
import DecodeText(convertMessageBody,decodeTextMsg',decodeMsg)
import Dew(convertCharset')
import HeaderNames as HN
import Utils2(words',mix,strToLower,pairwith,apFst,apSnd,aboth,chopList,breakAt)

-- debugging:
--import Debug.Trace(trace)
--import MimeMessage(showMessage)
--import HtmlPrinter(printHtml)

toHtml = apFst (apSnd snd) . pairwith toHtml' . apSnd decodeBody
  where
    decodeBody httpResp@HttpResp {respHdrs=hdrs,respBody=body} =
        ((ct,ocset),httpResp{respBody=cbody})
      where
        ct = M.contentType hdrs
        (_,(ocset,cbody)) = convertMessageBody hdrs body
      
toHtml' (url@(URL optproto _ _ path _),
    (ty,HttpResp {respHdrs=hdrs, respBody=body})) =
        {-trace (printHtml html)-} html
  where
    proto = case optproto of Just p -> p ; _ -> "" -- !!
    html = case proto of
	     "gopher" -> case gopherType path of
			   '1' -> gopherDir (stripDots' body)
			   '7' -> gopherDir (stripDots' body)
			   '0' -> plain2html (stripDots body)
			   'h' -> parsHtml (snd ty) (stripDots body)
			   t   -> plain2html ("Unknown gopher document type: "++[t])
	     _ -> msg2html path ty hdrs body

    stripDot ('.':cs) = cs
    stripDot cs       = cs
    stripDots = unlines.stripDots'
    stripDots' = map stripDot.lines
    gopherType "" = '1'
    gopherType "/" = '1'
    gopherType ('/':c:_) = c

msg2html path ((mimetype,params),ocset) hdrs msgbody =
    case mimetype of
      "text/html" -> parsHtml ocset msgbody
      "text/plain" -> plain2html msgbody
      "text/gemini" -> gemini2html msgbody
      "message/rfc822" -> rfc822msg2html msgbody
      ""     -> byext2html
      "file" -> byext2html
      "nlst" -> [body [dir [[href s [txt s]]|s<-lines msgbody]]]
      "list" -> [body [menu [(listEntry s)|s<-lines msgbody]]]
      ctype ->
        case breakAt '/' ctype of
          ("image",_) -> image2html ctype hdrs msgbody
	  ("text",_) -> plain2html ("Content-Type: "++ctype++"\n\n"++msgbody)
          ("multipart",subty) -> multipart2html subty bndry msgbody
            where bndry = lookup "boundary" ps
	  _          -> plain2html ("Content-Type: "++ctype)
  where
    ps = parseParams params
    byext2html =
      case extension path of
	"mosaic-hotlist-default" -> hotlist2html (lines msgbody)
	"htm" -> parsHtml ocset msgbody
	"html" -> parsHtml ocset msgbody
	"newsrc" -> newsrc2html msgbody
	e -> plain2html ({-("Unknown extension: "++e):"":-}msgbody)

    extension = afterlast False '.' . afterlast True '/'
    afterlast b c s = case break (==c) (reverse s) of
		        (e,"") -> if b then s else ""
		        (e,_) -> reverse e
    listEntry s =
       let ws = words' s
           droplast = init --reverse.tail.reverse
           prelen = 16 -- number of words before file name
           (pre,filepost) = splitAt prelen ws
	   (filews,post) = case break (=="->") filepost of
	                     (ws,p@("->":_)) -> (droplast ws,p)
			     (ws,_) -> (ws,[])
           file = concat filews
	   txt' = txt . nbsp . concat
	   nbsp = map nbsp1
	   nbsp1 ' ' = '\xa0'
	   nbsp1 c = c
       in [ctx NOBR [ctx TT [txt' pre],
            href file [HtmlChars file],
	    txt' post -- maybe empty
	  ]]

parsHtml ocset s' =
    case parseHtml s of
      Right html -> maybe convMetaCharset (const id) ocset html
      Left (es,ctx) ->
	[body
	[dl [dt [txt "Syntax error before:"],dd [txt (take 120 ctx++"...")],
	     dt [txt "Expected:"],dd [txt (mix es ", "++".")]],
	 hr, pre [txt s]]]
  where s = fixCR s'

convMetaCharset html = maybe id convert mcs html
  where
    mcs = listToMaybe . mapMaybe charset . extractElements META . take 1 $
          extractElements HEAD html
    charset (HtmlCommand (META,attrs)) = short `mplus` long `mplus` httpEquiv
       where
         short = lookupAttr "CHARSET" attrs

         long = do n <- lookupAttr "NAME" attrs
                   guard $ strToLower n == "charset"
                   lookupAttr "CONTENT" attrs

         httpEquiv = do n <- lookupAttr "HTTP-EQUIV" attrs
                        guard $ strToLower n == "content-type"
                        v <- lookupAttr "CONTENT" attrs
                        lookup "charset" (parseParams v)

    charset _ = Nothing

    convert = maybe id conv . convertCharset'
    conv (_,f) = mapHtmlChars ((:[]) . txt . f) . mapHtmlTags tf
      where tf (t,as) = (t,mapAttrs (aboth f) as)

image2html ty hdrs msgbody =
    [body [p [txt alt,br,imgalt ("data:"++ty++","++encode imgdata) alt]]]
  where
    MimeMsg _ imgdata = decodeMsg (MimeMsg hdrs msgbody)
    alt = ty++", "++show (length imgdata)++" bytes"
  
plain2html s = [body [pre [txt s]]]

gopherDir ls = [body [menu entries]]
  where
    entries = map htmlEntry ls
    htmlEntry "" = [] -- ??
    htmlEntry (t:cs) =
	case chopList (breakAt '\t') cs of
	  name:path:host:port:_ ->
	    let proto = if t=='8' then "telnet" else "gopher"
	        u = url proto host port ('/':t:path)
	    in txt (showType t++": "):
	       if t=='7'
	       then [txt name,cmd' ISINDEX [("ACTION",u)]]
	       else [href u [txt name]]
	  _ -> [txt "???"]

    showType t = --assoc id [t] gopherTypes t
                 maybe [t] id (lookup t gopherTypes)
    url proto host port path =
        url2str $
	URL (Just proto) (Just host) p path Nothing
      where p = case port of
                  "70" -> Nothing
		  _ -> Just (read port)

gopherTypes = 
  [('0',"Text"),
   ('1',"Menu"),
   ('2',"CSO "),
   ('3',"ERR "),
   ('4',"BinHex"),
   ('5',"PCBin"),
   ('6',"uuencoded"),
   ('7',"Search"),
   ('8',"Telnet"),
   ('9',"Binary"),
   ('g',"GIF "),
   ('I',"Image"),
   ('T',"3270"),
   ('h',"Html")]

hotlist2html ls =
    [body [ctx H1 [HtmlChars "Mosaic Hostlist"], ul entries]]
  where
    entries = (map entry.drop 1.pairs) ls
    pairs (x1:x2:xs) = (x1,x2):pairs xs
    pairs _ = []
    entry (urlline,title) = li [href url [HtmlChars title]]
      where url = head (words urlline)

multipart2html subty Nothing msgbody =
    plain2html ("Content-Type: multipart/"++subty)
multipart2html subty (Just boundary) msgbody =
    case subty of
      "mixed" -> all_parts
      "parallel" -> all_parts
      "signed" -> all_parts
      "related" -> all_parts -- hmm
      "alternative" -> part2html (last parts) -- hmm
      _ -> plain2html ("Content-Type: multipart/"++subty)
  where
    all_parts = mix (map part2html (drop 1 parts)) [hr]
    part2html part = rfc822msg2html' False part
    parts = splitMultipart boundary msgbody

splitMultipart boundary =
    map unlines . dropFromLast . chopList (breakAt ("--"++boundary)) . lines
  where
    dropFromLast = reverse . dropLast . reverse
    dropLast (p:ps) = (reverse . dropit $ reverse p):ps
    dropLast [] = []

    dropit ("":l:ls) | l=="--"++boundary++"--" = ls
    dropit ls = ls

rfc822msg2html msgbody = [body (rfc822msg2html' True msgbody)]

rfc822msg2html' showHdrs msgbody =
  --trace msgbody $
  case decodeTextMsg' (parseMessage msgbody) of
      MimeMsg hdrs msgbody ->
          [htmlHdrs hdrs|showHdrs]++msg2html "" (ct,Nothing) hdrs msgbody
        where
          ct = M.contentType hdrs
        --(_,(ocs,cbody)) = convertMessageBody hdrs msgbody
  
htmlHdrs hdrs = ctx' TABLE [("CELLSPACING","0")] (concatMap htmlHdr hdrs)
  where
    htmlHdr (h,r) =
      let h' = orig h
	  th' = ctx' TH [("ALIGN","RIGHT"),("VALIGN","TOP")]
      in if h `elem` interestingHeaders
         then [ctx TR [th' [HtmlChars (h'++":")],ctx TD (augment h r)]]
	 else []

    augment h r =
      case normal h of
        "newsgroups" -> newsrefs r
	"references" -> newsrefs r
	"subject" -> [ctx STRONG [HtmlChars r]]
	"from" -> [ctx ADDRESS [HtmlChars r]]
	_ -> [HtmlChars r]

    newsrefs = (:[]) . p . flip mix [HtmlChars ", "].map newsref.words.map cs
    newsref ref = [href ("news:"++ref) [HtmlChars ref]]

    cs ',' = ' '
    cs '<' = ' '
    cs '>' = ' '
    cs c   = c

newsrc2html newsrc = html
  where
    groups =
        map fst $ filter subscribed $ map (break (`elem` ":!")) $ lines newsrc
      where subscribed = (==":") . take 1 . snd
    html = [body [ul (map grouplink groups)]]
    grouplink group = li [href ("news:"++group) [txt group]]
--
interestingHeaders =
     [subject,from,date,to,cc,HN.contentType,contentTransferEncoding,
      references,organization,newsgroups]

fixCR ('\r':'\n':s) = '\n':fixCR s
fixCR ('\r':s) = '\n':fixCR s
fixCR (c:s) = c:fixCR s
fixCR "" = ""