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 ""
safePackage :: String -> Bool
safePackage = all $ \x -> isAlphaNum x || x `elem` "-_"
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 ([], [])
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 " ") 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 [i1 | 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
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>"