hoogle 4.2 → 4.2.1
raw patch · 12 files changed
+241/−177 lines, 12 filesdep +blaze-builderdep +enumeratordep +waidep −HTTPdep −networkPVP ok
version bump matches the API change (PVP)
Dependencies added: blaze-builder, enumerator, wai, warp
Dependencies removed: HTTP, network
API changes (from Hackage documentation)
Files
- datadir/resources/hoogle.js +42/−20
- hoogle.cabal +6/−4
- src/CmdLine/Type.hs +1/−2
- src/Console/Log.hs +63/−65
- src/General/Base.hs +9/−0
- src/General/Web.hs +33/−10
- src/Hoogle/Query/Suggest.hs +5/−3
- src/Hoogle/Query/Type.hs +35/−0
- src/Web/All.hs +3/−5
- src/Web/Page.hs +1/−1
- src/Web/Response.hs +4/−4
- src/Web/Server.hs +39/−63
datadir/resources/hoogle.js view
@@ -37,26 +37,31 @@ if (embed && now == ""){self.hide(); return;} watch.start(); + var data = {hoogle:now, mode:ajaxMode, prefix:ajaxPrefix, suffix:ajaxSuffix};+ function complete(e)+ {+ watch.stop();+ if (e.status == 200)+ {+ past.add(now,e.responseText);+ if ($hoogle.val() == now)+ self.showResult(e.responseText);+ }+ else+ self.showError(e.status, e.responseText);+ }++ var args = {url:ajaxUrl, data:data, complete:complete, dataType:"html"} try {- $.ajax({- url: ajaxUrl,- data: {hoogle:now, mode:ajaxMode, prefix:ajaxPrefix, suffix:ajaxSuffix},- dataType: 'html',- complete: function(e){- watch.stop();- if (e.status == 200)- {- past.add(now,e.responseText);- if ($hoogle.val() == now)- self.showResult(e.responseText);- }- else- self.showError(e.status, e.responseText);- }- });+ $.ajax(args); } catch (err) {- // Probably a permissions error from cross domain scripting...- watch.stop();+ try {+ if (!embed) throw err;+ $.ajaxCrossDomain(args);+ } catch (err) {+ // Probably a permissions error from cross domain scripting...+ watch.stop();+ } } }); })@@ -65,11 +70,10 @@ { $hoogle.focus(); $hoogle.select();- var $h1 = $("h1"); var $body = $("#body"); return {- showWaiting: function(){$h1.text("Still working...");},+ showWaiting: function(){$("h1").text("Still working...");}, showError: function(status,text){$body.html("<h1><b>Error:</b> status " + status + "</h1><p>" + text + "</p>")}, showResult: function(text){$body.html(text);} }@@ -288,4 +292,22 @@ function stop(){if (id == undefined) return; window.clearTimeout(id); id = undefined;} function start(){stop(); id = window.setTimeout(function(){id = undefined; fun();}, time);} return {start:start, stop:stop}+}++$.ajaxCrossDomain = function(args)+{+ if (!window.XDomainRequest) throw new Error("the XDomainRequest object is not supported in this browser");++ var xdr = new XDomainRequest();+ xdr.onload = function(){args.complete({status:200, responseText:xdr.responseText});};+ xdr.onerror = function(){args.complete({status:0, responseText:""});};++ var url = "";+ for (var i in args.data)+ {+ if (args.data[i] == undefined) continue;+ url += (url == "" ? "" : "&") + encodeURIComponent(i) + "=" + encodeURIComponent(args.data[i]);+ }+ xdr.open("get", args.url + url);+ xdr.send(); }
hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hoogle-version: 4.2+version: 4.2.1 license: GPL license-file: docs/LICENSE category: Development@@ -24,7 +24,7 @@ resources/*.ico resources/*.js resources/*.png- -- surely a Cabal bug that this isn't picked up by *.js+ -- Cabal doesn't find files with . in them, Cabal bug #794 resources/jquery-1.4.2.js resources/jquery.cookie.js @@ -106,8 +106,10 @@ time, old-locale, cmdargs == 0.6.*, tagsoup >= 0.11 && < 0.13,- network >= 2.2 && < 2.4,- HTTP >= 4000.0 && < 4000.2,+ enumerator == 0.4.*,+ blaze-builder == 0.2.*,+ wai == 0.3.0,+ warp == 0.3.0, Cabal >= 1.8 && < 1.11 other-modules:
src/CmdLine/Type.hs view
@@ -32,7 +32,7 @@ ,queryText :: String } | Data {redownload :: Bool, local :: [String], datadir :: FilePath, threads :: Int, actions :: [String]}- | Server {port :: Int, local_ :: Bool, databases :: [FilePath], resources :: FilePath, nostdin :: Bool}+ | Server {port :: Int, local_ :: Bool, databases :: [FilePath], resources :: FilePath} | Combine {srcfiles :: [FilePath], outfile :: String} | Convert {srcfile :: String, outfile :: String} | Log {logfiles :: [FilePath]}@@ -70,7 +70,6 @@ server = Server {port = 80 &= typ "INT" &= help "Port number" ,resources = "" &= typDir &= help "Directory to use for resources (images, CSS etc)"- ,nostdin = def &= help "Don't read from stdin" ,local_ = def &= help "Rewrite and serve file: links (potential security hole)" } &= help "Start a Hoogle server"
src/Console/Log.hs view
@@ -7,11 +7,9 @@ module Console.Log(logFiles) where import General.Base-import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map -type BString = BS.ByteString- logFiles :: [FilePath] -> IO () logFiles xs = do es <- mapM readEntries xs@@ -23,7 +21,7 @@ data Stats = Stats {hits :: !Int ,searches :: !Int- ,common :: !(Map.Map BString Int)+ ,common :: !(Map.Map LBString Int) } instance Show Stats where@@ -31,7 +29,7 @@ ["Hits: " ++ show hits ,"Searches: " ++ show searches ,"Unique: " ++ show (Map.size common)- ,"Top: " ++ fromList "" (map (BS.unpack . fst) top)+ ,"Top: " ++ fromList "" (map (LBS.unpack . fst) top) ] where top = take 20 $ sortBy (comparing $ negate . snd) $ Map.toList common@@ -46,8 +44,8 @@ where f s@Stats{..} Entry{..} = s {hits = 1 + hits- ,searches = (if BS.null search then 0 else 1) + searches- ,common = if BS.null search then common else Map.insertWith' (+) search 1 common+ ,searches = (if LBS.null search then 0 else 1) + searches+ ,common = if LBS.null search then common else Map.insertWith' (+) search 1 common } @@ -62,8 +60,8 @@ -- READ ENTRIES data Entry = Entry- {search :: BString -- the search performed, "" for blank- ,extra :: [(BString,BString)] -- extra parameters+ {search :: LBString -- the search performed, "" for blank+ ,extra :: [(LBString,LBString)] -- extra parameters ,date :: Maybe (Int,Int,Int) -- date the search was performed ,time :: Maybe (Int,Int,Int) -- time the search was performed ,unique :: Maybe String -- maybe a uniquely identifying string@@ -71,33 +69,33 @@ ,suggest :: Maybe Int -- number of times you hit with suggest for this query } deriving Show -entry = Entry BS.empty [] Nothing Nothing Nothing Nothing Nothing+entry = Entry LBS.empty [] Nothing Nothing Nothing Nothing Nothing readEntries :: FilePath -> IO [Entry] readEntries x = do- src <- BS.readFile x- return $ mapMaybe readEntry $ BS.lines src+ src <- LBS.readFile x+ return $ mapMaybe readEntry $ LBS.lines src -qstr = map BS.pack ["","q","hoogle"]+qstr = map LBS.pack ["","q","hoogle"] -readEntry :: BString -> Maybe Entry+readEntry :: LBString -> Maybe Entry -- log format v1 readEntry x- | Just ('[',x) <- BS.uncons x+ | Just ('[',x) <- LBS.uncons x = do y <- readList x let (a,b) = partition (flip elem qstr . fst) y- return entry{search=fromList BS.empty $ map snd a, extra = b}+ return entry{search=fromList LBS.empty $ map snd a, extra = b} where readList x = do- ('(',x) <- BS.uncons x+ ('(',x) <- LBS.uncons x (a,x) <- readShowString x- (',',x) <- BS.uncons x+ (',',x) <- LBS.uncons x (b,x) <- readShowString x- (')',x) <- BS.uncons x- case BS.uncons x of+ (')',x) <- LBS.uncons x+ case LBS.uncons x of Just (',',x) -> do ys <- readList x return $ (a,b):ys@@ -107,20 +105,20 @@ -- log format v2 readEntry o@x- | BS.length x > 10 && BS.index x 10 == ' '+ | LBS.length x > 10 && LBS.index x 10 == ' ' = do (d,x) <- readDate x- (' ',x) <- BS.uncons x+ (' ',x) <- LBS.uncons x (s,x) <- readShowString x- args <- readArgs $ BS.dropWhile isSpace x+ args <- readArgs $ LBS.dropWhile isSpace x return entry{search = s, date = Just d, extra = filter (flip notElem qstr . fst) args} where readArgs x- | Just ('?',x) <- BS.uncons x = do- (a,x) <- return $ BS.break (== '=') x- ('=',x) <- BS.uncons x+ | Just ('?',x) <- LBS.uncons x = do+ (a,x) <- return $ LBS.break (== '=') x+ ('=',x) <- LBS.uncons x (b,x) <- readQuoteString x- x <- return $ BS.dropWhile isSpace x+ x <- return $ LBS.dropWhile isSpace x ys <- readArgs x return $ (a,b) : ys | otherwise = Just []@@ -128,23 +126,23 @@ -- log format v3 readEntry x- | BS.length x > 10 && BS.index x 10 == 'T'+ | LBS.length x > 10 && LBS.index x 10 == 'T' = do ((d,t),x) <- readDateTime x- (' ',x) <- BS.uncons x- (u,x) <- return $ first BS.unpack $ BS.break (== ' ') x- args <- readArgs $ BS.dropWhile isSpace x+ (' ',x) <- LBS.uncons x+ (u,x) <- return $ first LBS.unpack $ LBS.break (== ' ') x+ args <- readArgs $ LBS.dropWhile isSpace x let (a,b) = partition (flip elem qstr . fst) args return entry{date = Just d, time = Just t, extra = b,- search=fromList BS.empty $ map snd a,+ search=fromList LBS.empty $ map snd a, unique = if u == "0" then Nothing else Just u} where readArgs x- | BS.null x = Just []+ | LBS.null x = Just [] | otherwise = do (a,x) <- readShortString x- ('=',x) <- BS.uncons x+ ('=',x) <- LBS.uncons x (b,x) <- readShortString x- ys <- readArgs $ BS.dropWhile isSpace x+ ys <- readArgs $ LBS.dropWhile isSpace x return $ (a,b):ys readEntry _ = Nothing@@ -153,53 +151,53 @@ --------------------------------------------------------------------- -- READ UTILITIES -readDate :: BString -> Maybe ((Int,Int,Int), BString)+readDate :: LBString -> Maybe ((Int,Int,Int), LBString) readDate x = do- (d1,x) <- BS.readInt x- ('-',x) <- BS.uncons x- (d2,x) <- BS.readInt x- ('-',x) <- BS.uncons x- (d3,x) <- BS.readInt x+ (d1,x) <- LBS.readInt x+ ('-',x) <- LBS.uncons x+ (d2,x) <- LBS.readInt x+ ('-',x) <- LBS.uncons x+ (d3,x) <- LBS.readInt x return ((d1,d2,d2),x) -readDateTime :: BString -> Maybe (((Int,Int,Int),(Int,Int,Int)), BString)+readDateTime :: LBString -> Maybe (((Int,Int,Int),(Int,Int,Int)), LBString) readDateTime x = do (d,x) <- readDate x- ('T',x) <- BS.uncons x- (t1,x) <- BS.readInt x- (':',x) <- BS.uncons x- (t2,x) <- BS.readInt x- (':',x) <- BS.uncons x- (t3,x) <- BS.readInt x+ ('T',x) <- LBS.uncons x+ (t1,x) <- LBS.readInt x+ (':',x) <- LBS.uncons x+ (t2,x) <- LBS.readInt x+ (':',x) <- LBS.uncons x+ (t3,x) <- LBS.readInt x return ((d,(t1,t2,t3)),x) -- | String, as produced by show-readShowString :: BString -> Maybe (BString, BString)+readShowString :: LBString -> Maybe (LBString, LBString) readShowString o@x = do- ('\"',x) <- BS.uncons x- (a,x) <- return $ BS.break (== '\"') x- if '\\' `BS.elem` a then do- [(a,x)] <- return $ reads $ BS.unpack o- return (BS.pack a, BS.pack x)+ ('\"',x) <- LBS.uncons x+ (a,x) <- return $ LBS.break (== '\"') x+ if '\\' `LBS.elem` a then do+ [(a,x)] <- return $ reads $ LBS.unpack o+ return (LBS.pack a, LBS.pack x) else do- ('\"',x) <- BS.uncons x+ ('\"',x) <- LBS.uncons x return (a, x) -- | Either a string produced by show, or a isAlphaNum terminated chunk-readShortString :: BString -> Maybe (BString, BString)-readShortString x | Just ('\"',_) <- BS.uncons x = readShowString x- | otherwise = Just $ BS.span isAlphaNum x+readShortString :: LBString -> Maybe (LBString, LBString)+readShortString x | Just ('\"',_) <- LBS.uncons x = readShowString x+ | otherwise = Just $ LBS.span isAlphaNum x -- | Either a space terminated chunk, or a quote terminated chunk-readQuoteString :: BString -> Maybe (BString, BString)-readQuoteString x | Just ('\"',x) <- BS.uncons x = do- (a,x) <- return $ BS.break (== '\"') x- ('\"',x) <- BS.uncons x- return (a, BS.dropWhile isSpace x)+readQuoteString :: LBString -> Maybe (LBString, LBString)+readQuoteString x | Just ('\"',x) <- LBS.uncons x = do+ (a,x) <- return $ LBS.break (== '\"') x+ ('\"',x) <- LBS.uncons x+ return (a, LBS.dropWhile isSpace x) readQuoteString x = do- (a,x) <- return $ BS.break (== ' ') x- return (a, BS.dropWhile isSpace x)+ (a,x) <- return $ LBS.break (== ' ') x+ return (a, LBS.dropWhile isSpace x)
src/General/Base.hs view
@@ -14,12 +14,21 @@ import Data.Maybe as X import Data.Monoid as X import Data.Ord as X+import Data.String as X import Debug.Trace as X (trace) import Numeric as X (readHex,showHex) import System.FilePath as X hiding (combine)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS import Control.Exception(bracket) import System.IO+++type LBString = LBS.ByteString+type BString = BS.ByteString+lbsUnpack = LBS.unpack+bsUnpack = BS.unpack -- | A URL, or internet address. These addresses will usually start with either
src/General/Web.hs view
@@ -5,29 +5,44 @@ -} module General.Web(- responseOk, responseBadRequest, responseNotFound, responseError,+ statusOK, hdrContentType, hdrCacheControl,+ responseOK, responseBadRequest, responseNotFound, responseError,+ responseFlatten, URL, filePathToURL, combineURL, escapeURL, (++%), unescapeURL, escapeHTML, (++&), htmlTag,- Args, cgiArgs, parseHttpQueryArgs+ Args, cgiArgs, cgiResponse, parseHttpQueryArgs ) where import General.System import General.Base-import Network.HTTP+import Network.Wai+import Blaze.ByteString.Builder(toLazyByteString)+import Data.Enumerator.List(consume)+import qualified Data.ByteString.Lazy.Char8 as LBS -instance Functor Response where- fmap f x = x{rspBody = f $ rspBody x} +type Args = [(String, String)] -responseOk = Response (2,0,0) "OK"-responseBadRequest x = Response (4,0,0) "Bad Request" [] $ "Bad request: " ++ x-responseNotFound x = Response (4,0,4) "Not Found" [] $ "File not found: " ++ x-responseError x = Response (5,0,0) "Internal Server Error" [] $ "Internal server error: " ++ x +---------------------------------------------------------------------+-- WAI STUFF -type Args = [(String, String)]+statusOK = status200+hdrContentType = fromString "Content-Type" :: ResponseHeader+hdrCacheControl = fromString "Cache-Control" :: ResponseHeader +responseOK = responseLBS statusOK+responseBadRequest x = responseLBS status400 [] $ fromString $ "Bad request: " ++ x+responseNotFound x = responseLBS status404 [] $ fromString $ "File not found: " ++ x+responseError x = responseLBS status500 [] $ fromString $ "Internal server error: " ++ x ++responseFlatten :: Response -> IO (Status, ResponseHeaders, LBString)+responseFlatten r = responseEnumerator r $ \s hs -> do+ builders <- consume+ return (s, hs, toLazyByteString $ mconcat builders)++ --------------------------------------------------------------------- -- HTML STUFF @@ -104,6 +119,14 @@ return $ case x of Nothing -> Nothing Just y -> Just $ parseHttpQueryArgs $ ['=' | '=' `notElem` y] ++ y+++cgiResponse :: Response -> IO ()+cgiResponse r = do+ (status,headers,body) <- responseFlatten r+ LBS.putStr $ LBS.unlines $+ [LBS.fromChunks [ciOriginal a, fromString ": ", b] | (a,b) <- headers] +++ [fromString "",body] ---------------------------------------------------------------------
src/Hoogle/Query/Suggest.hs view
@@ -20,9 +20,11 @@ where f x = length x == 6 && "oogle" `isSuffixOf` x -- They searched for "Int to Float", they meant "Int -> Float"-suggestQuery db q@Query{typeSig=Nothing, names=names} | "to" `elem` names = Just $ didYouMean q2- where q2 = fixup db $ q{names = [] ,typeSig = Just $ TypeSig [] t2}- t2 = TFun $ map (toApp . map toLitVar) $ split "to" names+suggestQuery db q@Query{typeSig=Nothing, names=names}+ | length parts > 1 && all (not . null) parts = Just $ didYouMean q2+ where parts = split "to" names+ q2 = fixup db $ q{names = [] ,typeSig = Just $ TypeSig [] t2}+ t2 = TFun $ map (toApp . map toLitVar) parts -- They search for "Maybe a", did they mean ":: Maybe a" suggestQuery db q@Query{typeSig=Nothing, names=names} | length names > 1 && all f names = Just $ didYouMean q2
src/Hoogle/Query/Type.hs view
@@ -5,6 +5,41 @@ import General.Base import Hoogle.Type.All +{-+GOALS OF THE QUERY REWRITE:++Query stores enough data to round trip perfectly++package:foo, module:foo, category:foo all work, all as a shortcut for +package:foo, ...++package:foo, +package:bar+-package:foo, -package:bar++bar is a shortcut for +package:bar++Bar is a shortcut for +module:Bar++Type signatures need extending to contain _, * and ? - all of which mean wildcard++Need a way to "tweak" type signatures.++At it's heart, a query is a list of names, a type sig, and a list of scopes, in order.++Need to augment this with a list of extra information, such that when the extra information+is replayed, it does the same job.++Should really be [String], Maybe TypeSig, [Scope], those -> ++data QueryInfo = [String] (Maybe TypeSig) [Scope]+data Query = Query QueryInfo (QueryInfo -> String?)+++"(a -" is assumed to be "(a -> _)"++"Ord a =" - is assumed to be "Ord a => _"++"(map > 1)" is total garbage... i think parse errors are still needed++Should try and autocomplete at the end where possible+-}+ -- | A query, representing a user input. data Query = Query
src/Web/All.hs view
@@ -2,15 +2,13 @@ module Web.All(action) where import CmdLine.All+import General.Web import Web.Server import Web.Response-import Data.List-import Network.HTTP + action :: CmdLine -> IO () action q@Server{} = server q -- FIXME: Should use datadir, but not sure how-action q = do- res <- response "datadir/resources" q- putStrLn $ intercalate "\n" $ map (takeWhile (`notElem` "\r\n") . show) (rspHeaders res) ++ ["",rspBody res]+action q = cgiResponse =<< response "datadir/resources" q
src/Web/Page.hs view
@@ -35,7 +35,7 @@ links = ["<div id='links'>" ," <span id='instant' style='display:none;'><a href='javascript:setInstant()'>" ++- "Instant is <span id='instantVal'>off</span> (β)</a> |</span>"+ "Instant is <span id='instantVal'>off</span></a> |</span>" ," <span id='plugin' style='display:none;'><a href='javascript:searchPlugin()'>Search plugin</a> |</span>" ," <a href='http://www.haskell.org/haskellwiki/Hoogle'>Manual</a> |" ," <a href='http://www.haskell.org/'>haskell.org</a>"
src/Web/Response.hs view
@@ -14,17 +14,17 @@ import Data.Time.Clock import Data.Time.Format import System.Locale-import Network.HTTP+import Network.Wai import System.IO.Unsafe(unsafeInterleaveIO) logFile = "log.txt" -response :: FilePath -> CmdLine -> IO (Response String)+response :: FilePath -> CmdLine -> IO Response response resources q = do logMessage q- let response x ys = responseOk $ [Header HdrContentType x] ++ ys+ let response x ys z = responseOK ((hdrContentType,fromString x) : ys) (fromString z) dbs <- unsafeInterleaveIO $ case queryParsed q of Left _ -> return mempty@@ -33,7 +33,7 @@ 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") "*"+ where hdr = (fromString "Access-Control-Allow-Origin", fromString "*") Just "ajax" -> return $ response "text/html" [] $ unlines $ runQuery True dbs q Just "web" -> return $ response "text/html" [] $ unlines $ header resources (escapeHTML $ queryText q) ++
src/Web/Server.hs view
@@ -6,91 +6,67 @@ import General.Web import CmdLine.All import Web.Response-import Control.Concurrent-import Control.Exception-import Network-import Network.HTTP-import Network.URI-import Network.Socket-import Data.Time+import Control.Monad.IO.Class import General.System-+import Control.Concurrent -server :: CmdLine -> IO ()-server q@Server{..} = withSocketsDo $ do- stop <- httpServer port (talk q)- flip finally stop $ do- putStrLn $ "Started Hoogle Server on port " ++ show port- -- must run under nohup, and with input from /dev/null- shut <- if nostdin then return True else hIsClosed stdin- eof <- if shut then return True else isEOF- when eof $ forever $ threadDelay maxBound+import Network.Wai+import Network.Wai.Handler.Warp+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.Char8 as BS --- | Given a port and a handler, return an action to shutdown the server-httpServer :: Int -> (Request String -> IO (Response String)) -> IO (IO ())-httpServer port handler = do- s <- listenOn $ PortNumber $ fromIntegral port- forkIO $ forever $ do- (sock,host) <- Network.Socket.accept s- bracket (socketConnection "" sock) close $ \strm -> do- start <- getCurrentTime- res <- receiveHTTP strm- case res of- Left x -> do- putStrLn $ "Bad request: " ++ show x- respondHTTP strm $ responseBadRequest $ show x- Right x -> do- let msg = unescapeURL $ show $ rqURI x- res <- try $ handler x- case res of- Left e -> do- let s = show (e :: SomeException)- putStrLn $ "Crash when serving " ++ msg ++ ", " ++ s- respondHTTP strm $ responseError s- Right r -> do- respondHTTP strm r- end <- getCurrentTime- let t = floor $ diffUTCTime end start * 1000- putStrLn $ "Served in " ++ show t ++ "ms: " ++ msg- return $ sClose s+server :: CmdLine -> IO ()+server q@Server{..} = do+ v <- newMVar ()+ putStrLn $ "Starting Hoogle Server on port " ++ show port+ run port $ \r -> liftIO $ do+ withMVar v $ const $ putStrLn $ bsUnpack (pathInfo r) ++ bsUnpack (queryString r)+ talk q r --- FIXME: This should be in terms of Lazy ByteString's, for higher performance--- serving of local files-talk :: CmdLine -> Request String -> IO (Response String)-talk Server{..} Request{rqURI=URI{uriPath=path,uriQuery=query}}+-- FIXME: Avoid all the conversions to/from LBS+talk :: CmdLine -> Request -> IO Response+talk Server{..} Request{pathInfo=path_, queryString=query_} | path `elem` ["/","/hoogle"] = do let args = parseHttpQueryArgs $ drop 1 query cmd <- cmdLineWeb args r <- response "/res" cmd{databases=databases}- return $ if local_ then fmap rewriteFileLinks r else r+ if local_ then rewriteFileLinks r else return r | takeDirectory path == "/res" = serveFile True $ resources </> takeFileName path | local_ && "/file/" `isPrefixOf` path = serveFile False $ drop 6 path | otherwise = return $ responseNotFound $ show path+ where (path,query) = (bsUnpack path_, bsUnpack query_) -serveFile :: Bool -> FilePath -> IO (Response String)+serveFile :: Bool -> FilePath -> IO Response serveFile cache file = do b <- doesFileExist file- if not b- then return $ responseNotFound file- else do- h <- openBinaryFile file ReadMode- src <- hGetContents h- return $ responseOk- ([Header HdrContentType $ contentExt $ takeExtension file] ++- [Header HdrCacheControl "max-age=604800" {- 1 week -} | cache]) src+ return $ if not b+ then responseNotFound file+ else ResponseFile statusOK hdr file+ where hdr = [(hdrContentType, fromString $ contentExt $ takeExtension file)] +++ [(hdrCacheControl, fromString "max-age=604800" {- 1 week -}) | cache] -rewriteFileLinks :: String -> String-rewriteFileLinks x- | "href='file://" `isPrefixOf` x = "href='/file/" ++ rewriteFileLinks (drop (13+1) x)- | null x = x- | otherwise = head x : rewriteFileLinks (tail x)+rewriteFileLinks :: Response -> IO Response+rewriteFileLinks r = do+ (a,b,c) <- responseFlatten r+ let res = LBS.fromChunks $ f $ BS.concat $ LBS.toChunks c+ return $ responseLBS a b res+ where+ f x | BS.null b = [a]+ | otherwise = a : rep : f (BS.drop nfind b) + where (a,b) = BS.breakSubstring find x + find = fromString "href='file://"+ rep = fromString "href='/file/"+ nfind = BS.length find + contentExt ".png" = "image/png" contentExt ".css" = "text/css" contentExt ".js" = "text/javascript"+contentExt ".html" = "text/html"+contentExt ".htm" = "text/html" contentExt _ = "text/plain"