diff --git a/function-graph.cabal b/function-graph.cabal index 19f611b..9be36ab 100644 --- a/function-graph.cabal +++ b/function-graph.cabal @@ -76,6 +76,7 @@ library function-graph-server , streaming , time , file-embed + , these hs-source-dirs: src/server default-language: Haskell2010 diff --git a/src/server/Server.hs b/src/server/Server.hs index 45e4cce..a3e22d2 100644 --- a/src/server/Server.hs +++ b/src/server/Server.hs @@ -68,20 +68,20 @@ mkHandlers searchConfig appendToHead graph = do (typeaheadHandler, initalSuggestions) <- Server.Pages.Typeahead.mkHandler (Just typeaheadCountLimit) graph let mkRootHandler = Server.Pages.Root.page (fixSvgWidth <> appendToHead <> bodyMargin) htmxScript initalSuggestions - searchEnv <- Server.Pages.Search.createSearchEnv graph + searchEnv <- Server.Pages.Search.createSearchEnv mkRootHandler graph pure $ Handlers - (mkRootHandler (mempty, Nothing)) - (\mHxBoosted mSrc mDst mMaxCount mNoGraph -> do - let runSearchHandler = Server.Pages.Search.handler searchConfig searchEnv mHxBoosted mSrc mDst mMaxCount mNoGraph - case mHxBoosted of - Just HxBoosted -> do - (searchResult, _) <- runSearchHandler - pure searchResult - Nothing -> do - (searchResult, (src, dst)) <- runSearchHandler - pure $ mkRootHandler (searchResult, Just (src, dst)) + (mkRootHandler (mempty, (Nothing, Nothing))) -- root handler + (\mHxBoosted mSrc mDst mMaxCount mNoGraph -> do -- search handler + Server.Pages.Search.handler + searchConfig + searchEnv + mHxBoosted + mSrc + mDst + mMaxCount + mNoGraph ) - typeaheadHandler + typeaheadHandler -- typeahead handler where typeaheadCountLimit = 25 diff --git a/src/server/Server/Pages/Root.hs b/src/server/Server/Pages/Root.hs index 45963e4..4130d1d 100644 --- a/src/server/Server/Pages/Root.hs +++ b/src/server/Server/Pages/Root.hs @@ -13,9 +13,8 @@ import Lucid import Lucid.Base import Lucid.Htmx import qualified Data.Text as T -import qualified FunGraph -import qualified Server.Pages.Typeahead import Server.HtmlStream +import Data.Maybe (fromMaybe) type HandlerType = HtmlStream IO () @@ -27,8 +26,9 @@ page -- ^ Append to 'body' content -> Html () -- ^ Initial typeahead suggestions (sequence of 'option' elements) - -> (HtmlStream m (), Maybe (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType)) - -- ^ Search result HTML and maybe the entered (src, dst). + -> (HtmlStream m (), (Maybe T.Text, Maybe T.Text)) + -- ^ 1. Search result HTML + -- 2. Maybe the entered (src, dst). NOTE: 'T.Text' instead of 'FunGraph.FullyQualifiedType' because we want to support filling the input fields with arbitrary text (not just valid types). -- -- If the user pastes a "/search?..." link into the browser then we want to display -- the root page with the search results included, as well as "src" and "dst" filled in. @@ -53,7 +53,7 @@ page appendToHead appendToBody initialSuggestions (searchResult, mSrcDst) = do form :: T.Text -- ^ targetId -> Html () -- ^ Initial suggestions - -> Maybe (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType) -- ^ Initial values for (src, dst) + -> (Maybe T.Text, Maybe T.Text) -- ^ Initial values for (src, dst) -> Html () form targetId initialSuggestions mSrcDst = do h2_ "Search" @@ -100,13 +100,13 @@ form targetId initialSuggestions mSrcDst = do mkTypeaheadInputs :: Html () - -> Maybe (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType) -- ^ Initial values for (src, dst) + -> (Maybe T.Text, Maybe T.Text) -- ^ Initial values for (src, dst) -> Html (Html (), Html ()) -mkTypeaheadInputs initialSuggestions mSrcDst = do +mkTypeaheadInputs initialSuggestions (mSrc, mDst) = do script_ $ "function " <> jsTriggerFunctionName <> "(event) { return event instanceof KeyboardEvent }" pure - ( mkInput' "src" (fst <$> mSrcDst) - , mkInput' "dst" (snd <$> mSrcDst) + ( mkInput' "src" mSrc + , mkInput' "dst" mDst ) where mkInput' = mkInput jsTriggerFunctionName attrs initialSuggestions @@ -122,7 +122,7 @@ mkInput -> [Attribute] -- ^ Attributes -> Html () -- ^ Initial suggestions -> T.Text -- ^ input ID - -> Maybe FunGraph.FullyQualifiedType -- ^ initial value (optional) + -> Maybe T.Text -- ^ initial value (optional) -> Html () mkInput jsTriggerFunctionName attrs initialSuggestions id' mInitialValue = do suggestions @@ -130,7 +130,7 @@ mkInput jsTriggerFunctionName attrs initialSuggestions id' mInitialValue = do [ name_ id' , id_ id' , type_ "search" - , value_ $ maybe mempty Server.Pages.Typeahead.renderSearchValue mInitialValue + , value_ $ fromMaybe mempty mInitialValue , list_ suggestionsId , hxGet_ "/typeahead" -- get suggestions from here (TODO: use something type-safe) , hxTarget_ $ "#" <> suggestionsId -- put suggestions here @@ -138,6 +138,8 @@ mkInput jsTriggerFunctionName attrs initialSuggestions id' mInitialValue = do , hxPushUrl_ "false" , autocomplete_ "off" , spellcheck_ "off" + , required_ "" + , autofocus_ ] where suggestionsId = "list_" <> id' diff --git a/src/server/Server/Pages/Search.hs b/src/server/Server/Pages/Search.hs index f4ea363..752b468 100644 --- a/src/server/Server/Pages/Search.hs +++ b/src/server/Server/Pages/Search.hs @@ -2,13 +2,20 @@ {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} module Server.Pages.Search -( page -, handler, HandlerType +( handler, HandlerType , SearchEnv, createSearchEnv , SearchConfig(..), defaultSearchConfig + -- * Validation +, VertexInputField -- TODO: how to export kind only? +, InputFieldValidationError(..) +, ValidationError +, renderHandlerError -- * Testing/benchmarking , mkResultAttribute ) @@ -28,9 +35,7 @@ import Control.Monad.Except (throwError) import Data.Maybe (fromMaybe, isNothing) import qualified Data.HashMap.Strict as HM import qualified Data.Graph.Digraph as DG -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as TLE -import Server.Api (HxBoosted, NoGraph (NoGraph)) +import Server.Api (HxBoosted (HxBoosted), NoGraph (NoGraph)) import Data.String (fromString) import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Bifunctor (bimap) @@ -38,14 +43,17 @@ import qualified Control.Monad.Except as ET import Server.HtmlStream import qualified Streaming.Prelude as S import qualified Data.BalancedStream -import Control.Monad (when) +import Control.Monad (when, forM) import qualified Data.Time.Clock import qualified Control.Monad.ST +import Data.These (These (..)) -- | Things we want to precompute when creating the handler data SearchEnv = SearchEnv { searchEnvGraph :: !(FunGraph.Graph ST.RealWorld) , searchEnvVertexLookup :: T.Text -> Maybe FunGraph.FullyQualifiedType + , searchEnvRootHandler :: (HtmlStream IO (), (Maybe T.Text, Maybe T.Text)) -> HtmlStream IO () + -- ^ Needed in case the 'HX-Boosted' header is not present, in which case a full page is returned } -- | Search options @@ -64,14 +72,16 @@ defaultSearchConfig = SearchConfig } createSearchEnv - :: FunGraph.Graph ST.RealWorld + :: ((HtmlStream IO (), (Maybe T.Text, Maybe T.Text)) -> HtmlStream IO ()) + -> FunGraph.Graph ST.RealWorld -> IO SearchEnv -createSearchEnv graph = do +createSearchEnv mkRootHandler graph = do vertices <- ST.stToIO $ DG.vertexLabels graph let hm = HM.fromList $ map (\fqt -> (FunGraph.renderFullyQualifiedType fqt, fqt)) vertices pure $ SearchEnv { searchEnvGraph = graph , searchEnvVertexLookup = (`HM.lookup` hm) + , searchEnvRootHandler = mkRootHandler } -- ^ /Search/ handler type @@ -83,33 +93,97 @@ type HandlerType ret -> Maybe NoGraph -- ^ if 'Just' then don't draw a graph -> Handler ret +type ValidationError = + (These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst)) + +renderHandlerError + :: These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst) + -> Html () +renderHandlerError = \case + This err -> renderError "source" err + That err -> renderError "target" err + These errSrc errTgt -> do + renderError "source" errSrc + renderError "target" errTgt + where + renderError :: T.Text -> InputFieldValidationError inputField -> Html () + renderError inputName = \case + InputFieldValidationError_MissingVertex -> + mkErrorText . toHtml $ "Missing " <> inputName <> " vertex" + InputFieldValidationError_NoSuchVertex input -> + mkErrorText $ + mconcat $ intersperse (toHtml (" " :: T.Text)) + [ toHtml $ "No such " <> inputName <> " vertex" + , mkMonoText (toHtml input) <> "." + , "Perhaps you meant one of: TODO" + ] + +-- | Full handler (considers 'HX-Boosted' header) handler :: SearchConfig -> SearchEnv - -> HandlerType (HtmlStream IO (), (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType)) -- ^ (html, (src, dst)) -handler cfg searchEnv _ (Just src) (Just dst) mMaxCount mNoGraph = - let defaultLimit = 100 -- TODO: add as HTML input field - in do + -> HandlerType (HtmlStream IO ()) +handler cfg searchEnv mHxBoosted mSrc mDst mMaxCount mNoGraph = do + eResult <- handler' cfg searchEnv mHxBoosted mSrc mDst mMaxCount mNoGraph + let searchResultHtml = case eResult of -- either the actual result or a human-readable error + Right searchResultStream -> + searchResultStream + Left err -> + Server.HtmlStream.streamHtml $ Server.Pages.Search.renderHandlerError err + -- pure $ eResult <&> \(_, (src, dst)) -> + pure $ case mHxBoosted of + Just HxBoosted -> + searchResultHtml + Nothing -> do + searchEnvRootHandler searchEnv (searchResultHtml, (mSrc, mDst)) + +-- | Pure Search handler (doesn't consider 'HX-Boosted' header) +handler' + :: SearchConfig + -> SearchEnv + -> HandlerType (Either ValidationError (HtmlStream IO ())) +handler' cfg searchEnv _ mSrc mDst mMaxCount mNoGraph = + forM validatedVertices $ \(src, dst) -> do page cfg searchEnv src dst (fromMaybe defaultLimit mMaxCount) mNoGraph -handler _ _ _ _ _ _ _ = - throwError $ err400 { errBody = "Missing 'src' and/or 'dst' query param" } + where + defaultLimit = 100 -- TODO: add as HTML input field + + validatedVertices + :: Either + (These (InputFieldValidationError 'Src) (InputFieldValidationError 'Dst)) + (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType) + validatedVertices = + case (validateVertex mSrc, validateVertex mDst) of + (Right src, Right dst) -> Right (src, dst) + (Left err, Right _) -> Left $ This err + (Right _, Left err) -> Left $ That err + (Left err1, Left err2) -> Left $ These err1 err2 + + validateVertex + :: Maybe T.Text + -> Either (InputFieldValidationError inputField) FunGraph.FullyQualifiedType + validateVertex Nothing = Left InputFieldValidationError_MissingVertex + validateVertex (Just txt) = + let lookupVertex = searchEnvVertexLookup searchEnv + in maybe + (Left $ InputFieldValidationError_NoSuchVertex txt) + Right + (lookupVertex txt) type StreamElem = ([FunGraph.NonEmpty FunGraph.TypedFunction], Double) page :: SearchConfig -> SearchEnv - -> T.Text - -> T.Text + -> FunGraph.FullyQualifiedType + -> FunGraph.FullyQualifiedType -> Word -> Maybe NoGraph - -> Handler (HtmlStream IO (), (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType)) -- ^ (html, (src, dst)) -page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do - src <- lookupVertexM srcTxt - dst <- lookupVertexM dstTxt + -> Handler (HtmlStream IO ()) +page cfg searchEnv src dst maxCount' mNoGraph = do eQueryResultStream <- liftIO $ query' (src, dst) queryResultStream <- either - (internalError . mkMissingVertexError (src, dst)) + (internalError . missingVertexError) pure eQueryResultStream let queryResultStreamWithAccum @@ -157,21 +231,20 @@ page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do renderTableWithRows True queryResultPathsWithResultNumber resultGraph accum = if null accum then mempty else ET.lift (mkGraph accum) >>= streamHtml - pure $ (, (src, dst)) $ do + pure $ do (timedOut, accum) <- resultsTable when timedOut $ streamHtml timedOutText when (null accum) $ - streamHtml $ noResultsText (src, dst) + streamHtml noResultsText resultGraph accum where maxCount = fromIntegral maxCount' - mkErrorText = p_ [style_ "color:red"] internalError errText = throwError $ err500 { errBody = "Internal error: " <> errText } - mkMissingVertexError (src, dst) (FunGraph.GraphActionError_NoSuchVertex v) = BSL.unwords + missingVertexError (FunGraph.GraphActionError_NoSuchVertex v) = BSL.unwords [ "Query returned 'no such vertex' error for vertex:" , fromString $ show v , "but we have the vertices right here:" @@ -201,13 +274,12 @@ page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do resultGraphE openSvgInNewWindowBtn svgGraphId - noResultsText :: (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType) -> Html () - noResultsText (src, dst) = + noResultsText = mkErrorText $ mconcat [ "No results found. No path from " - , mono $ toHtml $ FunGraph.renderFullyQualifiedType src + , mkMonoText $ toHtml $ FunGraph.renderFullyQualifiedType src , " to " - , mono $ toHtml $ FunGraph.renderFullyQualifiedType dst + , mkMonoText $ toHtml $ FunGraph.renderFullyQualifiedType dst , "." ] @@ -223,14 +295,7 @@ page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do [ href_ $ "https://hackage.haskell.org/package/" <> FunGraph.renderFgPackage fnPkg , target_ "_blank" ] - (mono $ toHtml $ FunGraph.fgPackageName fnPkg) - - -- TODO: don't throw 404; display HTML message and populate suggestions - lookupVertexM txt = - maybe - (throwError $ err404 { errBody = "Type not found: " <> TLE.encodeUtf8 (LT.fromStrict txt) }) - pure - (lookupVertex txt) + (mkMonoText $ toHtml $ FunGraph.fgPackageName fnPkg) queryTreeTimeoutIO = maybe @@ -241,7 +306,7 @@ page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do query' srcDst = ET.runExceptT $ queryTreeTimeoutIO - graph + (searchEnvGraph searchEnv) timeout maxCount srcDst @@ -270,17 +335,21 @@ page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do functionNameWithLink :: Html () functionNameWithLink = a_ [href_ $ FunGraph.functionToHackageDocsUrl fn, target_ "_blank"] - (mono $ toHtml $ FunGraph.renderFunctionNoPackage fn) + (mkMonoText $ toHtml $ FunGraph.renderFunctionNoPackage fn) in functionNameWithLink `with` [title_ typeSig] in div_ [mkResultAttribute (T.pack $ show resultNumber)] $ - mconcat $ intersperse (mono " . ") $ map renderSingleFn (reverse fns) + mconcat $ intersperse (mkMonoText " . ") $ map renderSingleFn (reverse fns) - mono = - let style = style_ $ T.intercalate "; " $ - [ "font-family: monospace, monospace" - , "background-color: rgb(200, 200, 200)" - ] - in span_ [style] +mkErrorText :: Html () -> Html () +mkErrorText = p_ [style_ "color:red"] + +mkMonoText :: Html () -> Html () +mkMonoText = + let style = style_ $ T.intercalate "; " + [ "font-family: monospace, monospace" + , "background-color: rgb(200, 200, 200)" + ] + in span_ [style] -- | Exported for benchmarking purposes: marks the actual results in the HTML so we can benchmark e.g. "time to first result" mkResultAttribute :: T.Text -> Attribute @@ -313,3 +382,11 @@ openSvgInNewWindowBtn svgGraphId = do ] where btnId = "open_svg_in_new_window" + +data VertexInputField + = Src + | Dst + +data InputFieldValidationError (inputField :: VertexInputField) + = InputFieldValidationError_MissingVertex + | InputFieldValidationError_NoSuchVertex T.Text