    module Web.Action(actionWeb) where

    import CmdLine.All
    import Hoogle.All
    import Hoogle.Query.All
    import Hoogle.Item.All
    import Hoogle.Search.All
    import Numeric
    import General.Code
    import System.IO.Unsafe(unsafeInterleaveIO)
    import Web.Page
    import Web.Text
    import Text.ParserCombinators.Parsec
    import Data.TagStr
    import Data.Range
    import Data.Binary.Defer.Index
    import Data.Generics.Uniplate

    import Data.Time.Clock
    import Data.Time.Calendar
    import General.CGI(cgiArgs)
    import Paths_hoogle

    logFile = "log.txt"

    actionWeb :: CmdQuery -> IO ()
    actionWeb q = do
        logMessage q
        res <-
            if Mode "suggest" `elem` queryFlags q then do
                putStr "Content-type: application/json\n\n"
                runSuggest q
            else do
                putStr "Content-type: text/html\n\n"
                (skipped,dbs) <- loadDataBases q
                return $ unlines $ header (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer
        putStrLn res
        when (Debug `elem` queryFlags q) $
            writeFile "temp.htm" res
        sequence_ [writeFile x res | Output x <- queryFlags q]

    logMessage :: CmdQuery -> IO ()
    logMessage q = do
        time <- getCurrentTime
        cgi <- liftM (fromMaybe []) cgiArgs
        appendFile logFile $ (++ "\n") $ unwords $
            [showGregorian (utctDay time)
            ,show (queryText q)] ++
            ["?" ++ a ++ "=" ++ c ++ b ++ c | (a,b) <- cgi, let c = ['\"' | any isSpace b]]

    runSuggest :: CmdQuery -> IO String
    runSuggest CmdQuery{query=Right Query{scope=[], names=[x], typeSig=Nothing}} = do
        root <- getDataDir
        db <- loadDataBase $ root </> "default.hoo"
        let res = take 8 $ completions db x
        return $ "[" ++ show x ++ "," ++ show res ++ "]"
    runSuggest _ = return ""

    -- is the package not something that might go wrong
    safePackage :: String -> Bool
    safePackage = all $ \x -> isAlphaNum x || x `elem` "-_"

    -- return the databases you loaded, and those you can't
    -- guarantees not to actually load the databases unless necessary
    -- TODO: Should say which databases are ignored
    loadDataBases :: CmdQuery -> IO ([String], [DataBase])
    loadDataBases CmdQuery{query=Right q} = do
        let pkgs = nub [x | PlusPackage x <- scope q, safePackage x]
            files = if null pkgs then ["default"] else pkgs
        root <- getDataDir
        files <- filterM doesFileExist $ map (\x -> root </> x <.> "hoo") files
        dbs <- unsafeInterleaveIO $ mapM loadDataBase files
        return ([], dbs)
    loadDataBases _ = return ([], [])

    -- TODO: Should escape the query text
    runQuery :: [DataBase] -> CmdQuery -> [String]
    runQuery dbs CmdQuery{queryText = text, query = Left err} =
        ["<h1><b>Parse error in user query</b></h1>"
        ,"<p>"
        ,"  Query: <tt>" +& pre ++ "<span id='error'>" +& post2 ++ "</span></tt><br/>"
        ,"</p><p>"
        ,"  Error: " +& drop 1 (dropWhile (/= ':') $ show err) ++ "<br/>"
        ,"</p><p>"
        ,"  For information on what queries should look like, see the"
        ,"  <a href='http://www.haskell.org/haskellwiki/Hoogle'>user manual</a>."
        ,"</p>"
        ]
        where
            (pre,post) = splitAt (sourceColumn (errorPos err) - 1) text
            post2 = if null post then concat (replicate 3 "&nbsp;") else post

    runQuery dbs q | not $ usefulQuery $ fromRight $ query q = welcome

    runQuery dbs cq@CmdQuery{query = Right q, queryFlags = flags} =
        ["<h1>Searching for " ++ qstr ++ "</h1>"] ++
        ["<p>" ++ showTagHTML (transform qurl sug) ++ "</p>" | Just sug <- [suggestQuery dbs q]] ++
        if null res then
            ["<p>No results found</p>"]
        else
            ["<table>"] ++
            concatMap (uncurry renderRes) pre ++
            insertMore (concatMap (uncurry renderRes) now) ++
            [moreResults | not $ null post] ++
            ["</table>"]
        where
            start = headDef 0 [i-1 | Start i <- flags]
            count = headDef 20 [n | Count n <- flags]
            res = zip [0..] $ searchRange (rangeStartCount 0 (start+count+1)) dbs q
            (pre,res2) = splitAt start res
            (now,post) = splitAt count res2

            moreResults = "<tr><td></td><td><a href=\"" +& urlMore ++ "\" class='more'>Show more results</a></td></tr>"
            urlMore = "?hoogle=" +% queryText cq ++ "&start=" ++ show (start+count+1) ++ "#more"

            qstr = unwords $ ["<b>" +& n ++ "</b>" | n <- names q] ++
                   ["::" | names q /= [] && isJust (typeSig q)] ++
                   [showTagHTML (renderEntryText view $ renderTypeSig t) | Just t <- [typeSig q]]
            view = [ArgPosNum i i | i <- [0..10]]

            qurl (TagHyperlink url x) | "query:" `isPrefixOf` url = TagHyperlink ("?hoogle=" +% drop 6 url) x
            qurl x = x

    -- insert <a name=more> where you can
    insertMore :: [String] -> [String]
    insertMore [] = []
    insertMore (x:xs) = f x : xs
        where
            f ('>':xs) | not $ "<td" `isPrefixOf` xs = "><a name='more'></a>" ++ xs
            f (x:xs) = x : f xs
            f [] = []

    renderRes :: Int -> Result -> [String]
    renderRes i r =
            [tr $ modname ++ td "ans" (href urlEnt $ showTagHTMLWith url text)
            ,tr $ pkgname ++ td "doc" docs]
        where
            ent = fromLink $ resultEntry r

            (modu,text,_) = renderResult r
            modname = td "mod" $ maybe "" (href urlMod . showModule) modu
            pkgname = td "pkg" $ href urlPkg $ packageName $ fromLink $ entryPackage ent

            docs = ("<div id='d" ++ show i ++ "' class='shut'>" ++
                       "<a class='docs' onclick='return docs(" ++ show i ++ ")' href='" +& urlEnt ++ "'></a>") +?
                       (showTagHTML $ renderHaddock $ entryDocs ent) +?
                   "</div>"

            urlPkg = entryPackageURL ent
            urlMod = entryModuleURL ent
            urlEnt = entryURL ent

            url (TagHyperlink _ x)
                | null urlEnt = Just $ "<span class='a'>" ++ showTagHTML x ++ "</span>"
                | otherwise = Just $ "</a><a href='" +& urlEnt ++ "'>" ++ showTagHTML x ++
                                     "</a><a class='dull' href='" +& urlEnt ++ "'>"
            url _ = Nothing

    tr x = "<tr>" ++ x ++ "</tr>"
    td c x = "<td" ++ (if null c then "" else " class='" ++ c ++ "'") ++ ">" ++ x ++ "</td>"
    href url x = if null url then x else "<a class='dull' href='" +& url ++ "'>" ++ x ++ "</a>"