module NewsFetchF(newsFetchF) where
import Fudgets
import NntpF
import URL(URL(..))
import MimeMessage(splitmsg,getheader) --,header,headerName,lookupHeader
import HeaderNames(subject,from,contentType)
import Dew(decodeEncodedWords)
--import DecodeText(decodeText)
import Http
import HtmlEntities(encode)
import Data.Char(isSpace)

newsFetchF :: F URL (Either String (URL,Either String HttpResponseStr))
newsFetchF = loopThroughRightF (absF ctrlSP0) nntpF

ctrlSP0 = putStatusMsg "News fetcher starting..." ctrlSP

ctrlSP =
  getSP $ \ msg ->
  case msg of
    Right url@(URL _ _ _ id _) ->
      if '@' `elem` id
      then reqArticleById url ("<"++id++">")
      else case break (=='/') id of
             (_,"") -> listGroup url id
	     (grp,'/':arts) ->
	        case break (=='-') arts of
		  (art,"") -> reqArticleByNum url grp (read art)
		  (art1,'-':art2) -> listArticles url grp (read art1) (read art2)
    _ -> ctrlSP

reqArticleByNum url grp num =
  putStatusMsg ("Fetching article "++show num++" in "++grp) $
  nntpCmd (GetArticle [Head,Body] grp num) $ getArticle url

reqArticleById url articleId =
  putStatusMsg ("Fetching article id "++articleId) $
  nntpCmd (GetArticleWithId [Head,Body] articleId) $ getArticle url

getArticle url resp =
  case resp of
    Article _ _ _ ls -> putAns url (okResp "message/rfc822" (unlines ls))
                        ctrlSP
    NntpError s -> putErr url s ctrlSP

getGroup url groupName cont =
  nntpCmd (GetGroup groupName) $ \ resp ->
  case resp of
    Group (grp,cnt,first,last) -> cont first last
    NntpError s -> putErr url s ctrlSP

listGroup url grp =
  getGroup url grp $ \ first last ->
  listGroupArticles url grp first last (max first (last-20)) last

listArticles url grp wfirst wlast =
  getGroup url grp $ \ efirst elast ->
  listGroupArticles url grp efirst elast (max efirst wfirst) (min elast wlast)

listGroupArticles url grp efirst elast wfirst wlast =
  getHeaders grp wfirst wlast $ \ hdrs ->
  putAns url (articleList grp efirst elast wfirst wlast hdrs) $
  ctrlSP

okResp ty = HttpResp (SC 200 "OK nntp") [header contentType ty]

articleList grp efirst elast wfirst wlast hdrs =
    okResp "text/html" $
    unlines $
    "<UL>":
      (if efirst<wfirst then ref "Earlier articles" (wfirst-20) (wfirst-1)
       else [])++
      map artref hdrs ++
      (if elast>wlast then ref "Later articles" (wlast+1) (wlast+21)
       else [])++
      ["</UL>"]
  where
    ref s f t =
      ["<LI><A HREF=news:"++grp++"/"++show f++"-"++show t++">"++s++"</A>"]
    artref (id,h) =
      "<LI><A HREF=\"news:"++aid++"\"><B>"++subj++" </B> </A> <I> "++auth++"</I>"
      where
        newsref u s ="<A HREF=\"news:"++u++"\">"++s++"</A>"
        headers = (fst.splitmsg) h
	hdr = encode.decodeEncodedWords.getheader headers
	subj = hdr subject
	auth = hdr from
	aid = trim id
	trim = reverse.trim2.reverse.trim1
	trim1 = dropWhile (\c->isSpace c || c=='<')
	trim2 = dropWhile (\c->isSpace c || c=='>')
	

getHeaders grp first last cont =
    get first []
  where
    get n acc =
      if n>last
      then putStatusMsg ("Got "++show (length acc)++" article heads") $
           cont (reverse acc)
      else putStatusMsg ("Fetching article head "++show n++" in "++grp) $
           nntpCmd (GetArticle [Head] grp n) $ \ resp ->
           case resp of
	     Article _ _ id ls -> get (n+1) ((id,ls):acc)
	     NntpError _ -> get (n+1) acc

putAns url s = putSP (Right (Right (url,(Right s))))
putStatusMsg = putSP. Right. Left
putErr url msg = putSP (Right (Right (url,(Left msg))))

nntpCmd cmd = cmdContSP (Left cmd) resp
  where
    resp (Left r) = Just r
    resp _ = Nothing