{-# LANGUAGE RecordWildCards #-} module Web.Response(response) where import CmdLine.All import Hoogle import General.Base import General.Util import General.Web import Web.Page import Data.Generics.Uniplate import Data.Time.Clock import Data.Time.Calendar import Network.HTTP logFile = "log.txt" response :: FilePath -> CmdLine -> IO (Response String) response resources q = do logMessage q let response x = responseOk [Header HdrContentType x] let res ajax = do dbs <- if isRight $ queryParsed q then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q) else return mempty return $ runQuery ajax dbs q case web q of Just "ajax" -> do res <- res True return $ response "text/html" $ unlines res Just "web" -> do res <- res False return $ response "text/html" $ unlines $ header resources (escapeHTML $ queryText q) ++ res ++ footer Just "suggest" -> fmap (response "application/json") $ runSuggest q Just e -> return $ response "text/html" $ "Unknown webmode: " ++ e logMessage :: CmdLine -> IO () logMessage q = do time <- getCurrentTime cgi <- fmap (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 :: CmdLine -> IO String runSuggest cq@Search{queryText=q} = do (_, db) <- loadQueryDatabases (databases cq) (Query [] Nothing []) let res = queryCompletions db q return $ "[" ++ show q ++ "," ++ show res ++ "]" runSuggest _ = return "" runQuery :: Bool -> Database -> CmdLine -> [String] runQuery ajax dbs Search{queryParsed = Left err} = ["
" ," Parse error: " ++& errorMessage err ,"
" ," For information on what queries should look like, see the" ," user manual." ,"
" ] where f (TagEmph x) = Just $ "" ++ showTagHTMLWith f x ++ "" f _ = Nothing runQuery ajax dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome runQuery ajax dbs cq@Search{queryParsed = Right q, queryText = qt} = (if prefix then ["" ++ showTag sug ++ "
" | Just sug <- [querySuggestions dbs q]] ++ if null res then ["No results found
"] else concat (pre ++ now) else concat now) ++ ["" | not $ null post] where prefix = not $ ajax && start2 /= 0 -- show from the start, with header start2 = maybe 0 (subtract 1 . max 0) $ start cq count2 = maybe 20 (max 1) $ count cq src = search dbs q res = [renderRes i (i /= 0 && i == start2 && prefix) x | (i,(_,x)) <- zip [0..] src] (pre,res2) = splitAt start2 res (now,post) = splitAt count2 res2 also = "