diff --git a/src/Action/Server.hs b/src/Action/Server.hs index f623d7d8..cd093ff5 100644 --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -60,7 +62,7 @@ actionServer cmd@Server{..} = do log <- logCreate (if logs == "" then Left stdout else Right logs) $ \x -> BS.pack "hoogle=" `BS.isInfixOf` x && not (BS.pack "is:ping" `BS.isInfixOf` x) putStrLn . showDuration =<< time - evaluate spawned + _ <- evaluate spawned dataDir <- maybe getDataDir pure datadir haddock <- maybe (pure Nothing) (fmap Just . canonicalizePath) haddock withSearch database $ \store -> @@ -88,8 +90,15 @@ replyServer :: Log -> Bool -> Bool -> Maybe FilePath -> StoreRead -> String -> S 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 grabBy name = [x | (a,x) <- inputArgs, name a, x /= ""] + let + -- take from inputArgs, if namePred and value not empty + grabBy :: (String -> Bool) -> [String] + grabBy namePred = [x | (a,x) <- inputArgs, namePred a, x /= ""] + -- take from input Args if value not empty + grab :: String -> [String] grab name = grabBy (== name) + -- take an int from input Args, iff exists, else use default value + grabInt :: String -> Int -> Int grabInt name def = fromMaybe def $ readMaybe =<< listToMaybe (grab name) :: Int let qScope = let xs = grab "scope" in [scope | null xs && scope /= ""] ++ xs @@ -97,15 +106,20 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas let qSource = qSearch ++ 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 + + let urlOpts = if + | Just _ <- haddock -> HaddockUrl + | local -> LocalUrl + | otherwise -> OtherUrl + let body = showResults urlOpts links (filter ((/= "mode") . fst) inputArgs) q2 $ + takeAndGroup 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results case lookup "mode" inputArgs of Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex [("tags", html $ tagOptions qScope) ,("body", html body) - ,("title", text $ unwords qSource ++ " - Hoogle") - ,("search", text $ unwords qSearch) - ,("robots", text $ if any isQueryScope q then "none" else "index")] + ,("title", txt $ unwords qSource ++ " - Hoogle") + ,("search", txt $ unwords qSearch) + ,("robots", txt $ if any isQueryScope q then "none" else "index")] | otherwise -> OutputHTML <$> templateRender templateHome [] Just "body" -> OutputHTML <$> if null qSource then templateRender templateEmpty [] else templateRender (html body) [] Just "json" -> @@ -130,7 +144,7 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas summ <- logSummary log let errs = sum [summaryErrors | Summary{..} <- summ, summaryDate >= pred (utctDay now)] let alive = fromRational $ toRational $ (now `diffUTCTime` spawned) / (24 * 60 * 60) - pure $ (if errs == 0 && alive < 1.5 then OutputText else OutputFail) $ lbstrPack $ + pure $ (if errs == 0 && alive < (1.5 :: Double) then OutputText else OutputFail) $ lbstrPack $ "Errors " ++ (if errs == 0 then "good" else "bad") ++ ": " ++ show errs ++ " in the last 24 hours.\n" ++ "Updates " ++ (if alive < 1.5 then "good" else "bad") ++ ": Last updated " ++ showDP 2 alive ++ " days ago.\n" @@ -144,8 +158,8 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas pure $ case stats of Nothing -> OutputFail $ lbstrPack "GHC Statistics is not enabled, restart with +RTS -T" Just x -> OutputText $ lbstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop1 $ dropWhile (/= '{') $ show x - "haddock":xs | Just x <- haddock -> do - let file = intercalate "/" $ x:xs + "haddock":xs | Just haddockFilePath <- haddock -> do + let file = intercalate "/" $ haddockFilePath:xs pure $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "") "file":xs | local -> do let x = ['/' | not isWindows] ++ intercalate "/" (dropWhile null xs) @@ -161,48 +175,57 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas pure $ OutputFile $ joinPath $ htmlDir : xs where html = templateMarkup - text = templateMarkup . H.string + txt = templateMarkup . H.string tagOptions sel = mconcat [H.option Text.Blaze.!? (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 "https:" ++ JQuery.url) - ,("version", text $ showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)] + [("cdn", txt cdn) + ,("home", txt home) + ,("jquery", txt $ if null cdn then "plugin/jquery.js" else "https:" ++ JQuery.url) + ,("version", txt $ 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",html $ tagOptions []),("body",templateEmpty),("title",text "Hoogle"),("search",text ""),("robots",text "index")] + templateHome = templateIndex `templateApply` [("tags",html $ tagOptions []),("body",templateEmpty),("title",txt "Hoogle"),("search",txt ""),("robots",txt "index")] templateLog = templateFile (htmlDir "log.html") `templateApply` params templateLogJs = templateFile (htmlDir "log.js") `templateApply` params -dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]] -dedupeTake n key = f [] Map.empty +-- | Take from the list until we’ve seen `n` different keys, +-- and group all values by their respective key. +-- +-- Will keep the order of elements for each key the same. +takeAndGroup :: Ord k => Int -> (v -> k) -> [v] -> [[v]] +takeAndGroup n key = f [] Map.empty where - -- map is Map k [v] - f res mp xs | Map.size mp >= n || null xs = map (reverse . (Map.!) mp) $ reverse res - f res mp (x:xs) | Just vs <- Map.lookup k mp = f res (Map.insert k (x:vs) mp) xs - | otherwise = f (k:res) (Map.insert k [x] mp) xs + -- mp is Map k [v] + f keys mp [] + = map (\k -> reverse $ mp Map.! k) $ reverse keys + f keys mp _ | Map.size mp >= n + = map (\k -> reverse $ mp Map.! k) $ reverse keys + f keys mp (x:xs) + | Just vs <- Map.lookup k mp = f keys (Map.insert k (x:vs) mp) xs + | otherwise = f (k:keys) (Map.insert k [x] mp) xs where k = key x +data UrlOpts = HaddockUrl | LocalUrl | OtherUrl -showResults :: Bool -> Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> Markup -showResults local links haddock args query results = do +showResults :: UrlOpts -> Bool -> [(String, String)] -> [Query] -> [[Target]] -> Markup +showResults urlOpts links args query results = do H.h1 $ renderQuery 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) $ + H.a ! H.href (H.stringValue $ showURL urlOpts targetURL) $ displayItem query targetItem when links $ whenJust (useLink is) $ \link -> H.div ! H.class_ "links" $ H.a ! H.href (H.stringValue link) $ "Uses" - H.div ! H.class_ "from" $ showFroms local haddock is + H.div ! H.class_ "from" $ showFroms urlOpts is H.div ! H.class_ "doc newline shut" $ H.preEscapedString targetDocs 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] + mconcat [H.li $ leftSidebarSearchLinks cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query] where useLink :: [Target] -> Maybe String @@ -210,23 +233,28 @@ showResults local links haddock args query results = do Just $ "https://packdeps.haskellers.com/reverse/" ++ extractName (targetItem t) useLink _ = Nothing - add x = ("?" ++) $ intercalate "&" $ map (joinPair "=") $ + -- The search URL with an extra filter added to the hoogle query + searchURLWithExtraSearchFilter :: String -> String + searchURLWithExtraSearchFilter searchFilter = ("?" ++) $ intercalate "&" $ map (joinPair "=") $ case break ((==) "hoogle" . fst) args of - (a,[]) -> a ++ [("hoogle", escapeURL x)] - (a,(_,x1):b) -> a ++ [("hoogle", escapeURL $ x1 ++ " " ++ x)] ++ b - - 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) $ + (a,[]) -> a ++ [("hoogle", escapeURL searchFilter)] + (a,(_,x1):b) -> a ++ [("hoogle", escapeURL $ x1 ++ " " ++ searchFilter)] ++ b + + -- Construct two links in the left sidebar, + -- one which repeats the current search *with* the respective package or category, + -- one *without* the package or category. + leftSidebarSearchLinks cat val = do + H.a ! H.class_" minus" ! H.href (H.stringValue $ searchURLWithExtraSearchFilter $ "-" ++ cat ++ ":" ++ val) $ "" + H.a ! H.class_ "plus" ! H.href (H.stringValue $ searchURLWithExtraSearchFilter $ cat ++ ":" ++ val) $ H.string $ (if cat == "package" then "" else cat ++ ":") ++ val -- find the X bit extractName :: String -> String extractName x - | Just (_, x) <- stripInfix "" x - , Just (x, _) <- stripInfix "" x - = unHTML x + | Just (_, x') <- stripInfix "" x + , Just (x'', _) <- stripInfix "" x' + = unHTML x'' extractName x = x @@ -237,35 +265,44 @@ itemCategories xs = [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] -showFroms :: Bool -> Maybe FilePath -> [Target] -> Markup -showFroms local haddock xs = mconcat $ intersperse ", " $ flip map pkgs $ \p -> - let ms = filter ((==) p . targetPackage) xs - in mconcat $ intersperse " " [H.a ! H.href (H.stringValue $ showURL local haddock b) $ H.string a | (a,b) <- catMaybes $ p : map remod ms] +-- | Display the line under the title of a search result, which contains a list of Modules each target is defined in, ordered by package. +showFroms :: UrlOpts -> [Target] -> Markup +showFroms urlOpts targets = mconcat $ intersperse ", " $ flip map pkgs $ \pkg -> + let ms = filter ((==) pkg . targetPackage) targets + in mconcat $ intersperse " " + [(H.a ! H.href (H.stringValue $ showURL urlOpts targetUrl)) + (H.string pkgName) + | (pkgName, targetUrl) + <- catMaybes $ pkg : map pkgAndTargetUrlMay ms + ] where - remod Target{..} = do (a,_) <- targetModule; pure (a,targetURL) - pkgs = nubOrd $ map targetPackage xs + pkgAndTargetUrlMay Target{targetModule, targetURL} = do + (pkgName, _) <- targetModule + pure (pkgName, targetURL) + pkgs = nubOrd $ map targetPackage targets -showURL :: Bool -> Maybe FilePath -> URL -> String -showURL _ (Just _) x = "haddock/" ++ dropPrefix "file:///" x -showURL True _ (stripPrefix "file:///" -> Just x) = "file/" ++ x -showURL _ _ x = x +showURL :: UrlOpts -> URL -> String +showURL HaddockUrl x = "haddock/" ++ dropPrefix "file:///" x +showURL LocalUrl (stripPrefix "file:///" -> Just x) = "file/" ++ x +showURL LocalUrl x = x +showURL OtherUrl x = x ------------------------------------------------------------- -- DISPLAY AN ITEM (bold keywords etc) highlightItem :: [Query] -> String -> Markup -highlightItem qs x - | Just (pre,x) <- stripInfix "" x, Just (name,post) <- stripInfix "" x +highlightItem qs str + | Just (pre,x) <- stripInfix "" str, Just (name,post) <- stripInfix "" x = H.preEscapedString pre <> highlight (unescapeHTML name) <> H.preEscapedString post - | otherwise = H.string x + | otherwise = H.string str where highlight = mconcatMap (\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) where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)] - f (x:xs) = False : f xs + f (_:xs) = False : f xs f [] = [] displayItem :: [Query] -> String -> Markup