diff --git a/CHANGES.txt b/CHANGES.txt
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -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
diff --git a/hoogle.cabal b/hoogle.cabal
--- a/hoogle.cabal
+++ b/hoogle.cabal
@@ -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,
diff --git a/html/hoogle.css b/html/hoogle.css
--- a/html/hoogle.css
+++ b/html/hoogle.css
@@ -110,6 +110,11 @@
     padding-right: 15px;
 }
 
+#top-menu li#plugin {
+    display: none;
+    cursor: pointer;
+}
+
 
 /********************************************************************
 *  LEFT - EXTRA SUGGESTIONS
diff --git a/html/hoogle.js b/html/hoogle.js
--- a/html/hoogle.js
+++ b/html/hoogle.js
@@ -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);
-}
 
 
 /////////////////////////////////////////////////////////////////////
diff --git a/html/index.html b/html/index.html
--- a/html/index.html
+++ b/html/index.html
@@ -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>
diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs
--- a/src/Action/Generate.hs
+++ b/src/Action/Generate.hs
@@ -81,7 +81,7 @@
 
 
 generate :: FilePath -> [(String, [(String, String)])] -> [(String, LBS.ByteString)] -> IO ()
-generate output metadata  = undefined
+generate output metadata = ...
 -}
 
 
diff --git a/src/Action/Search.hs b/src/Action/Search.hs
--- a/src/Action/Search.hs
+++ b/src/Action/Search.hs
@@ -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"
diff --git a/src/Action/Server.hs b/src/Action/Server.hs
--- a/src/Action/Server.hs
+++ b/src/Action/Server.hs
@@ -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 "&amp;" $ map (joinPair "=" . second escapeUntaint) $
+        add x = ("?" ++) $ intercalate "&amp;" $ 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 -&gt; test"
         "new west" === "<s0>{newest}_{new}</s0> :: Int"
         "+*" === "(<s0>{+*}&amp;</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
diff --git a/src/General/Store.hs b/src/General/Store.hs
--- a/src/General/Store.hs
+++ b/src/General/Store.hs
@@ -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"
diff --git a/src/General/Template.hs b/src/General/Template.hs
--- a/src/General/Template.hs
+++ b/src/General/Template.hs
@@ -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
diff --git a/src/General/Util.hs b/src/General/Util.hs
--- a/src/General/Util.hs
+++ b/src/General/Util.hs
@@ -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
diff --git a/src/General/Web.hs b/src/General/Web.hs
--- a/src/General/Web.hs
+++ b/src/General/Web.hs
@@ -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")]
diff --git a/src/Query.hs b/src/Query.hs
--- a/src/Query.hs
+++ b/src/Query.hs
@@ -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

No results found