hoogle 5.0.17.7 → 5.0.17.8
raw patch · 13 files changed
+202/−136 lines, 13 filesdep +blaze-htmldep +blaze-markupPVP ok
version bump matches the API change (PVP)
Dependencies added: blaze-html, blaze-markup
API changes (from Hackage documentation)
Files
- CHANGES.txt +3/−0
- hoogle.cabal +3/−1
- html/hoogle.css +5/−0
- html/hoogle.js +10/−11
- html/index.html +1/−1
- src/Action/Generate.hs +1/−1
- src/Action/Search.hs +3/−1
- src/Action/Server.hs +69/−59
- src/General/Store.hs +2/−2
- src/General/Template.hs +6/−1
- src/General/Util.hs +1/−11
- src/General/Web.hs +83/−38
- src/Query.hs +15/−10
CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for Hoogle (* = breaking change) +5.0.17.8, released 2019-05-14+ #299, add some security-improving headers+ #298, use Blaze for constructing most HTML 5.0.17.7, released 2019-05-10 Fix an XSS vulnerability, reported by @alexanderGugel #297, make Uses for packages point at reverse deps
hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle-version: 5.0.17.7+version: 5.0.17.8 license: BSD3 license-file: LICENSE category: Development@@ -45,6 +45,8 @@ QuickCheck, aeson, base > 4 && < 5,+ blaze-html,+ blaze-markup, binary, bytestring >= 0.10.2.0, cmdargs,
html/hoogle.css view
@@ -110,6 +110,11 @@ padding-right: 15px; } +#top-menu li#plugin {+ display: none;+ cursor: pointer;+}+ /******************************************************************** * LEFT - EXTRA SUGGESTIONS
html/hoogle.js view
@@ -247,18 +247,17 @@ }); } if (window.external && ("AddSearchProvider" in window.external))- $("#plugin").css("display","");+ {+ $("#plugin").css("display","inline").on('click', function(){+ var url = $("link[rel=search]").attr("href");+ // If neither scheme(http(s)://) nor DSN prefix(//) is in URL then we+ // should add prefix.+ if (url.indexOf('://') === -1 && url.indexOf('//') !== 0)+ url = prefixUrl + url;+ window.external.AddSearchProvider(url);+ });+ } });--function searchPlugin()-{- var url = $("link[rel=search]").attr("href");- // If neither scheme(http(s)://) nor DSN prefix(//) is in URL then we- // should add prefix.- if (url.indexOf('://') === -1 && url.indexOf('//') !== 0)- url = prefixUrl + url;- window.external.AddSearchProvider(url);-} /////////////////////////////////////////////////////////////////////
html/index.html view
@@ -17,7 +17,7 @@ <body> <div id="links"> <ul id="top-menu">- <li id="plugin" style="display:none;"><a href="javascript:searchPlugin()">Search plugin</a></li>+ <li id="plugin"><a>Search plugin</a></li> <li><a href="https://github.com/ndmitchell/hoogle/blob/master/README.md">Manual</a></li> <li><a href="https://www.haskell.org">haskell.org</a></li> </ul>
src/Action/Generate.hs view
@@ -81,7 +81,7 @@ generate :: FilePath -> [(String, [(String, String)])] -> [(String, LBS.ByteString)] -> IO ()-generate output metadata = undefined+generate output metadata = ... -}
src/Action/Search.hs view
@@ -12,6 +12,8 @@ import Control.Exception.Extra import Data.Functor.Identity import Data.List.Extra+import Text.Blaze.Renderer.Utf8+import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set@@ -37,7 +39,7 @@ withSearch database $ \store -> if null compare_ then do (q, res) <- return $ search store $ parseQuery $ unwords query- whenLoud $ putStrLn $ "Query: " ++ unescapeHTML (renderQuery q)+ whenLoud $ putStrLn $ "Query: " ++ unescapeHTML (LBS.unpack $ renderMarkup $ renderQuery q) let (shown, hidden) = splitAt count $ nubOrd $ map (targetResultDisplay link) res if null res then putStrLn "No results found"
src/Action/Server.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -8,6 +9,10 @@ import Control.Exception.Extra import Control.DeepSeq import System.Directory+import Text.Blaze+import Text.Blaze.Renderer.Utf8+import qualified Text.Blaze.XHtml5 as H+import qualified Text.Blaze.XHtml5.Attributes as H import Data.Tuple.Extra import qualified Language.Javascript.JQuery as JQuery import qualified Language.Javascript.Flot as Flot@@ -19,6 +24,7 @@ import System.IO.Extra import General.Str import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import System.Time.Extra import Data.Time.Clock@@ -38,6 +44,7 @@ import Action.Search import Action.CmdLine import Control.Applicative+import Data.Monoid import Prelude import qualified Data.Aeson as JSON@@ -84,33 +91,33 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = case inputURL of -- without -fno-state-hack things can get folded under this lambda [] -> do- let grab name = [x | (a,x) <- inputArgs, a == name, x /= taint ""]- grabInt name def = fromMaybe def $ readMaybe . carefulUntaint =<< listToMaybe (grab name) :: Int+ let grab name = [x | (a,x) <- inputArgs, a == name, x /= ""]+ grabInt name def = fromMaybe def $ readMaybe =<< listToMaybe (grab name) :: Int - let qScope = let xs = grab "scope" in [taint scope | null xs && scope /= ""] ++ xs- let qSource = sequenceA $ grab "hoogle" ++ filter (/= taint "set:stackage") qScope- let q = concatMap parseQuery <$> qSource :: Taint [Query]- let (q2, results) = search store $ carefulUntaint q+ let qScope = let xs = grab "scope" in [scope | null xs && scope /= ""] ++ xs+ let qSource = grab "hoogle" ++ filter (/= "set:stackage") qScope+ let q = concatMap parseQuery qSource+ let (q2, results) = search store q let body = showResults local links haddock (filter ((/= "mode") . fst) inputArgs) q2 $ dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results case lookup "mode" inputArgs of- Nothing | qSource /= taint [] -> fmap OutputHTML $ templateRender templateIndex $ map (second str)- [("tags",tagOptions qScope)- ,("body",body)- ,("title",escapeUntaint $ (\x -> unwords x ++ " - Hoogle") <$> qSource)- ,("search",escapeUntaint $ unwords <$> sequenceA (grab "hoogle"))- ,("robots",if carefulUntaint $ any isQueryScope <$> q then "none" else "index")]+ Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex+ [("tags", html $ tagOptions qScope)+ ,("body", html body)+ ,("title", text $ unwords qSource ++ " - Hoogle")+ ,("search", text $ unwords $ grab "hoogle")+ ,("robots", text $ if any isQueryScope q then "none" else "index")] | otherwise -> OutputHTML <$> templateRender templateHome []- Just ((== taint "body") -> True) -> OutputHTML <$> if qSource == taint [] then templateRender templateEmpty [] else return $ lbstrPack body- Just ((== taint "json") -> True) ->+ Just "body" -> OutputHTML <$> if null qSource then templateRender templateEmpty [] else templateRender (html body) []+ Just "json" -> let -- 1 means don't drop anything, if it's less than 1 ignore it start :: Int start = max 0 $ grabInt "start" 1 - 1 -- by default it returns 100 entries count :: Int count = min 500 $ grabInt "count" 100- in pure $ OutputJSON $ JSON.encode $ take count $ drop start results- Just m -> return $ OutputFail $ lbstrPack $ "Mode " ++ escapeUntaint m ++ " not (currently) supported"+ in pure $ OutputJSON $ JSON.toEncoding $ take count $ drop start results+ Just m -> return $ OutputFail $ lbstrPack $ "Mode " ++ m ++ " not (currently) supported" ["plugin","jquery.js"] -> OutputFile <$> JQuery.file ["plugin","jquery.flot.js"] -> OutputFile <$> Flot.file Flot.Flot ["plugin","jquery.flot.time.js"] -> OutputFile <$> Flot.file Flot.FlotTime@@ -126,7 +133,7 @@ ["log"] -> do log <- displayLog <$> logSummary log- OutputHTML <$> templateRender templateLog [("data",str log)]+ OutputHTML <$> templateRender templateLog [("data",html $ H.string log)] ["stats"] -> do stats <- getStatsDebug return $ case stats of@@ -148,16 +155,18 @@ xs -> return $ OutputFile $ joinPath $ htmlDir : xs where- str = templateStr . lbstrPack- tagOptions sel = concat [tag "option" ["selected=selected" | taint x `elem` sel] x | x <- completionTags store]- params = map (second str)- [("cdn",cdn)- ,("home",home)- ,("jquery",if null cdn then "plugin/jquery.js" else JQuery.url)- ,("version",showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)]+ html = templateMarkup+ text = templateMarkup . H.string++ tagOptions sel = mconcat [H.option !? (x `elem` sel, H.selected "selected") $ H.string x | x <- completionTags store]+ params =+ [("cdn", text cdn)+ ,("home", text home)+ ,("jquery", text $ if null cdn then "plugin/jquery.js" else JQuery.url)+ ,("version", text $ showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)] templateIndex = templateFile (htmlDir </> "index.html") `templateApply` params templateEmpty = templateFile (htmlDir </> "welcome.html")- templateHome = templateIndex `templateApply` [("tags",str $ tagOptions []),("body",templateEmpty),("title",str "Hoogle"),("search",str ""),("robots",str "index")]+ templateHome = templateIndex `templateApply` [("tags",html $ tagOptions []),("body",templateEmpty),("title",text "Hoogle"),("search",text ""),("robots",text "index")] templateLog = templateFile (htmlDir </> "log.html") `templateApply` params @@ -171,23 +180,22 @@ where k = key x -showResults :: Bool -> Bool -> Maybe FilePath -> [(String, Taint String)] -> [Query] -> [[Target]] -> String-showResults local links haddock args query results = unlines $- ["<h1>" ++ renderQuery query ++ "</h1>"- ,"<ul id=left>"- ,"<li><b>Packages</b></li>"] ++- [tag_ "li" $ f cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query] ++- ["</ul>"] ++- ["<p>No results found</p>" | null results] ++- ["<div class=result>" ++- "<div class=ans>" ++- "<a href=\"" ++ showURL local haddock targetURL ++ "\">" ++ displayItem query targetItem ++ "</a>" ++- (if not links then "" else "<div class=links><a href='" ++ useLink is ++ "'>Uses</a></div>") ++- "</div>" ++- "<div class=from>" ++ showFroms local haddock is ++ "</div>" ++- "<div class=\"doc newline shut\">" ++ targetDocs ++ "</div>" ++- "</div>"- | is@(Target{..}:_) <- results]+showResults :: Bool -> Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> Markup+showResults local links haddock args query results = do+ H.h1 $ renderQuery query+ H.ul ! H.id "left" $ do+ H.li $ H.b "Packages"+ mconcat [H.li $ f cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query]+ when (null results) $ H.p "No results found"+ forM_ results $ \is@(Target{..}:_) -> do+ H.div ! H.class_ "result" $ do+ H.div ! H.class_ "ans" $ do+ H.a ! H.href (H.stringValue $ showURL local haddock targetURL) $+ displayItem query targetItem+ when links $ do+ H.div ! H.class_ "links" $ H.a ! H.href (H.stringValue $ useLink is) $ "Uses"+ H.div ! H.class_ "from" $ showFroms local haddock is+ H.div ! H.class_ "doc newline shut" $ H.preEscapedString targetDocs where useLink :: [Target] -> String useLink [t] | isNothing $ targetPackage t =@@ -197,14 +205,15 @@ "&filter=" ++ intercalate "|" (mapMaybe (fmap fst . targetModule) ts) ++ "&precise=on" - add x = ("?" ++) $ intercalate "&" $ map (joinPair "=" . second escapeUntaint) $+ add x = ("?" ++) $ intercalate "&" $ map (joinPair "=") $ case break ((==) "hoogle" . fst) args of- (a,[]) -> a ++ [("hoogle",taint x)]- (a,(_,x1):b) -> a ++ [("hoogle",(\v -> v ++ " " ++ x) <$> x1)] ++ b+ (a,[]) -> a ++ [("hoogle", x)]+ (a,(_,x1):b) -> a ++ [("hoogle", x1 ++ " " ++ x)] ++ b - f cat val = "<a class=\"minus\" href=\"" ++ add ("-" ++ cat ++ ":" ++ val) ++ "\"></a>" ++- "<a class=\"plus\" href=\"" ++ add (cat ++ ":" ++ val) ++ "\">" ++- (if cat == "package" then "" else cat ++ ":") ++ val ++ "</a>"+ f cat val = do+ H.a ! H.class_" minus" ! H.href (H.stringValue $ add $ "-" ++ cat ++ ":" ++ val) $ ""+ H.a ! H.class_ "plus" ! H.href (H.stringValue $ add $ cat ++ ":" ++ val) $+ H.string $ (if cat == "package" then "" else cat ++ ":") ++ val -- find the <span class=name>X</span> bit@@ -223,10 +232,10 @@ [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] -showFroms :: Bool -> Maybe FilePath -> [Target] -> String-showFroms local haddock xs = intercalate ", " $ flip map pkgs $ \p ->+showFroms :: Bool -> Maybe FilePath -> [Target] -> Markup+showFroms local haddock xs = mconcat $ intersperse ", " $ flip map pkgs $ \p -> let ms = filter ((==) p . targetPackage) xs- in unwords ["<a href=\"" ++ showURL local haddock b ++ "\">" ++ a ++ "</a>" | (a,b) <- catMaybes $ p : map remod ms]+ in mconcat $ intersperse " " [H.a ! H.href (H.stringValue $ showURL local haddock b) $ H.string a | (a,b) <- catMaybes $ p : map remod ms] where remod Target{..} = do (a,_) <- targetModule; return (a,targetURL) pkgs = nubOrd $ map targetPackage xs@@ -240,12 +249,13 @@ ------------------------------------------------------------- -- DISPLAY AN ITEM (bold keywords etc) -highlightItem :: [Query] -> String -> String+highlightItem :: [Query] -> String -> Markup highlightItem qs x- | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x = pre ++ highlight (unescapeHTML name) ++ post- | otherwise = x+ | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x+ = H.preEscapedString pre <> highlight (unescapeHTML name) <> H.preEscapedString post+ | otherwise = H.string x where- highlight = concatMap (\xs@((b,_):_) -> let s = escapeHTML $ map snd xs in if b then "<b>" ++ s ++ "</b>" else s) .+ highlight = mconcat . map (\xs@((b,_):_) -> let s = H.string $ map snd xs in if b then H.b s else s) . groupOn fst . (\x -> zip (f x) x) where f (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (f xs)@@ -253,7 +263,7 @@ f (x:xs) = False : f xs f [] = [] -displayItem :: [Query] -> String -> String+displayItem :: [Query] -> String -> Markup displayItem = highlightItem @@ -262,8 +272,8 @@ testing "Action.Server.displayItem" $ do let expand = replace "{" "<b>" . replace "}" "</b>" . replace "<s0>" "" . replace "</s0>" "" contract = replace "{" "" . replace "}" ""- let q === s | displayItem (parseQuery q) (contract s) == expand s = putChar '.'- | otherwise = errorIO $ show (q,s,displayItem (parseQuery q) (contract s))+ let q === s | LBS.unpack (renderMarkup $ displayItem (parseQuery q) (contract s)) == expand s = putChar '.'+ | otherwise = errorIO $ show (q,s,renderMarkup $ displayItem (parseQuery q) (contract s)) "test" === "<s0>my{Test}</s0> :: Int -> test" "new west" === "<s0>{newest}_{new}</s0> :: Int" "+*" === "(<s0>{+*}&</s0>) :: Int"@@ -280,7 +290,7 @@ log <- logNone dataDir <- getDataDir let check p q = do- OutputHTML (lbstrUnpack -> res) <- replyServer log False False Nothing store "" "" (dataDir </> "html") "" (Input [] [("hoogle",taint q)])+ OutputHTML (lbstrUnpack -> res) <- replyServer log False False Nothing store "" "" (dataDir </> "html") "" (Input [] [("hoogle",q)]) if p res then putChar '.' else fail $ "Bad substring: " ++ res let q === want = check (want `isInfixOf`) q let q /== want = check (not . isInfixOf want) q
src/General/Store.hs view
@@ -146,7 +146,7 @@ sw@SW{..} <- readIORef ref putBuffer swHandle ptr len - let val = show $ typeOf (undefined :: a)+ let val = show $ typeRep (Proxy :: Proxy a) atoms <- case swAtoms of (keyOld,a):xs | part, key == keyOld -> do let size = atomSize a + len@@ -196,7 +196,7 @@ storeReadAtom :: forall a t . (Typeable (t a), Typeable a) => StoreRead -> t a -> (CStringLen -> IO a) -> a storeReadAtom StoreRead{..} (typeOf -> k) unpack = unsafePerformIO $ do let key = show k- let val = show $ typeOf (undefined :: a)+ let val = show $ typeRep (Proxy :: Proxy a) let corrupt msg = errorIO $ "The Hoogle file " ++ srFile ++ " is corrupt, " ++ key ++ " " ++ msg ++ "." case Map.lookup key srAtoms of Nothing -> corrupt "is missing"
src/General/Template.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-} module General.Template(- Template, templateFile, templateStr, templateApply, templateRender+ Template, templateFile, templateMarkup, templateApply, templateRender ) where import Data.Data import Data.Monoid+import Text.Blaze+import Text.Blaze.Renderer.Utf8 import General.Str import Control.Exception import Data.Generics.Uniplate.Data@@ -95,6 +97,9 @@ templateFile :: FilePath -> Template templateFile = templateTree . Lam++templateMarkup :: Markup -> Template+templateMarkup = templateStr . renderMarkup templateStr :: LBStr -> Template templateStr = templateTree . List . map Lit . lbstrToChunks
src/General/Util.hs view
@@ -12,7 +12,7 @@ showUTCTime, strict, withs,- escapeHTML, unescapeHTML, unHTML, tag, tag_,+ escapeHTML, unescapeHTML, unHTML, escapeURL, takeSortOn, Average, toAverage, fromAverage,@@ -261,16 +261,6 @@ padL n s = replicate (n - length s) ' ' ++ s padR n s = s ++ replicate (n - length s) ' '---tag :: String -> [String] -> String -> String-tag name attr inner = "<" ++ unwords (name : map f attr) ++ ">" ++ inner ++ "</" ++ name ++ ">"- where f (break (== '=') -> (a,'=':b)) = a ++ "=\"" ++ escapeHTML b ++ "\""- f x = x--tag_ :: String -> String -> String-tag_ name = tag name []- -- ensure that no value escapes in a thunk from the value strict :: NFData a => IO a -> IO a
src/General/Web.hs view
@@ -2,7 +2,6 @@ module General.Web( Input(..),- Taint, taint, carefulUntaint, escapeUntaint, Output(..), readInput, server ) where @@ -19,6 +18,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.List.Extra+import Data.Aeson.Encoding import Data.Char import Data.String import Data.Tuple.Extra@@ -33,32 +33,12 @@ data Input = Input {inputURL :: [String]- ,inputArgs :: [(String, Taint String)]+ ,inputArgs :: [(String, String)] } deriving Show -newtype Taint a = Taint a- deriving (Functor, Show, Eq)--instance Applicative Taint where- pure = Taint- Taint f <*> Taint x = Taint $ f x--instance Monad Taint where- Taint m >>= k = k m---taint :: a -> Taint a-taint = Taint--carefulUntaint :: Taint a -> a-carefulUntaint (Taint a) = a--escapeUntaint :: Taint String -> String-escapeUntaint = escapeHTML . carefulUntaint- readInput :: String -> Input readInput (breakOn "?" -> (a,b)) = Input (filter (not . badPath) $ dropWhile null $ splitOn "/" a) $- filter (not . badArg . fst) $ map (second (Taint . unEscapeString . drop1) . breakOn "=") $ splitOn "&" $ drop1 b+ filter (not . badArg . fst) $ map (second (unEscapeString . drop1) . breakOn "=") $ splitOn "&" $ drop1 b where -- avoid "" and ".." in the URLs, since they could be trying to browse on the server badPath xs = xs == "" || all (== '.') xs@@ -68,18 +48,21 @@ data Output = OutputText LBS.ByteString | OutputHTML LBS.ByteString- | OutputJSON LBS.ByteString+ | OutputJSON Encoding | OutputFail LBS.ByteString | OutputFile FilePath deriving Show -instance NFData Output where- rnf (OutputText x) = rnf x- rnf (OutputJSON x) = rnf x- rnf (OutputHTML x) = rnf x- rnf (OutputFail x) = rnf x- rnf (OutputFile x) = rnf x+-- | Force all the output (no delayed exceptions) and produce bytestrings+forceBS :: Output -> LBS.ByteString+forceBS (OutputText x) = force x+forceBS (OutputJSON x) = force $ encodingToLazyByteString x+forceBS (OutputHTML x) = force x+forceBS (OutputFail x) = force x+forceBS (OutputFile x) = rnf x `seq` LBS.empty +instance NFData Output where+ rnf x = forceBS x `seq` () server :: Log -> CmdLine -> (Input -> IO Output) -> IO () server log Server{..} act = do@@ -99,25 +82,87 @@ runServer :: Application -> IO () runServer = if https then runTLS (tlsSettings cert key) set else runSettings set+ secH = [+ -- The CSP is giving additional instructions to the browser.+ ("Content-Security-Policy",+ -- For any content type not specifically enumerated in this CSP+ -- (e.g. fonts), the only valid origin is the same as the current+ -- page.+ "default-src 'self';"+ -- As an exception to the default rule, allow scripts from jquery+ -- and the CDN.+ <> " script-src 'self' https://code.jquery.com/ https://rawcdn.githack.com;"+ -- As an exception to the default rule, allow stylesheets from+ -- the CDN. TODO: for now, we are also enabling inline styles,+ -- because it the chosen plugin uses them.+ <> " style-src 'self' 'unsafe-inline' https://rawcdn.githack.com;"+ -- As an exception to the default rule, allow images from the+ -- CDN.+ <> " img-src 'self' https://rawcdn.githack.com;"+ -- Only allow this request in an iframe if the containing page+ -- has the same origin.+ <> " frame-ancestors 'self';"+ -- Forms are only allowed to target addresses under the same+ -- origin as the page.+ <> " form-action 'self';"+ -- Any request originating from this page and specifying http as+ -- its protocol will be automatically upgraded to https.+ <> " upgrade-insecure-requests;"+ -- Do not display http content if the page was loaded under+ -- https.+ <> " block-all-mixed-content"), + -- Tells the browser this web page should not be rendered inside a+ -- frame, except if the framing page comes from the same origin+ -- (i.e. DNS name + port). This is to thwart invisible, keylogging+ -- framing pages.+ ("X-Frame-Options", "sameorigin"),++ -- Tells browsers to trust the Content-Type header and not try to+ -- otherwise guess at response types. In particular, prevents+ -- dangerous browser behaviour that would execute a file loaded+ -- from a <script> or <style> tag despite not having a+ -- text/javascript or text/css Content-Type.+ ("X-Content-Type-Options", "nosniff"),++ -- Browser should try to detect "reflected" XSS attacks, where+ -- some suspicious payload of the request appears in the response.+ -- How browsers do that is unspecified. On detection, browser+ -- should block the page from rendering at all.+ ("X-XSS-Protection", "1; mode=block"),++ -- Do not include referrer information if user-agent generates a+ -- request from an HTTPS page to an HTTP one. Note: this is+ -- technically redundant as this should be the browser default+ -- behaviour.+ ("Referrer-Policy", "no-referrer-when-downgrade")++ -- Strict Transport Security (aka HSTS) tells the browser that,+ -- from now on and until max-age seconds have passed, it should+ -- never try to connect to this domain name through unprotected+ -- HTTP. The browser will automatically upgrade any HTTP request+ -- to this domain name to HTTPS, client side, before any network+ -- call happens.+ ] ++ [("Strict-Transport-Security", "max-age=31536000; includeSubDomains") | https]+ logAddMessage log $ "Server starting on port " ++ show port ++ " and host/IP " ++ show host' runServer $ \req reply -> do putStrLn $ BS.unpack $ rawPathInfo req <> rawQueryString req let pay = Input (map Text.unpack $ pathInfo req)- [(bstrUnpack a, Taint $ maybe "" bstrUnpack b) | (a,b) <- queryString req]- (time,res) <- duration $ try_ $ do s <- act pay; evaluate $ force s+ [(bstrUnpack a, maybe "" bstrUnpack b) | (a,b) <- queryString req]+ (time,res) <- duration $ try_ $ do s <- act pay; bs <- evaluate $ forceBS s; return (s, bs) res <- either (fmap Left . showException) (return . Right) res logAddEntry log (showSockAddr $ remoteHost req) (BS.unpack $ rawPathInfo req <> rawQueryString req) time (either Just (const Nothing) res) case res of Left s -> reply $ responseLBS status500 [] $ LBS.pack s- Right v -> reply $ case v of+ Right (v, bs) -> reply $ case v of OutputFile file -> responseFile status200- [("content-type",c) | Just c <- [lookup (takeExtension file) contentType]] file Nothing- OutputText msg -> responseLBS status200 [("content-type","text/plain")] msg- OutputJSON msg -> responseLBS status200 [("content-type","application/json"), ("access-control-allow-origin","*")] msg- OutputFail msg -> responseLBS status500 [] msg- OutputHTML msg -> responseLBS status200 [("content-type","text/html")] msg+ ([("content-type",c) | Just c <- [lookup (takeExtension file) contentType]] ++ secH) file Nothing+ OutputText{} -> responseLBS status200 (("content-type","text/plain") : secH) bs+ OutputJSON{} -> responseLBS status200 (("content-type","application/json") : ("access-control-allow-origin","*") : secH) bs+ OutputFail{} -> responseLBS status500 (("content-type","text/plain") : secH) bs+ OutputHTML{} -> responseLBS status200 (("content-type","text/html") : secH) bs contentType = [(".html","text/html"),(".css","text/css"),(".js","text/javascript")]
src/Query.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -O0 #-} -- otherwise it takes a lot of memory to compile on the haskell.org server module Query(@@ -10,10 +11,13 @@ import Data.List import Language.Haskell.Exts import Data.Char+import Text.Blaze+import qualified Text.Blaze.XHtml5 as H import Data.List.Extra import Data.Generics.Uniplate.Data import General.Util import Data.Maybe+import Data.Monoid import Control.Applicative import Prelude @@ -32,13 +36,14 @@ isQueryType QueryType{} = True; isQueryType _ = False isQueryScope QueryScope{} = True; isQueryScope _ = False -renderQuery :: [Query] -> String-renderQuery [] = "<i>No query</i>"-renderQuery xs = unwords $- [escapeHTML x | QueryName x <- xs] ++- [":: " ++ escapeHTML (pretty x) | QueryType x <- xs] ++- [['-' | not scopeInclude] ++ escapeHTML scopeCategory ++ ":" ++ escapeHTML scopeValue | QueryScope{..} <- xs] ++- ["<strike>" ++ escapeHTML x ++ "</strike>" | QueryNone x <- xs]+renderQuery :: [Query] -> Markup+renderQuery [] = H.i "No query"+renderQuery xs = do+ string $ unwords $+ [x | QueryName x <- xs] +++ [":: " ++ pretty x | QueryType x <- xs] +++ [['-' | not scopeInclude] ++ scopeCategory ++ ":" ++ scopeValue | QueryScope{..} <- xs]+ mconcat [" " <> H.del (string x) | QueryNone x <- xs] ---------------------------------------------------------------------@@ -58,8 +63,8 @@ isBracketPair x = x `elem` zipWith (++) openBrackets shutBrackets isSym x = ((isSymbol x || isPunctuation x) && x `notElem` special) || x `elem` ascSymbol- where special = "(),;[]`{}\"'"- ascSymbol = "!#$%&*+./<=>?@\\^|-~"+ where special = "(),;[]`{}\"'" :: String+ ascSymbol = "!#$%&*+./<=>?@\\^|-~" :: String isSyms xs | isBracket xs || isBracketPair xs = False isSyms (x:xs) = isSym x@@ -75,7 +80,7 @@ lexer (x:xs) | isSpace x = " " : lexer (dropWhile isSpace xs) | isAlpha x || x == '_' =- let (a,b) = span (\x -> isAlphaNum x || x `elem` "_'#-") xs+ let (a,b) = span (\x -> isAlphaNum x || x `elem` ("_'#-" :: String)) xs (a1,a2) = spanEnd (== '-') a in (x:a1) : lexer (a2 ++ b) | isSym x = let (a,b) = span isSym xs in (x:a) : lexer b