{-# LANGUAGE RecordWildCards #-} module Web.Response(response) where import CmdLine.All import Hoogle import General.Base import General.System import General.Util import General.Web import Web.Page import Data.Generics.Uniplate import Data.Time.Clock import Data.Time.Format import System.Locale import Network.HTTP import System.IO.Unsafe(unsafeInterleaveIO) logFile = "log.txt" response :: FilePath -> CmdLine -> IO (Response String) response resources q = do logMessage q let response x ys = responseOk $ [Header HdrContentType x] ++ ys dbs <- unsafeInterleaveIO $ case queryParsed q of Left _ -> return mempty Right x -> fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q) case web q of Just "suggest" -> fmap (response "application/json" []) $ runSuggest q Just "embed" -> return $ response "text/html" [hdr] $ unlines $ runEmbed dbs q where hdr = Header (HdrCustom "Access-Control-Allow-Origin") "*" Just "ajax" -> return $ response "text/html" [] $ unlines $ runQuery True dbs q Just "web" -> return $ response "text/html" [] $ unlines $ header resources (escapeHTML $ queryText q) ++ runQuery False dbs q ++ footer mode -> return $ response "text/html" [] $ "Unknown webmode: " ++ fromMaybe "none" mode logMessage :: CmdLine -> IO () logMessage q = do time <- getCurrentTime args <- fmap (fromMaybe [("hoogle",queryText q)]) cgiArgs ip <- fmap (fromMaybe "0") $ getEnvVar "REMOTE_ADDR" let shw x = if all isAlphaNum x then x else show x appendFile logFile $ (++ "\n") $ unwords $ [formatTime defaultTimeLocale "%FT%T" time ,ip] ++ [shw a ++ "=" ++ shw b | (a,b) <- args] runSuggest :: CmdLine -> IO String runSuggest cq@Search{queryText=q} = do (_, db) <- loadQueryDatabases (databases cq) mempty let res = completions db q return $ "[" ++ show q ++ "," ++ show res ++ "]" runSuggest _ = return "" runEmbed :: Database -> CmdLine -> [String] runEmbed dbs Search{queryParsed = Left err} = ["Parse error: " ++& errorMessage err ++ ""] runEmbed dbs cq@Search{queryParsed = Right q} | null now = ["No results found"] | otherwise = ["" ++ showTagHTML (transform f $ self $ snd x) ++ "" | x <- now, let url = fromList "" $ map fst $ locations $ snd x] where now = take (maybe 10 (max 1) $ count cq) $ search dbs q f (TagEmph x) = TagBold x f (TagBold x) = x f x = x 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 | fromRight (queryParsed q) == mempty = welcome runQuery ajax dbs cq@Search{queryParsed = Right q, queryText = qt} = (if prefix then ["" ++ showTag sug ++ "
" | Just sug <- [suggestions 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 = "