module AuxWindows where
import Fudgets hiding (menuF)
import AllFudgets(metaKey)
import ContribFudgets
import Arrows
import Http
import HeaderNames(userAgent,accept,location,dnt)
import MessageHeaders(getheader)
import URL(URL(..),url2str,urlPath,urlHost)
import ParseURL(parseURL)
import HtmlFuns(extractTitle)
import Utils2(trim,mix)
import URLFetchF
import Rdf

import Data.Maybe(maybeToList,fromMaybe)
import Data.Char(isLatin1)
import Unicode(decodeUTF8)

--auxWindowsF = srcDispF >*< what'sRelatedF >*< urlHistoryF

--{-
data AuxWindow = UrlHistory | What'sRelated | SourceDisp deriving Eq
auxWindows = [UrlHistory, What'sRelated, SourceDisp]

auxWindowsF = loopThroughRightF windowsF auxWindowsMenuF
  where
    windowsF = post >^=<
	       listF [(UrlHistory,urlHistoryF),
		      (What'sRelated,what'sRelatedF),
		      (SourceDisp,srcDispF)]
	       >=^^< concatMapSP pre
      where
        pre (Left (w,b)) = [(w,Left b)]
	pre (Right i) = [(w,Right i)|w<-auxWindows]

	post (w,Left b) = Left (w,b)
	post (w,Right o) = Right o

    auxWindowsMenuF =
        nameF "AuxWindowsMenu" $
        menuBarF [subMenuItem idT ws "Windows"]
      where
        ws = [wtoggle UrlHistory "History",
	      wtoggle What'sRelated "What's Related",
	      wtoggle SourceDisp "Source Display"]

        wtoggle w = toggleItem (tr w) False
	tr w = Transl ((,) w) (\ (w',b) -> if w'==w then Just b else Nothing)

    idT = Transl id Just -- why not this?
--}
--------------------------------------------------------------------------------

srcDispF =
  if showSource
  then (idSP -+- nullSP)>^^=<
       --moreShellF "Source"
       --nameF "SourceWindow"
         (delayedAuxShellF {-"Source"-} "WWWB: Source Display" moreF)
       >=^<mapEither id (lines.showHttpResponse' id.snd.fst)
  else nullF

--------------------------------------------------------------------------------

urlHistoryF =
    nameF "HistoryButtons" $ hBoxF $
    loopThroughRightF (absF (historySP (-1) [])) (buttonsF>+<urlListF)
  where
    buttonsF = buttonF' kl lArrowD >+< buttonF' kr rArrowD
      where kl = k "Left"; kr = k "Right"; k sym = setKeys [([metaKey],sym)]
    urlListF = auxShellF {-"History"-} "WWWB: URL History" urlPickListF
    
    historySP pos refs =
        getSP $ either fromLoop fromOutside
      where
	same = historySP pos refs
	urlOut url = putSP (Right (Right (httpGet url)))
	closeOut = putSP . Right . Left
	toList = putSP . Left . Right . Right
	toAuxShell = putSP . Left . Right . Left
	hilight = toList . highlightItems . (:[])
	newpos p = hilight p $ historySP p refs
	fromLoop = either fromButtons (either fromAuxShell fromUrlList)
	fromAuxShell b = closeOut b same
        fromButtons = either fromPrevious fromNext
	fromPrevious _ =
	  if pos>0
	  then urlOut (fst (refs!!pos')) $ newpos pos'
	  else same
	  where pos' = pos-1
	fromNext _ =
	  case splitAt pos' refs of
	    (_,(url,_):_) -> urlOut url $ newpos pos'
	    _ -> same
	  where pos' = pos+1
	fromUrlList (n,(url,_)) = urlOut url $ newpos n
	fromOutside = either openFromOutside urlFromOutside
	openFromOutside b = toAuxShell b same
	urlFromOutside ((url,_),html) =
	  let ref = (url,doctitle)
	      doctitle = case extractTitle html of
	                   Just t -> trim t
			   _ -> url2str url
	  in case find (fst ref) 0 (map fst refs) of
	       Just pos' -> newpos pos'
	       _ -> let refs' = take pos' refs++[ref]
	                pos' = pos+1
	            in toList (replaceAllFrom pos' [ref]) $
		       hilight pos' $
		       historySP pos' refs'

    find x n [] = Nothing
    find x n (y:ys) =
      if x==y
      then Just n
      else find x (n+1) ys

--------------------------------------------------------------------------------

what'sRelatedF = 
    --nameF "What'sRelated" $
    delayedAuxShellF {-lbl-} ("WWWB: "++lbl) relatedF
  where
    lbl = "What's Related"
    
    relatedF= dispRelatedF >==< (clearF>*<fetchRelatedF)
      where clearF = mapF (const [])
        -- Let's hope the route through clearF always is faster!!

    dispRelatedF = post >^=< urlPickListF >=^< replaceAll . extr
      where
        post (n,(url,title)) = httpGet url
	extr = concatMap extr1
	  where
	    extr1 (RdfCmd ("CHILD",attrs)) =
	       maybeToList $
	       do urlstr <- lookup "HREF" attrs
	          url <- parseURL urlstr
		  return (url,linktext url (lookup "NAME" attrs))
	    extr1 (RdfCtx _ rdf) = extr rdf
	    extr1 _ = []
	    fromUTF = map onlyLatin1 . decodeUTF8
	    onlyLatin1 c = if isLatin1 c then c else '¿'
	    linktext url optName =
	        maybe (url2str url) useName optName
	      where
	        useName name = fromUTF name ++ extrHost url
		extrHost url =
		  fromMaybe "" $
		  -- This is of course highly dependent Netscape conventions...
		  do rurl <- parseURL (drop (length "/fwd/rl/") (urlPath url))
		     host <- urlHost rurl
		     return $ " ("++host++")"

    fetchRelatedF =
        mapFilterSP post >^^=< urlFetchF >=^^< mapFilterSP (pre . fst . fst)
      where
	post (Right (url,Right resp)) = parseRdf (respBody resp)
	post _ = Nothing

        pre (URL (Just "http") (Just host) optport path _)
	       | host/="localhost" && '?' `notElem` path =
	    fmap httpGetRdf rurl
	  where
	    rurl = parseURL (wwwrl++host++portstr++path)
	    portstr = opt optport ((':':).show)
	    opt m f = maybe "" f m

	    wwwrl = "http://www-rl.netscape.com/wtgn?"
        pre _ = Nothing

--------------------------------------------------------------------------------
{-
auxShellF lbl title fud =
  loopThroughRightF
    (wmShellF' (setVisible False) title fud)
    (Right>^=<toggleButtonF lbl>=^<const False)
-}

urlPickListF = stripInputMsg >^=< pickListF snd

--------------------------------------------------------------------------------

httpGetRdf url = httpReq' ["text/rdf"] (url,HttpGet)

httpGet url = httpReq (url,HttpGet)

httpReq = httpReq' doctypes
  where
    doctypes = ["text/"++t | t<-["html","plain","gemini"]]++["*/*;q=0.5"] 

httpReq' types (url,method) = HttpReq url method httpHdrs
  where
    httpHdrs =
      [header userAgent "WWWBrowser/0 HttpFetchF (wwwbrowser@altocumulus.org)",
       header dnt "1",
       header accept (mix types ",")]

docUrl url resp@(HttpResp { respHdrs=hdrs }) =
  case getheader hdrs location of
    "" -> url
    s -> fromMaybe url (parseURL s)

--------------------------------------------------------------------------------

showSource = argFlag "source" True