diff --git a/app/Env.hs b/app/Env.hs index 67bca31..240e1c2 100644 --- a/app/Env.hs +++ b/app/Env.hs @@ -23,6 +23,7 @@ import Share.Utils.Logging qualified as Logging import Share.Utils.Servant.Cookies qualified as Cookies import Share.Web.Authentication (cookieSessionTTL) import Hasql.Pool qualified as Pool +import Hasql.Pool.Config qualified as Pool import Network.URI (parseURI) import Servant.API qualified as Servant import System.Environment (lookupEnv) @@ -97,11 +98,11 @@ withEnv action = do let pgConnectionMaxIdleTime = Time.secondsToDiffTime (60 * 5) -- 5 minutes -- Limiting max lifetime helps cycle connections which may have accumulated memory cruft. let pgConnectionMaxLifetime = Time.secondsToDiffTime (60 * 60) -- 1 hour - pgConnectionPool <- - Pool.acquire postgresConnMax pgConnectionAcquisitionTimeout pgConnectionMaxLifetime pgConnectionMaxIdleTime (Text.encodeUtf8 postgresConfig) + let pgSettings = Pool.settings [Pool.staticConnectionSettings (Text.encodeUtf8 postgresConfig), Pool.size postgresConnMax, Pool.acquisitionTimeout pgConnectionAcquisitionTimeout, Pool.idlenessTimeout pgConnectionMaxIdleTime, Pool.agingTimeout pgConnectionMaxLifetime] + pgConnectionPool <- Pool.acquire pgSettings timeCache <- FL.newTimeCache FL.simpleTimeFormat -- E.g. 05/Sep/2023:13:23:56 -0700 sandboxedRuntime <- RT.startRuntime True RT.Persistent "share" - let requestCtx = () + let ctx = () -- We use a zero-width-space to separate log-lines on ingestion, this allows us to use newlines for -- formatting, but without affecting log-grouping. let zeroWidthSpace = "\x200B" diff --git a/package.yaml b/package.yaml index 8bdb42e..a120944 100644 --- a/package.yaml +++ b/package.yaml @@ -62,11 +62,13 @@ dependencies: - http-media - http-types - jose +- ki-unlifted - lens - megaparsec - memory - mmorph - monad-validate +- monoidal-containers - mtl - network - network-simple diff --git a/share-api.cabal b/share-api.cabal index 05047a1..0c04841 100644 --- a/share-api.cabal +++ b/share-api.cabal @@ -27,6 +27,12 @@ library Share Share.App Share.Backend + Share.BackgroundJobs + Share.BackgroundJobs.Errors + Share.BackgroundJobs.Monad + Share.BackgroundJobs.Search.DefinitionSync + Share.BackgroundJobs.Search.DefinitionSync.Types + Share.BackgroundJobs.Workers Share.Branch Share.Codebase Share.Codebase.Types @@ -45,6 +51,7 @@ library Share.Postgres.Causal.Types Share.Postgres.Comments.Queries Share.Postgres.Contributions.Queries + Share.Postgres.Cursors Share.Postgres.Definitions.Queries Share.Postgres.Definitions.Types Share.Postgres.Hashes.Queries @@ -63,6 +70,7 @@ library Share.Postgres.Projects.Queries Share.Postgres.Queries Share.Postgres.Refs.Types + Share.Postgres.Search.DefinitionSearch.Queries Share.Postgres.Serialization Share.Postgres.Sync.Conversions Share.Postgres.Sync.Queries @@ -144,6 +152,7 @@ library Unison.Server.NameSearch.Postgres Unison.Server.Share.Definitions Unison.Server.Share.DefinitionSummary + Unison.Server.Share.DefinitionSummary.Types Unison.Server.Share.Docs Unison.Server.Share.FuzzyFind Unison.Server.Share.NamespaceDetails @@ -217,11 +226,13 @@ library , http-media , http-types , jose + , ki-unlifted , lens , megaparsec , memory , mmorph , monad-validate + , monoidal-containers , mtl , network , network-simple @@ -356,11 +367,13 @@ executable share-api , http-media , http-types , jose + , ki-unlifted , lens , megaparsec , memory , mmorph , monad-validate + , monoidal-containers , mtl , network , network-simple diff --git a/share-utils/package.yaml b/share-utils/package.yaml index debe83c..519184e 100644 --- a/share-utils/package.yaml +++ b/share-utils/package.yaml @@ -71,6 +71,7 @@ dependencies: - jose - memory - network-uri +- pretty-simple - random - servant-auth - servant-server diff --git a/share-utils/share-utils.cabal b/share-utils/share-utils.cabal index 7b89c0a..b064344 100644 --- a/share-utils/share-utils.cabal +++ b/share-utils/share-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -24,6 +24,7 @@ source-repository head library exposed-modules: + Share.Debug Share.Utils.Binary Share.Utils.Deployment Share.Utils.IDs @@ -83,6 +84,7 @@ library , lens , memory , network-uri + , pretty-simple , random , servant-auth , servant-server diff --git a/share-utils/src/Share/Debug.hs b/share-utils/src/Share/Debug.hs new file mode 100644 index 0000000..0c6837e --- /dev/null +++ b/share-utils/src/Share/Debug.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +-- pTrace is marked deprecated so you get warnings when you use it. +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Share.Debug + ( debug, + debugM, + whenDebug, + debugLog, + debugLogM, + shouldDebug, + DebugFlag (..), + ) +where + +import Control.Monad +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Debug.Pretty.Simple (pTrace, pTraceM) +import Debug.Trace +import System.IO.Unsafe (unsafePerformIO) +import Text.Pretty.Simple (pShow) +import UnliftIO.Environment (lookupEnv) +import Witch (into) + +data DebugFlag + = Timing + | Queries + deriving (Eq, Ord, Show, Bounded, Enum) + +debugFlags :: Set DebugFlag +debugFlags = case (unsafePerformIO (lookupEnv "SHARE_DEBUG")) of + Nothing -> Set.empty + Just "" -> Set.fromList [minBound .. maxBound] + Just s -> Set.fromList $ do + w <- (Text.splitOn "," . Text.pack $ s) + case Text.toUpper . Text.strip $ w of + "TIMING" -> pure Timing + "QUERIES" -> pure Queries + _ -> mempty +{-# NOINLINE debugFlags #-} + +debugTiming :: Bool +debugTiming = Timing `Set.member` debugFlags +{-# NOINLINE debugTiming #-} + +debugQueries :: Bool +debugQueries = Queries `Set.member` debugFlags +{-# NOINLINE debugQueries #-} + +-- | Use for trace-style selective debugging. +-- E.g. 1 + (debug Sync "The second number" 2) +-- +-- Or, use in pattern matching to view arguments. +-- E.g. +-- myFunc (debug Sync "argA" -> argA) = ... +debug :: (Show a) => DebugFlag -> String -> a -> a +debug flag msg a = + if shouldDebug flag + then (trace (msg <> ":\n" <> into @String (pShow a)) a) + else a + +-- | Use for selective debug logging in monadic contexts. +-- E.g. +-- do +-- debugM Sync "source repo" srcRepo +-- ... +debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m () +debugM flag msg a = + whenDebug flag do + traceM (msg <> ":\n" <> into @String (pShow a)) + +debugLog :: DebugFlag -> String -> a -> a +debugLog flag msg = + if shouldDebug flag + then pTrace msg + else id + +debugLogM :: (Monad m) => DebugFlag -> String -> m () +debugLogM flag msg = + whenDebug flag $ pTraceM msg + +-- | A 'when' block which is triggered if the given flag is being debugged. +whenDebug :: (Monad m) => DebugFlag -> m () -> m () +whenDebug flag action = do + when (shouldDebug flag) action + +shouldDebug :: DebugFlag -> Bool +shouldDebug = \case + Timing -> debugTiming + Queries -> debugQueries diff --git a/share-utils/src/Share/Utils/IDs.hs b/share-utils/src/Share/Utils/IDs.hs index 42d029d..39581fb 100644 --- a/share-utils/src/Share/Utils/IDs.hs +++ b/share-utils/src/Share/Utils/IDs.hs @@ -122,6 +122,9 @@ instance (IsID a, Typeable a) => Hasql.DecodeValue (UsingID a) where Hasql.decodeValue & Decoder.refine \txt -> fromText txt <&> UsingID +instance (IsID a) => From (UsingID a) Text where + from = toText + -- | CI doesnt' expose its internal constructor so we can't derive via without adding our own -- instances. newtype CaseInsensitiveID = CaseInsensitiveID (CI Text) diff --git a/sql/2024-07-17-00-00_cursors.sql b/sql/2024-07-17-00-00_cursors.sql new file mode 100644 index 0000000..8880c27 --- /dev/null +++ b/sql/2024-07-17-00-00_cursors.sql @@ -0,0 +1,19 @@ + +CREATE OR REPLACE FUNCTION create_cursor(cursor_name text) +RETURNS refcursor AS $$ +DECLARE + segments text[]; + input_segments text[]; + current_segment text; +BEGIN + input_segments := string_to_array(trim(trailing '.' from fqn), '.'); + segments := ARRAY[]::text[]; + + FOREACH current_segment IN ARRAY input_segments + LOOP + segments := array_append(segments, array_to_string(input_segments[1:array_position(input_segments, current_segment)], '.') || '.'); + END LOOP; + + RETURN segments; +END; +$$ LANGUAGE plpgsql; diff --git a/sql/2024-07-18-00-00_defn_search.sql b/sql/2024-07-18-00-00_defn_search.sql new file mode 100644 index 0000000..b44d1ac --- /dev/null +++ b/sql/2024-07-18-00-00_defn_search.sql @@ -0,0 +1,39 @@ +-- Allows us to create composite indexes over traditionally non-GIN indexable types. +-- In this case it allows us to include the project_id and release_id in the GIN index for search tokens. +CREATE EXTENSION IF NOT EXISTS btree_gin; + +-- Allows us to create trigram indexes for fuzzy searching. +CREATE EXTENSION IF NOT EXISTS pg_trgm; + +-- New table for coordinating background job for syncing global definitions for search. + +-- Table of all releases which have been published, but not yet synced to the global definition search index. +CREATE TABLE global_definition_search_release_queue ( + release_id UUID PRIMARY KEY REFERENCES project_releases(id) ON DELETE CASCADE, + created_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT CURRENT_TIMESTAMP +); + +CREATE TABLE global_definition_search_docs ( + project_id UUID NOT NULL REFERENCES projects(id) ON DELETE CASCADE, + release_id UUID NOT NULL REFERENCES project_releases(id) ON DELETE CASCADE, + -- Fully qualified name + name TEXT NOT NULL, + search_tokens TSVECTOR NOT NULL, + -- Number of arguments. 0 for values. + arity INT NOT NULL, + + -- Contains the rendered type signature, type, hash, etc. + -- so we don't need to look up types for hundreds of search results on the fly. + metadata JSONB NOT NULL, + + -- Ostensibly there's the possibility of name conflicts, + -- but those are rare enough we don't care, we just insert with ON CONFLICT DO NOTHING. + PRIMARY KEY (project_id, release_id, name) +); + +-- Index for searching global definitions by 'search token', with an optional project/release filter. +-- P.s. there's a search token type for name, so we don't need to index that separately. +CREATE INDEX global_definition_search_tokens ON global_definition_search_docs USING GIN(search_tokens, project_id, release_id); + +-- Index for fuzzy-searching on the fully qualified name. +CREATE INDEX global_definition_search_name_trigram ON global_definition_search_docs USING GIST (name gist_trgm_ops); diff --git a/src/Share.hs b/src/Share.hs index de80e12..87bad24 100644 --- a/src/Share.hs +++ b/src/Share.hs @@ -22,6 +22,7 @@ import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Typeable qualified as Typeable import Data.UUID (UUID) import Data.Vault.Lazy as Vault +import Ki.Unlifted qualified as Ki import Network.HTTP.Types (HeaderName, statusCode) import Network.HTTP.Types qualified as HTTP import Network.URI qualified as URI @@ -35,6 +36,8 @@ import Network.Wai.Middleware.RequestLogger (logStdoutDev) import Network.Wai.Middleware.Routed (routedMiddleware) import Servant import Share.App +import Share.BackgroundJobs qualified as BackgroundJobs +import Share.BackgroundJobs.Monad (runBackground) import Share.Env qualified as Env import Share.IDs (RequestId, UserId) import Share.IDs qualified as IDs @@ -62,8 +65,10 @@ import UnliftIO.STM qualified as STM startApp :: Env.Env () -> IO () startApp env = do - app <- mkApp env - run (Env.serverPort env) app + app <- mkShareServer env + Ki.scoped \scope -> do + runBackground env "background-jobs" $ BackgroundJobs.startWorkers scope + run (Env.serverPort env) app newtype UncaughtException err = UncaughtException err deriving stock (Show) @@ -101,13 +106,13 @@ toServantHandler env appM = in Handler . ExceptT $ do -- fresh request ctx for each request. reqCtx <- WebApp.freshRequestCtx - runReaderT (unAppM $ catchErrors appM) (env {Env.requestCtx = reqCtx}) + runAppM (env {Env.ctx = reqCtx}) $ catchErrors appM -- | Uses context from the request to set up an appropriate RequestCtx type WrapperAPI = (RawRequest :> Header "X-NO-CACHE" Text :> Cookies.Cookie "NO-CACHE" Text :> Header "X-RequestID" RequestId :> MaybeAuthenticatedUserId :> Web.API) -mkApp :: Env.Env () -> IO Application -mkApp env = do +mkShareServer :: Env.Env () -> IO Application +mkShareServer env = do reqTagsKey <- Vault.newKey let reqLoggerMiddleware = mkReqLogger reqTagsKey (Env.timeCache env) (Env.logger env) metricsMiddleware <- serveMetricsMiddleware env @@ -160,7 +165,7 @@ mkApp env = do } ) do - reqTagsVar <- asks (WebApp.reqTagsVar . Env.requestCtx) + reqTagsVar <- asks (WebApp.reqTagsVar . Env.ctx) STM.atomically $ STM.modifyTVar' reqTagsVar (<> reqTags) m diff --git a/src/Share/App.hs b/src/Share/App.hs index 47e113c..c8303e4 100644 --- a/src/Share/App.hs +++ b/src/Share/App.hs @@ -1,6 +1,12 @@ {-# LANGUAGE InstanceSigs #-} -module Share.App where +module Share.App + ( AppM, + runAppM, + shareIssuer, + shareAud, + ) +where import Control.Monad.Random.Strict import Control.Monad.Reader @@ -13,10 +19,11 @@ import Share.Env qualified as Env import Share.Prelude import Share.Utils.Logging qualified as Logging -newtype AppM reqCtx a = AppM {unAppM :: ReaderT (Env reqCtx) IO a} +newtype AppM reqCtx a = AppM {_unAppM :: ReaderT (Env reqCtx) IO a} deriving newtype (Functor, Applicative, Monad, MonadReader (Env reqCtx), MonadRandom, MonadIO, MonadUnliftIO) -type CloudApp = AppM () +runAppM :: Env reqCtx -> AppM reqCtx a -> IO a +runAppM env (AppM m) = runReaderT m env instance Logging.MonadLogger (AppM ()) where logMsg msg = do @@ -30,9 +37,6 @@ instance Cryptonite.MonadRandom (AppM reqCtx) where getRandomBytes = liftIO . Cryptonite.getRandomBytes -runAppM :: Env reqCtx -> AppM reqCtx a -> IO a -runAppM env (AppM m) = runReaderT m env - instance R.MonadRedis (AppM reqCtx) where liftRedis m = do redis <- asks Env.redisConnection diff --git a/src/Share/BackgroundJobs.hs b/src/Share/BackgroundJobs.hs new file mode 100644 index 0000000..06b79d9 --- /dev/null +++ b/src/Share/BackgroundJobs.hs @@ -0,0 +1,10 @@ +module Share.BackgroundJobs (startWorkers) where + +import Ki.Unlifted qualified as Ki +import Share.BackgroundJobs.Monad (Background) +import Share.BackgroundJobs.Search.DefinitionSync qualified as DefnSearch + +-- | Kicks off all background workers. +startWorkers :: Ki.Scope -> Background () +startWorkers scope = do + DefnSearch.worker scope diff --git a/src/Share/BackgroundJobs/Errors.hs b/src/Share/BackgroundJobs/Errors.hs new file mode 100644 index 0000000..6f446b9 --- /dev/null +++ b/src/Share/BackgroundJobs/Errors.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs #-} + +module Share.BackgroundJobs.Errors + ( reportException, + reportError, + throwSomeServerError, + ) +where + +import Control.Exception (SomeException) +import Control.Monad.Except +import Data.HashMap.Lazy qualified as HM +import Data.Typeable qualified as Typeable +import Share.BackgroundJobs.Monad +import Share.Env qualified as Env +import Share.Monitoring qualified as Monitoring +import Share.Prelude +import Share.Utils.Logging (Loggable) +import Share.Utils.Logging qualified as Logging +import Share.Web.Errors (InternalServerError (..), withCallstack) +import UnliftIO qualified + +data SomeBackgroundError where + SomeBackgroundError :: (Typeable e, Loggable e) => e -> SomeBackgroundError + +instance Loggable SomeBackgroundError where + toLog (SomeBackgroundError e) = Logging.toLog e + +throwSomeServerError :: (Show e, Loggable e, MonadError SomeBackgroundError m, HasCallStack, Typeable e) => e -> m a +throwSomeServerError = throwError . SomeBackgroundError . withCallstack + +-- | Log any exceptions which occur within the worker. +-- Catch and return synchronous exceptions, but just log and rethrow async exceptions. +reportException :: Background a -> Background (Either SomeException a) +reportException bg = flip (UnliftIO.withException @_ @SomeException) (reportError . InternalServerError "uncaught-async-exception") do + UnliftIO.tryAny bg >>= \case + Left e@(UnliftIO.SomeException err) + | Just (SomeBackgroundError bgErr) <- Typeable.cast err -> do + reportError bgErr + pure $ Left e + | otherwise -> do + reportError $ InternalServerError "unknown-exception" err + pure $ Left e + Right a -> pure $ Right a + +-- | Logs the error with a call stack, but doesn't abort the request or render an error to the client. +reportError :: (HasCallStack, Loggable e) => e -> Background () +reportError e = do + env <- ask + let BackgroundCtx {workerName} = Env.ctx env + let coreTags = HM.fromList [("workerName", into @String workerName)] + let extraTags = HM.fromList [] + let errID = "background-job:" <> workerName + let errLog = Logging.toLog e + Monitoring.reportError env coreTags extraTags errID e + Logging.logMsg (Logging.withSeverity Logging.Error $ errLog) diff --git a/src/Share/BackgroundJobs/Monad.hs b/src/Share/BackgroundJobs/Monad.hs new file mode 100644 index 0000000..26f2abb --- /dev/null +++ b/src/Share/BackgroundJobs/Monad.hs @@ -0,0 +1,42 @@ +-- | Background worker monad +module Share.BackgroundJobs.Monad + ( Background, + BackgroundCtx (..), + withWorkerName, + runBackground, + ) +where + +import Data.Map qualified as Map +import Share.App +import Share.Env +import Share.Env qualified as Env +import Share.Prelude +import Share.Utils.Logging qualified as Logging + +data BackgroundCtx = BackgroundCtx + { workerName :: Text + } + +type Background = AppM BackgroundCtx + +localBackgroundCtx :: (MonadReader (Env BackgroundCtx) m) => (BackgroundCtx -> BackgroundCtx) -> m a -> m a +localBackgroundCtx f = local \env -> env {ctx = f (ctx env)} + +withWorkerName :: Text -> Background a -> Background a +withWorkerName name = localBackgroundCtx \ctx -> ctx {workerName = name} + +instance Logging.MonadLogger Background where + logMsg msg = do + log <- asks Env.logger + BackgroundCtx {workerName} <- asks ctx + let currentTags = Map.singleton "workerName" workerName + msg <- pure $ msg {Logging.tags = Logging.tags msg `Map.union` currentTags} + minSeverity <- asks Env.minLogSeverity + when (Logging.severity msg >= minSeverity) $ do + timestamp <- asks timeCache >>= liftIO + liftIO . log . Logging.logFmtFormatter timestamp $ msg + +runBackground :: Env () -> Text -> Background a -> IO a +runBackground env workerName bg = + runAppM env {ctx = BackgroundCtx {workerName}} bg diff --git a/src/Share/BackgroundJobs/Search/DefinitionSync.hs b/src/Share/BackgroundJobs/Search/DefinitionSync.hs new file mode 100644 index 0000000..2534ce8 --- /dev/null +++ b/src/Share/BackgroundJobs/Search/DefinitionSync.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE DataKinds #-} + +module Share.BackgroundJobs.Search.DefinitionSync (worker) where + +import Control.Lens +import Control.Monad.Except +import Data.Either (isRight) +import Data.Generics.Product (HasField (..)) +import Data.List qualified as List +import Data.Map qualified as Map +import Data.Map.Monoidal.Strict (MonoidalMap) +import Data.Map.Monoidal.Strict qualified as MonMap +import Data.Monoid (Any (..), Sum (..)) +import Data.Set qualified as Set +import Data.Set.Lens (setOf) +import Ki.Unlifted qualified as Ki +import Share.BackgroundJobs.Monad (Background) +import Share.BackgroundJobs.Search.DefinitionSync.Types (DefinitionDocument (..), DefnSearchToken (..), Occurrence, TermOrTypeSummary (..), VarId (VarId)) +import Share.BackgroundJobs.Workers (newWorker) +import Share.Codebase (CodebaseM) +import Share.Codebase qualified as Codebase +import Share.IDs (ProjectId, ReleaseId) +import Share.Metrics qualified as Metrics +import Share.Postgres qualified as PG +import Share.Postgres.Cursors qualified as Cursors +import Share.Postgres.Hashes.Queries qualified as HashQ +import Share.Postgres.IDs (BranchHashId) +import Share.Postgres.NameLookups.Ops qualified as NLOps +import Share.Postgres.NameLookups.Types qualified as NL +import Share.Postgres.Queries qualified as PG +import Share.Postgres.Search.DefinitionSearch.Queries qualified as DDQ +import Share.Prelude +import Share.Project (Project (..), ProjectVisibility (..)) +import Share.Release (Release (..)) +import Share.User (User (..), UserVisibility (..)) +import Share.Utils.Logging qualified as Logging +import Share.Web.Authorization qualified as AuthZ +import U.Codebase.Referent (Referent) +import U.Codebase.Referent qualified as Referent +import Unison.ABT qualified as ABT +import Unison.ConstructorType qualified as CT +import Unison.DataDeclaration qualified as DD +import Unison.Debug qualified as Debug +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.LabeledDependency qualified as LD +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.NameSegment (NameSegment) +import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres +import Unison.Reference (TypeReference) +import Unison.Reference qualified as Reference +import Unison.Server.Share.DefinitionSummary qualified as Summary +import Unison.Server.Share.DefinitionSummary.Types qualified as Summary +import Unison.Server.Types qualified as Server.Types +import Unison.ShortHash (ShortHash) +import Unison.Type qualified as Type +import Unison.Util.Monoid qualified as Monoid +import Unison.Util.Set qualified as Set +import Unison.Var qualified as Var +import UnliftIO.Concurrent qualified as UnliftIO + +data DefnIndexingFailure + = NoTypeSigForTerm Name Referent + | NoDeclForType Name TypeReference + +-- | How often to poll for new releases to sync in seconds. +pollingIntervalSeconds :: Int +pollingIntervalSeconds = 10 + +-- | How many definitions to hold in memory at a time while syncing +defnBatchSize :: Int32 +defnBatchSize = 1000 + +worker :: Ki.Scope -> Background () +worker scope = do + authZReceipt <- AuthZ.backgroundJobAuthZ + newWorker scope "search:defn-sync" $ forever do + Logging.logInfoText "Syncing definitions..." + Metrics.recordDefinitionSearchIndexDuration $ PG.runTransactionMode PG.ReadCommitted PG.ReadWrite $ do + mayReleaseId <- DDQ.claimUnsyncedRelease + Debug.debugM Debug.Temp "Syncing release" mayReleaseId + for_ mayReleaseId (syncRelease authZReceipt) + liftIO $ UnliftIO.threadDelay $ pollingIntervalSeconds * 1000000 + +syncRelease :: + AuthZ.AuthZReceipt -> + ReleaseId -> + PG.Transaction e [DefnIndexingFailure] +syncRelease authZReceipt releaseId = fmap (fromMaybe []) . runMaybeT $ do + Release {projectId, releaseId, squashedCausal} <- lift $ PG.expectReleaseById releaseId + -- Wipe out any existing rows for this release. Normally there should be none, but this + -- makes it easy to re-index later if we change how we tokenize things. + lift $ DDQ.cleanIndexForRelease releaseId + Project {ownerUserId, visibility = projectVis} <- lift $ PG.expectProjectById projectId + User {visibility = userVis} <- PG.expectUserByUserId ownerUserId + -- Don't sync private projects + guard $ projectVis == ProjectPublic + -- Don't sync private users + guard $ userVis == UserPublic + Debug.debugM Debug.Temp "Syncing release" releaseId + lift $ do + bhId <- HashQ.expectNamespaceIdsByCausalIdsOf id squashedCausal + Debug.debugM Debug.Temp "bhId" bhId + namesPerspective <- NLOps.namesPerspectiveForRootAndPath bhId (NL.PathSegments []) + let nlReceipt = NL.nameLookupReceipt namesPerspective + let codebaseLoc = Codebase.codebaseLocationForProjectRelease ownerUserId + let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc + Codebase.codebaseMToTransaction codebase $ do + Debug.debugM Debug.Temp "Building cursor" releaseId + termsCursor <- lift $ NLOps.termsWithinNamespace nlReceipt bhId + Debug.debugM Debug.Temp "Syncing terms" releaseId + termErrs <- syncTerms namesPerspective bhId projectId releaseId termsCursor + typesCursor <- lift $ NLOps.typesWithinNamespace nlReceipt bhId + Debug.debugM Debug.Temp "Syncing types" releaseId + typeErrs <- syncTypes namesPerspective projectId releaseId typesCursor + pure (termErrs <> typeErrs) + +syncTerms :: + NL.NamesPerspective -> + BranchHashId -> + ProjectId -> + ReleaseId -> + Cursors.PGCursor (Name, Referent) -> + CodebaseM e [DefnIndexingFailure] +syncTerms namesPerspective bhId projectId releaseId termsCursor = do + Cursors.foldBatched termsCursor defnBatchSize \terms -> do + Debug.debugM Debug.Temp "Fetched N more terms" (length terms) + (errs, refDocs) <- + PG.timeTransaction "Building terms" $ + terms & foldMapM \(fqn, ref) -> fmap (either (\err -> ([err], [])) (\doc -> ([], [doc]))) . runExceptT $ do + typ <- lift (Codebase.loadTypeOfReferent ref) `whenNothingM` throwError (NoTypeSigForTerm fqn ref) + termSummary <- lift $ Summary.termSummaryForReferent ref typ (Just fqn) bhId Nothing Nothing + let sh = Referent.toShortHash ref + let (refTokens, arity) = tokensForTerm fqn ref typ termSummary + let dd = + DefinitionDocument + { project = projectId, + release = releaseId, + fqn, + hash = sh, + tokens = refTokens, + arity = arity, + metadata = ToTTermSummary termSummary + } + pure dd + + -- It's much more efficient to build only one PPE per batch. + let allDeps = setOf (folded . folding tokens . folded . to LD.TypeReference) refDocs + pped <- PG.timeTransaction "Build PPED" $ PPEPostgres.ppedForReferences namesPerspective allDeps + let ppe = PPED.unsuffixifiedPPE pped + let namedDocs :: [DefinitionDocument ProjectId ReleaseId Name (NameSegment, ShortHash)] + namedDocs = + refDocs + & traversed . field @"tokens" %~ Set.mapMaybe \token -> do + for token \ref -> do + name <- PPE.types ppe ref + pure $ (Name.lastSegment . HQ'.toName $ name, Reference.toShortHash ref) + lift $ PG.timeTransaction "Inserting Docs" $ DDQ.insertDefinitionDocuments namedDocs + pure errs + +-- | Compute the search tokens for a term given its name, hash, and type signature +tokensForTerm :: (Var.Var v) => Name -> Referent -> Type.Type v a -> Summary.TermSummary -> (Set (DefnSearchToken TypeReference), Int) +tokensForTerm name ref typ (Summary.TermSummary {tag}) = do + let sh = Referent.toShortHash ref + baseTokens = Set.fromList [NameToken name, HashToken sh] + tagTokens = Set.singleton $ TermTagToken tag + (tsTokens, arity) = typeSigTokens typ + in (baseTokens <> tsTokens <> tagTokens, arity) + +data TokenGenEnv v = TokenGenEnv + { varIds :: Map v VarId + } + deriving stock (Show, Generic) + +data TokenGenState v = TokenGenState + { nextVarId :: VarId + } + deriving stock (Show, Generic) + +type TokenGenM v = ReaderT (TokenGenEnv v) (State (TokenGenState v)) + +-- | Compute var occurrence and type ref occurrence search tokens from a type signature. +typeSigTokens :: forall v ann. (Var.Var v) => Type.Type v ann -> (Set (DefnSearchToken TypeReference), Int) +typeSigTokens typ = + let occMap :: MonoidalMap (Either VarId TypeReference) (Occurrence, Any) + arity :: Int + (occMap, Sum arity) = flip evalState initState . flip runReaderT (TokenGenEnv mempty) $ ABT.cata alg typ + (varIds, typeRefs) = + MonMap.toList occMap & foldMap \case + (Left vId, (occ, ret)) -> ([(vId, (occ, ret))], []) + (Right typeRef, (occ, ret)) -> ([], [(typeRef, (occ, ret))]) + expandedVarTokens = + varIds + -- Rewrite varIds normalized by number of occurrences, + -- this is necessary to ensure that order of type variables + -- in a type signature don't actually matter. + -- + -- E.g. BOTH of (a -> b -> a) and (b -> a -> a) turn into [(VarId 1, 1), (VarId 2, 2)] + & List.sortOn snd + -- Expand a token for each occurrence of a variable, this way + -- a -> a -> a still matches the type a -> a, since the user may not have typed the + -- whole thing. + & imap (\i (_vId, occ) -> (VarId i, occ)) + -- Expand a token for each occurrence of a variable, this way + -- 'Text' still matches the type 'Text -> Text' + & foldMap + ( \(vId, (occ, Any isReturn)) -> + Monoid.whenM isReturn [TypeVarToken vId Nothing] <> ((TypeVarToken vId . Just) <$> [1 .. occ]) + ) + & Set.fromList + expandedTypeRefTokens = + typeRefs + & foldMap \(typeRef, (occ, Any isReturn)) -> + Monoid.whenM isReturn [TypeMentionToken typeRef Nothing] <> (TypeMentionToken typeRef . Just <$> [1 .. occ]) + & Set.fromList + in (expandedVarTokens <> expandedTypeRefTokens, arity) + where + initState = TokenGenState 0 + -- Cata algebra for collecting type reference tokens from a type signature. + alg :: + ann -> + ABT.ABT Type.F v (TokenGenM v (MonoidalMap (Either VarId TypeReference) (Occurrence, Any {- Is return type -}), Sum Int)) -> + TokenGenM v (MonoidalMap (Either VarId TypeReference) (Occurrence, Any {- Is return type -}), Sum Int) + alg _ann = \case + ABT.Var v -> do + vId <- varIdFor v + pure $ (MonMap.singleton (Left vId) (1, Any True), mempty) + ABT.Cycle a -> a + ABT.Abs v r -> do + vId <- nextVarId + local (field @"varIds" . at v ?~ vId) r + ABT.Tm tf -> case tf of + Type.Ref typeRef -> do + pure $ (MonMap.singleton (Right typeRef) (1, Any True), mempty) + Type.Arrow a b -> do + -- Anything on the left of an arrow is not a return type. + aTokens <- a <&> \(toks, _arity) -> MonMap.map (\(occ, _) -> (occ, Any False)) toks + (bTokens, arity) <- b + pure $ (aTokens <> bTokens, arity + 1) + Type.Ann a _kind -> a + -- At the moment we don't handle higher kinded type applications differently than regular + -- type mentions. + Type.App a b -> do + aTokens <- a + bTokens <- b + pure $ aTokens <> bTokens + Type.Effect a b -> do + -- Don't include vars from effects. + aTokens <- removeVars . fst <$> a + (bTokens, bArity) <- b + pure $ (aTokens <> bTokens, bArity) + Type.Effects as -> first removeVars <$> Monoid.foldMapM id as + Type.Forall a -> a + Type.IntroOuter a -> a + removeVars :: MonoidalMap (Either VarId TypeReference) (Occurrence, Any) -> MonoidalMap (Either VarId TypeReference) (Occurrence, Any) + removeVars = MonMap.filterWithKey (\k _ -> isRight k) + nextVarId :: TokenGenM v VarId + nextVarId = field @"nextVarId" <<%= succ + varIdFor :: v -> TokenGenM v VarId + varIdFor v = do + asks (Map.lookup v . varIds) >>= \case + Just vid -> pure vid + Nothing -> do + error "typeRefTokens: Found variable without corresponding Abs in type signature" + +syncTypes :: + NL.NamesPerspective -> + ProjectId -> + ReleaseId -> + Cursors.PGCursor (Name, TypeReference) -> + CodebaseM e [DefnIndexingFailure] +syncTypes namesPerspective projectId releaseId typesCursor = do + Cursors.foldBatched typesCursor defnBatchSize \types -> do + (errs, refDocs) <- + types & foldMapM \(fqn, ref) -> fmap (either (\err -> ([err], [])) (\doc -> ([], [doc]))) . runExceptT $ do + (declTokens, declArity) <- case ref of + Reference.Builtin _ -> pure (mempty, 0) + Reference.DerivedId refId -> do + decl <- lift (Codebase.loadTypeDeclaration refId) `whenNothingM` throwError (NoDeclForType fqn ref) + pure $ (tokensForDecl refId decl, length . DD.bound $ DD.asDataDecl decl) + let basicTokens = Set.fromList [NameToken fqn, HashToken $ Reference.toShortHash ref] + + typeSummary <- lift $ Summary.typeSummaryForReference ref (Just fqn) Nothing + let sh = Reference.toShortHash ref + let dd = + DefinitionDocument + { project = projectId, + release = releaseId, + fqn, + hash = sh, + tokens = declTokens <> basicTokens, + arity = declArity, + metadata = ToTTypeSummary typeSummary + } + pure dd + -- It's much more efficient to build only one PPE per batch. + let allDeps = setOf (folded . folding tokens . folded . to LD.TypeReference) refDocs + pped <- PPEPostgres.ppedForReferences namesPerspective allDeps + let ppe = PPED.unsuffixifiedPPE pped + let namedDocs :: [DefinitionDocument ProjectId ReleaseId Name (NameSegment, ShortHash)] + namedDocs = + refDocs + & traversed . field @"tokens" %~ Set.mapMaybe \token -> do + for token \ref -> do + name <- PPE.types ppe ref + pure $ (Name.lastSegment . HQ'.toName $ name, Reference.toShortHash ref) + lift $ DDQ.insertDefinitionDocuments namedDocs + pure errs + +tokensForDecl :: Reference.TypeReferenceId -> DD.Decl v a -> Set (DefnSearchToken TypeReference) +tokensForDecl _typeRefId decl = do + let ddecl = DD.asDataDecl decl + tagToken = case DD.constructorType decl of + CT.Data -> TypeTagToken Server.Types.Data + CT.Effect -> TypeTagToken Server.Types.Ability + modToken = TypeModToken $ DD.modifier ddecl + in -- Include the constructors as Name Tokens + -- constructorTokens = + -- DD.declConstructorReferents typeRefId decl + -- & (fmap . fmap) Reference.DerivedId + -- <&> \constructorReferent -> ConstructorToken constructorReferent + Set.fromList $ [tagToken, modToken] diff --git a/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs b/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs new file mode 100644 index 0000000..dd87d41 --- /dev/null +++ b/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} + +module Share.BackgroundJobs.Search.DefinitionSync.Types + ( TermOrTypeSummary (..), + DefinitionDocument (..), + DefnSearchToken (..), + Occurrence (..), + VarId (..), + ) +where + +import Data.Aeson +import Data.Monoid (Sum (..)) +import Data.Text qualified as Text +import Share.Prelude +import Unison.DataDeclaration qualified as DD +import Unison.Name (Name) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary (..), TypeSummary (..)) +import Unison.Server.Types (TermTag, TypeTag) +import Unison.ShortHash (ShortHash) + +data TermOrTypeSummary = ToTTermSummary TermSummary | ToTTypeSummary TypeSummary + deriving (Show) + +instance ToJSON TermOrTypeSummary where + toJSON (ToTTermSummary ts) = object ["kind" .= ("term" :: Text), "payload" .= ts] + toJSON (ToTTypeSummary ts) = object ["kind" .= ("type" :: Text), "payload" .= ts] + +instance FromJSON TermOrTypeSummary where + parseJSON = withObject "TermOrTypeSummary" $ \o -> do + kind :: Text <- o .: "kind" + case kind of + "term" -> do + ts <- o .: "payload" + ts & withObject "TermSummary" \o -> do + displayName <- o .: "displayName" + hash <- o .: "hash" + summary <- o .: "summary" + tag <- o .: "tag" + pure $ ToTTermSummary $ TermSummary {..} + "type" -> do + ts <- o .: "payload" + ts & withObject "TypeSummary" \o -> do + displayName <- o .: "displayName" + hash <- o .: "hash" + summary <- o .: "summary" + tag <- o .: "tag" + pure $ ToTTypeSummary $ TypeSummary {..} + _ -> fail $ "Invalid kind: " <> Text.unpack kind + +-- | The number of occurences of this token in the search query. +-- E.g. for the query: 'Text -> Text -> Text', the Text type mention token would +-- occur 3 times, and the set would be: +-- {NameMention "Text" (Occurrence 1), NameMention "Text" (Occurrence 2), NameMention "Text" (Occurrence 3)} +newtype Occurrence = Occurrence Int + deriving newtype (Show, Read, Eq, Ord, Num, ToJSON, Enum) + deriving (Semigroup) via Sum Int + deriving (Monoid) via Sum Int + +-- | An id for identifying unique type variables mentioned in a query. +-- E.g. 'map : (a -> b) -> List a -> List b' would have two type var Ids, one for a, one +-- for b, and would have occurrences 1 and 2 for each respectively. +newtype VarId = VarId Int + deriving newtype (Show, Read, Eq, Ord, Num, ToJSON, Enum) + +-- | Represents the possible ways we can search the global definitions index. +data DefnSearchToken typeRef + = -- Allows searching by literal name + NameToken Name + | -- A mention of some external type or ability + TypeMentionToken typeRef (Maybe Occurrence {- Nothing means it's a return value -}) + | -- Allows searching for type sigs with type variables + TypeVarToken VarId (Maybe Occurrence {- Nothing means it's a return value -}) + | -- Allows searching by component hash + -- Note: not actually a _short_ hash, it's a full hash with the referent info tagged + -- on. + HashToken ShortHash + | TermTagToken TermTag + | TypeTagToken TypeTag + | TypeModToken DD.Modifier + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) + +-- | Converts a DefnSearchToken to a prefix-searchable text string. +-- +-- >>> tokenToText (NameToken (Name.unsafeParseText "List.map")) +-- "List.map:name" +-- +-- >>> tokenToText (TypeMentionToken (Name.unsafeParseText "List.map") (Occurrence 1)) +-- "List.map:mention:1" +-- +-- >>> tokenToText (TypeVarToken (VarId 1) (Occurrence 1)) +-- "_:var:1:1" +-- +-- >>> import Unison.Hash qualified as Hash +-- >>> import U.Codebase.HashTags (ComponentHash (..)) +-- >>> hash = ComponentHash $ Hash.unsafeFromBase32HexText "abcd" +-- >>> tokenToText (HashToken hash) +-- "#abc0:hash" +-- tokenToText :: DefnSearchToken Name -> Text +-- tokenToText = \case +-- (NameToken n) -> Text.intercalate ":" [Name.toText n, "name"] +-- (TypeMentionToken n o) -> Text.intercalate ":" [Name.toText n, "mention", tShow o] +-- (TypeVarToken v o) -> Text.intercalate ":" ["_", "var", tShow v, tShow o] +-- (HashToken h) -> Text.intercalate ":" [into @Text $ PrefixedHash @"#" h, "hash"] + +-- tokenFromText :: Text -> Maybe (DefnSearchToken Name) +-- tokenFromText t = case Text.splitOn ":" t of +-- [name, "name"] -> NameToken <$> Name.parseText name +-- [name, "mention", occ] -> TypeMentionToken <$> (Name.parseText name) <*> readMaybe (Text.unpack occ) +-- [_, "var", vid, occ] -> TypeVarToken <$> readMaybe (Text.unpack vid) <*> readMaybe (Text.unpack occ) +-- [prefixedHash, "hash"] -> +-- case Text.stripPrefix "#" prefixedHash of +-- Just hash -> HashToken . into @ComponentHash <$> Hash.fromBase32HexText hash +-- Nothing -> Nothing +-- _ -> Nothing + +data DefinitionDocument proj release name typeRef = DefinitionDocument + { project :: proj, + release :: release, + fqn :: Name, + hash :: ShortHash, + -- For now we only index types by their final name segment, may need to revisit this + -- in the future. + tokens :: Set (DefnSearchToken typeRef), + arity :: Int, + metadata :: TermOrTypeSummary + } + deriving (Show, Generic) + +data SearchDefinition = SearchDefinition + { fqn :: Name, + hash :: ShortHash + } + deriving (Show) diff --git a/src/Share/BackgroundJobs/Workers.hs b/src/Share/BackgroundJobs/Workers.hs new file mode 100644 index 0000000..8c24977 --- /dev/null +++ b/src/Share/BackgroundJobs/Workers.hs @@ -0,0 +1,14 @@ +module Share.BackgroundJobs.Workers (newWorker) where + +import Ki.Unlifted qualified as Ki +import Share.BackgroundJobs.Errors (reportException) +import Share.BackgroundJobs.Monad (Background, withWorkerName) +import Share.Prelude + +-- | Creates a worker that runs forever. +-- Any exceptions will be caught and logged, then the worker will be restarted. +newWorker :: Ki.Scope -> Text -> Background Void -> Background () +newWorker scope workerName worker = withWorkerName workerName do + Ki.fork_ scope do + -- Run the worker forever, catching and logging any syncronous exceptions, but then restarting. + forever $ reportException worker diff --git a/src/Share/Codebase.hs b/src/Share/Codebase.hs index 0573429..90bb085 100644 --- a/src/Share/Codebase.hs +++ b/src/Share/Codebase.hs @@ -74,6 +74,8 @@ import Data.ByteString.Lazy.Char8 qualified as BL import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text.Encoding qualified as Text +import Servant qualified +import Servant.Server (err500) import Share.Branch (Branch (..)) import Share.Codebase.Types import Share.Codebase.Types qualified as Codebase @@ -99,8 +101,6 @@ import Share.Web.App import Share.Web.Authorization (AuthZReceipt) import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors -import Servant qualified -import Servant.Server (err500) import U.Codebase.Branch qualified as V2 import U.Codebase.Causal qualified as Causal import U.Codebase.Decl qualified as V2 @@ -113,6 +113,7 @@ import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.ConstructorType qualified as CT import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration qualified as V1 +import Unison.Debug qualified as Debug import Unison.Parser.Ann import Unison.Parser.Ann qualified as Ann import Unison.Prelude (askUnliftIO) @@ -278,10 +279,10 @@ expectTypeOfReferents :: Traversal s t V2.Referent (V1.Type Symbol Ann) -> s -> expectTypeOfReferents trav s = do s & trav %%~ expectTypeOfReferent -expectDeclKind :: PG.QueryM m => Reference.TypeReference -> m CT.ConstructorType +expectDeclKind :: (PG.QueryM m) => Reference.TypeReference -> m CT.ConstructorType expectDeclKind r = loadDeclKind r `whenNothingM` (unrecoverableError (InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r)) -expectDeclKindsOf :: PG.QueryM m => Traversal s t Reference.TypeReference CT.ConstructorType -> s -> m t +expectDeclKindsOf :: (PG.QueryM m) => Traversal s t Reference.TypeReference CT.ConstructorType -> s -> m t expectDeclKindsOf trav s = do s & unsafePartsOf trav %%~ \refs -> do @@ -290,10 +291,10 @@ expectDeclKindsOf trav s = do (r, Nothing) -> unrecoverableError (InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r) (_, Just ct) -> pure ct -loadDeclKind :: PG.QueryM m => V2.TypeReference -> m (Maybe CT.ConstructorType) +loadDeclKind :: (PG.QueryM m) => V2.TypeReference -> m (Maybe CT.ConstructorType) loadDeclKind = loadDeclKindsOf id -loadDeclKindsOf :: PG.QueryM m => Traversal s t Reference.TypeReference (Maybe CT.ConstructorType) -> s -> m t +loadDeclKindsOf :: (PG.QueryM m) => Traversal s t Reference.TypeReference (Maybe CT.ConstructorType) -> s -> m t loadDeclKindsOf trav s = s & unsafePartsOf trav %%~ \refs -> do @@ -448,6 +449,7 @@ squashCausalAndAddToCodebase causalId = runMaybeT $ do causalBranch <- MaybeT (CausalQ.loadCausalNamespace causalId) (squashedCausalId, _squashedCausal) <- lift $ squashCausal causalBranch squashedBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id squashedCausalId + Debug.debugLogM Debug.Temp "Squashed, making name lookup" lift . lift $ NLOps.ensureNameLookupForBranchId squashedBranchHashId pure squashedCausalId @@ -455,6 +457,7 @@ squashCausalAndAddToCodebase causalId = runMaybeT $ do -- Causal node at every level. squashCausal :: V2.CausalBranch (CodebaseM e) -> CodebaseM e (CausalId, V2.CausalBranch (CodebaseM e)) squashCausal Causal.Causal {valueHash = unsquashedBranchHash, value} = do + Debug.debugM Debug.Temp "Squashing" unsquashedBranchHash mayCachedSquashResult <- runMaybeT $ do causalId <- MaybeT (CausalQ.tryGetCachedSquashResult unsquashedBranchHash) fmap (causalId,) . MaybeT $ CausalQ.loadCausalNamespace causalId diff --git a/src/Share/Env.hs b/src/Share/Env.hs index df0155f..e201b21 100644 --- a/src/Share/Env.hs +++ b/src/Share/Env.hs @@ -4,19 +4,19 @@ module Share.Env where import Database.Redis qualified as R +import Hasql.Pool qualified as Hasql +import Network.URI (URI) +import Servant qualified as S import Share.JWT qualified as JWT import Share.Prelude import Share.Utils.Logging.Types qualified as Logging import Share.Utils.Servant.Cookies qualified as Cookies -import Hasql.Pool qualified as Hasql -import Network.URI (URI) -import Servant qualified as S import System.Log.FastLogger (FormattedTime, LogStr) import System.Log.Raven.Types (SentryService) import Unison.Codebase.Runtime (Runtime) import Unison.Symbol (Symbol) -data Env reqCtx = Env +data Env ctx = Env { redisConnection :: R.Connection, pgConnectionPool :: Hasql.Pool, logger :: LogStr -> IO (), @@ -41,7 +41,7 @@ data Env reqCtx = Env sentryService :: SentryService, -- The commit hash of the currently running version of Share commitHash :: Text, - requestCtx :: reqCtx, + ctx :: ctx, shouldCheckForMigration :: Bool, -- The maximum number of workers to use for concurrent work on a single request. -- E.g. sync can parallelize signing/verifying JWTs or run multiple transactions against diff --git a/src/Share/IDs.hs b/src/Share/IDs.hs index fdff53c..fd90b93 100644 --- a/src/Share/IDs.hs +++ b/src/Share/IDs.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Share.IDs @@ -54,6 +55,9 @@ import Data.Char qualified as Char import Data.List (intercalate) import Data.Text qualified as Text import Data.UUID (UUID) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Hasql.Interpolate qualified as Hasql +import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Share.OAuth.Types ( JTI (..), PendingSessionId (..), @@ -62,9 +66,6 @@ import Share.OAuth.Types ) import Share.Prelude import Share.Utils.IDs (CaseInsensitiveID (..), IsID (..), PrefixedID (..), UsingID (..), fromId, fromUUID, idFrom) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Hasql.Interpolate qualified as Hasql -import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Text.Megaparsec ( ErrorFancy (..), MonadParsec (eof, takeWhileP), @@ -357,8 +358,10 @@ branchNameParser = do Megaparsec.observing eof >>= \case Left _ -> pure () Right () -> customFailure BranchNameParseFailure'Empty - (BranchNameTag'ReleaseDraft,) . releaseDraftFixup <$> releaseDraftParser - <|> (BranchNameTag'Plain,) <$> plainBranchParser + (BranchNameTag'ReleaseDraft,) . releaseDraftFixup + <$> releaseDraftParser + <|> (BranchNameTag'Plain,) + <$> plainBranchParser where releaseDraftParser :: Parsec BranchNameParseFailure Text ReleaseVersion releaseDraftParser = do @@ -650,6 +653,11 @@ newtype PrefixedHash (prefix :: Symbol) h = PrefixedHash h deriving newtype (Eq, Ord) deriving (Show) +instance (From h Text, KnownSymbol prefix) => From (PrefixedHash prefix h) Text where + from (PrefixedHash h) = + let prefix = Text.pack $ symbolVal (Proxy @prefix) + in prefix <> into @Text h + instance (KnownSymbol prefix, ToHttpApiData h) => ToHttpApiData (PrefixedHash prefix h) where toUrlPiece (PrefixedHash h) = let prefix = Text.pack $ symbolVal (Proxy @prefix) diff --git a/src/Share/Metrics.hs b/src/Share/Metrics.hs index 2c094f8..c43b16f 100644 --- a/src/Share/Metrics.hs +++ b/src/Share/Metrics.hs @@ -9,6 +9,7 @@ module Share.Metrics requestMetricsMiddleware, tickUserSignup, recordBackgroundImportDuration, + recordDefinitionSearchIndexDuration, ) where @@ -17,17 +18,17 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding import Data.Time qualified as Time +import Network.HTTP.Types qualified as HTTP +import Network.Wai qualified as Wai +import Network.Wai.Middleware.Prometheus qualified as Prom +import Prometheus qualified as Prom +import Prometheus.Metric.GHC qualified as Prom import Share.Env qualified as Env import Share.Postgres qualified as PG import Share.Postgres.Metrics.Queries qualified as Q import Share.Prelude import Share.Utils.Deployment qualified as Deployment import Share.Utils.Servant.PathInfo (HasPathInfo, normalizePath) -import Network.HTTP.Types qualified as HTTP -import Network.Wai qualified as Wai -import Network.Wai.Middleware.Prometheus qualified as Prom -import Prometheus qualified as Prom -import Prometheus.Metric.GHC qualified as Prom import System.Clock (Clock (..), diffTimeSpec, toNanoSecs) import System.Clock qualified as Clock import UnliftIO qualified @@ -83,7 +84,7 @@ serveMetricsMiddleware env = do } -- | Record an event to the middleware metric. -requestMetricsMiddleware :: HasPathInfo api => Proxy api -> Wai.Middleware +requestMetricsMiddleware :: (HasPathInfo api) => Proxy api -> Wai.Middleware requestMetricsMiddleware api app req handleResponse = do if recordRequest req then do @@ -269,7 +270,7 @@ numUsersWithTickets = info = Prom.Info "num_users_with_tickets" "The number of users who have interacted with tickets." -- | Adds one to the user-signup counter -tickUserSignup :: MonadIO m => m () +tickUserSignup :: (MonadIO m) => m () tickUserSignup = liftIO do Prom.withLabel userSignupsCounter (tShow Deployment.deployment, "share-api") Prom.incCounter @@ -385,6 +386,18 @@ backgroundImportDurationSeconds = "background_codebase_import_duration_seconds" "The time it took to import a pulled branch into the user's codebase." +{-# NOINLINE definitionSearchIndexDurationSeconds #-} +definitionSearchIndexDurationSeconds :: Prom.Vector Prom.Label2 Prom.Histogram +definitionSearchIndexDurationSeconds = + Prom.unsafeRegister $ + Prom.vector ("deployment", "service") $ + Prom.histogram info Prom.defaultBuckets + where + info = + Prom.Info + "definition_search_indexing_duration_seconds" + "The time it took to index a release for definition search" + timeActionIntoHistogram :: (Prom.Label l, MonadUnliftIO m) => (Prom.Vector l Prom.Histogram) -> l -> m c -> m c timeActionIntoHistogram histogram l m = do UnliftIO.bracket start end \_ -> m @@ -397,5 +410,9 @@ timeActionIntoHistogram histogram l m = do Prom.withLabel histogram l (flip Prom.observe latency) -- | Record the duration of a background import. -recordBackgroundImportDuration :: MonadUnliftIO m => m r -> m r +recordBackgroundImportDuration :: (MonadUnliftIO m) => m r -> m r recordBackgroundImportDuration = timeActionIntoHistogram backgroundImportDurationSeconds (deployment, service) + +-- | Record the duration of a background import. +recordDefinitionSearchIndexDuration :: (MonadUnliftIO m) => m r -> m r +recordDefinitionSearchIndexDuration = timeActionIntoHistogram definitionSearchIndexDurationSeconds (deployment, service) diff --git a/src/Share/Postgres.hs b/src/Share/Postgres.hs index 68b1680..9be2ed9 100644 --- a/src/Share/Postgres.hs +++ b/src/Share/Postgres.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LiberalTypeSynonyms #-} @@ -8,6 +9,7 @@ module Share.Postgres ( -- * Types Transaction, + Pipeline, T, Session, Mode (..), @@ -19,6 +21,7 @@ module Share.Postgres Interp.DecodeField, RawBytes (..), Only (..), + QueryA (..), QueryM (..), decodeField, (:.) (..), @@ -27,6 +30,7 @@ module Share.Postgres readTransaction, writeTransaction, runTransaction, + runTransactionMode, tryRunTransaction, tryRunTransactionMode, unliftTransaction, @@ -37,8 +41,10 @@ module Share.Postgres runSessionWithPool, tryRunSessionWithPool, unliftSession, - transactionUnsafeIO, defaultIsolationLevel, + pipelined, + pFor, + pFor_, -- * query Helpers rollback, @@ -59,6 +65,9 @@ module Share.Postgres Interp.toTable, Interp.Sql, singleColumnTable, + + -- * Debugging + timeTransaction, ) where @@ -66,12 +75,24 @@ import Control.Lens import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -import Data.ByteString.Char8 qualified as BSC +import Data.Functor.Compose (Compose (..)) import Data.Map qualified as Map import Data.Maybe import Data.Text qualified as Text +import Data.Time.Clock (picosecondsToDiffTime) +import Data.Time.Clock.System (getSystemTime, systemToTAITime) +import Data.Time.Clock.TAI (diffAbsoluteTime) import Data.Void +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Interpolate qualified as Interp +import Hasql.Pipeline qualified as Hasql.Pipeline +import Hasql.Pool qualified as Pool +import Hasql.Session qualified as Hasql +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Hasql import Share.App +import Share.Debug qualified as Debug import Share.Env qualified as Env import Share.Postgres.Orphans () import Share.Prelude @@ -79,16 +100,7 @@ import Share.Utils.Logging (Loggable (..)) import Share.Utils.Logging qualified as Logging import Share.Web.App import Share.Web.Errors (ErrorID (..), SomeServerError, ToServerError (..), internalServerError, respondError, someServerError) -import Hasql.Decoders qualified as Decoders -import Hasql.Encoders qualified as Encoders -import Hasql.Interpolate qualified as Interp -import Hasql.Pool qualified as Pool -import Hasql.Session qualified as Hasql -import Hasql.Session qualified as Session -import Hasql.Statement qualified as Hasql - -debug :: Bool -debug = False +import System.CPUTime (getCPUTime) data TransactionError e = Unrecoverable SomeServerError @@ -96,7 +108,7 @@ data TransactionError e -- | A transaction that may fail with an error 'e' (or throw an unrecoverable error) newtype Transaction e a = Transaction {unTransaction :: Hasql.Session (Either (TransactionError e) a)} - deriving (Functor, Applicative, Monad, MonadIO) via (ExceptT (TransactionError e) Hasql.Session) + deriving (Functor, Applicative, Monad) via (ExceptT (TransactionError e) Hasql.Session) instance MonadError e (Transaction e) where throwError = Transaction . pure . Left . Err @@ -106,6 +118,20 @@ instance MonadError e (Transaction e) where Left (Unrecoverable err) -> pure (Left (Unrecoverable err)) Right a -> pure (Right a) +-- | Applicative pipelining transaction +newtype Pipeline e a = Pipeline {unPipeline :: Hasql.Pipeline.Pipeline (Either (TransactionError e) a)} + deriving (Functor, Applicative) via (Compose Hasql.Pipeline.Pipeline (Either (TransactionError e))) + +-- | Run a pipeline in a transaction +pipelined :: Pipeline e a -> Transaction e a +pipelined p = Transaction (Hasql.pipeline (unPipeline p)) + +pFor :: (Traversable f) => f a -> (a -> Pipeline e b) -> Transaction e (f b) +pFor f p = pipelined $ for f p + +pFor_ :: (Foldable f) => f a -> (a -> Pipeline e b) -> Transaction e () +pFor_ f p = pipelined $ for_ f p + -- | A transaction that has no errors. Prefer using a fully polymorphic 'e' when possible, -- but this is very helpful when dealing with data type which include fields which are -- loaded on-demand from the DB. @@ -144,9 +170,6 @@ data IsolationLevel | Serializable deriving stock (Show, Eq) -transactionUnsafeIO :: IO a -> Transaction e a -transactionUnsafeIO io = Transaction (Right <$> liftIO io) - -- | Run a transaction in a session transaction :: forall e a. IsolationLevel -> Mode -> Transaction e a -> Session e a transaction isoLevel mode (Transaction t) = do @@ -235,6 +258,9 @@ writeTransaction t = transaction defaultIsolationLevel ReadWrite t runTransaction :: (MonadReader (Env.Env x) m, MonadIO m, HasCallStack) => Transaction Void a -> m a runTransaction t = runSession (writeTransaction t) +runTransactionMode :: (MonadReader (Env.Env x) m, MonadIO m, HasCallStack) => IsolationLevel -> Mode -> Transaction Void a -> m a +runTransactionMode isoLevel mode t = runSession (transaction isoLevel mode t) + -- | Run a transaction in the App monad, returning an Either error. -- -- Uses a Write transaction for simplicity since there's not much @@ -276,11 +302,11 @@ unliftSession s = do pure $ tryRunSessionWithPool pool s -- | Manually run an unfailing session using a connection pool. -runSessionWithPool :: HasCallStack => Pool.Pool -> Session Void a -> IO a +runSessionWithPool :: (HasCallStack) => Pool.Pool -> Session Void a -> IO a runSessionWithPool pool s = either absurd id <$> tryRunSessionWithPool pool s -- | Manually run a session using a connection pool, returning an Either error. -tryRunSessionWithPool :: HasCallStack => Pool.Pool -> Session e a -> IO (Either e a) +tryRunSessionWithPool :: (HasCallStack) => Pool.Pool -> Session e a -> IO (Either e a) tryRunSessionWithPool pool s = do liftIO (Pool.use pool (runExceptT s)) >>= \case Left err -> throwIO . someServerError $ PostgresError err @@ -292,69 +318,89 @@ tryRunSessionWithPool pool s = do runSessionOrRespondError :: (HasCallStack, ToServerError e, Loggable e) => Session e a -> WebApp a runSessionOrRespondError t = tryRunSession t >>= either respondError pure --- | Represents any monad in which we can run a statement -class Monad m => QueryM m where +-- | Represents anywhere we can run a statement +class (Applicative m) => QueryA m where statement :: q -> Hasql.Statement q r -> m r -- | Fail the transaction and whole request with an unrecoverable server error. unrecoverableError :: (HasCallStack, ToServerError e, Loggable e, Show e) => e -> m a -instance QueryM (Transaction e) where - statement q s@(Hasql.Statement bs _ _ _) = do - when debug $ transactionUnsafeIO $ BSC.putStrLn bs +class (Monad m, QueryA m) => QueryM m where + -- | Allow running IO actions in a transaction. These actions may be run multiple times if + -- the transaction is retried. + transactionUnsafeIO :: IO a -> m a + +instance QueryA (Transaction e) where + statement q s = do transactionStatement q s unrecoverableError e = Transaction (pure (Left (Unrecoverable (someServerError e)))) -instance QueryM (Session e) where - statement q s@(Hasql.Statement bs _ _ _) = do - when debug $ liftIO $ BSC.putStrLn bs +instance QueryM (Transaction e) where + transactionUnsafeIO io = Transaction (Right <$> liftIO io) + +instance QueryA (Session e) where + statement q s = do lift $ Session.statement q s unrecoverableError e = throwError (Unrecoverable (someServerError e)) -instance QueryM m => QueryM (ReaderT e m) where +instance QueryM (Session e) where + transactionUnsafeIO io = lift $ liftIO io + +instance QueryA (Pipeline e) where + statement q s = Pipeline (Right <$> Hasql.Pipeline.statement q s) + + unrecoverableError e = Pipeline $ pure (Left (Unrecoverable (someServerError e))) + +instance (QueryM m) => QueryA (ReaderT e m) where statement q s = lift $ statement q s unrecoverableError e = lift $ unrecoverableError e -instance QueryM m => QueryM (MaybeT m) where +instance (QueryM m) => QueryM (ReaderT e m) where + transactionUnsafeIO io = lift $ transactionUnsafeIO io + +instance (QueryM m) => QueryA (MaybeT m) where statement q s = lift $ statement q s unrecoverableError e = lift $ unrecoverableError e +instance (QueryM m) => QueryM (MaybeT m) where + transactionUnsafeIO io = lift $ transactionUnsafeIO io + prepareStatements :: Bool prepareStatements = True queryListRows :: forall r m. (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m [r] queryListRows sql = statement () (Interp.interp prepareStatements sql) -query1Row :: forall r m. QueryM m => (Interp.DecodeRow r) => Interp.Sql -> m (Maybe r) +query1Row :: forall r m. (QueryM m) => (Interp.DecodeRow r) => Interp.Sql -> m (Maybe r) query1Row sql = listToMaybe <$> queryListRows sql query1Col :: forall a m. (QueryM m, Interp.DecodeField a) => Interp.Sql -> m (Maybe a) query1Col sql = listToMaybe <$> queryListCol sql -queryListCol :: forall a m. QueryM m => (Interp.DecodeField a) => Interp.Sql -> m [a] +queryListCol :: forall a m. (QueryM m) => (Interp.DecodeField a) => Interp.Sql -> m [a] queryListCol sql = queryListRows @(Interp.OneColumn a) sql <&> coerce @[Interp.OneColumn a] @[a] -execute_ :: QueryM m => Interp.Sql -> m () +execute_ :: (QueryA m) => Interp.Sql -> m () execute_ sql = statement () (Interp.interp prepareStatements sql) -queryExpect1Row :: forall r m. HasCallStack => (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m r +queryExpect1Row :: forall r m. (HasCallStack) => (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m r queryExpect1Row sql = query1Row sql >>= \case Nothing -> error "queryExpect1Row: expected 1 row, got 0" Just r -> pure r -queryExpect1Col :: forall a m. HasCallStack => (Interp.DecodeField a, QueryM m) => Interp.Sql -> m a +queryExpect1Col :: forall a m. (HasCallStack) => (Interp.DecodeField a, QueryM m) => Interp.Sql -> m a queryExpect1Col sql = query1Col sql >>= \case Nothing -> error "queryExpect1Col: expected 1 row, got 0" Just r -> pure r -- | Decode a single field as part of a Row -decodeField :: Interp.DecodeField a => Decoders.Row a +decodeField :: (Interp.DecodeField a) => Decoders.Row a decodeField = Decoders.column Interp.decodeField -- | Helper for decoding a row which contains many types which each have their own DecodeRow @@ -378,7 +424,7 @@ newtype Only a = Only {fromOnly :: a} deriving stock (Generic) deriving anyclass (Interp.EncodeRow) -instance Interp.DecodeField a => Interp.DecodeRow (Only a) where +instance (Interp.DecodeField a) => Interp.DecodeRow (Only a) where decodeRow = Only <$> decodeField likeEscape :: Text -> Text @@ -388,7 +434,7 @@ likeEscape = Text.replace "%" "\\%" . Text.replace "_" "\\_" -- -- The @EncodeRow (Only a)@ instance might seem strange, but without it we get overlapping -- instances on @EncodeValue a@. -singleColumnTable :: forall a. Interp.EncodeRow (Only a) => [a] -> Interp.Sql +singleColumnTable :: forall a. (Interp.EncodeRow (Only a)) => [a] -> Interp.Sql singleColumnTable cols = Interp.toTable (coerce @[a] @[Only a] cols) -- | Helper for looking things up, using a cache for keys we've already seen (within the same @@ -450,3 +496,19 @@ instance Interp.DecodeValue RawBytes where -- @@ whenNonEmpty :: forall m f a x. (Monad m, Foldable f, Monoid a) => f x -> m a -> m a whenNonEmpty f m = if null f then pure mempty else m + +timeTransaction :: (QueryM m) => String -> m a -> m a +timeTransaction label ma = + if Debug.shouldDebug Debug.Timing + then do + transactionUnsafeIO $ putStrLn $ "Timing Transaction: " ++ label ++ "..." + systemStart <- transactionUnsafeIO getSystemTime + cpuPicoStart <- transactionUnsafeIO getCPUTime + !a <- ma + cpuPicoEnd <- transactionUnsafeIO getCPUTime + systemEnd <- transactionUnsafeIO getSystemTime + let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) + let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart) + transactionUnsafeIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" + pure a + else ma diff --git a/src/Share/Postgres/Cursors.hs b/src/Share/Postgres/Cursors.hs new file mode 100644 index 0000000..e96d8ac --- /dev/null +++ b/src/Share/Postgres/Cursors.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GADTs #-} + +-- | Helpers for streamable cursors +module Share.Postgres.Cursors + ( newRowCursor, + newColCursor, + fetchN, + foldBatched, + PGCursor, + ) +where + +import Data.Char qualified as Char +import Data.List.NonEmpty qualified as NEL +import Data.String (IsString (fromString)) +import Data.Text qualified as Text +import Data.UUID (UUID) +import Share.Postgres +import Share.Prelude +import System.Random (randomIO) + +-- | A cursor that can be used to fetch rows from the database. +-- Includes a mapper (CoYoneda) to allow the type to be a functor. +data PGCursor result where + PGCursor :: + forall row result. + (DecodeRow row {- decoder for original row -}) => + Text {- cursor name -} -> + (row -> result {- mapper for Functor instance -}) -> + PGCursor result + +instance Functor PGCursor where + fmap f (PGCursor name g) = PGCursor name (f . g) + +newColCursor :: forall a m. (QueryM m, DecodeField a) => Text -> Sql -> m (PGCursor a) +newColCursor namePrefix query = do + newRowCursor namePrefix query + <&> fmap fromOnly + +-- | Create a new cursor. The name is only for debugging purposes since it will be munged with +-- a random UUID. +-- +-- This cursor will be closed when the transaction ends, and must not be used outside of the +-- transaction in which it was created. +newRowCursor :: forall r m. (QueryM m) => (DecodeRow r) => Text -> Sql -> m (PGCursor r) +newRowCursor namePrefix query = + do + uuid <- transactionUnsafeIO $ randomIO @UUID + -- We can't use a parameter for cursor names, so we make sure to clean it to prevent any + -- possible sql errors/injections. + let cursorName = Text.filter (\c -> Char.isAlphaNum c || c == '_') (namePrefix <> "_" <> into @Text uuid) + let declaration = fromString $ "DECLARE " <> Text.unpack cursorName <> "\n" + execute_ $ + declaration + <> [sql| + NO SCROLL + CURSOR + WITHOUT HOLD + FOR ^{query} + |] + pure $ PGCursor cursorName id + +-- | Fetch UP TO the next N results from the cursor. If there are no more rows, returns Nothing. +fetchN :: forall r m. (QueryM m) => PGCursor r -> Int32 -> m (Maybe (NonEmpty r)) +fetchN (PGCursor cursorName f) n = do + -- PG doesn't allow bind params for limits or cursor names. + -- We're safe from injection here because `n` is just an int, and we guarantee the + -- cursorName is safe at construction time. + let sql = fromString . Text.unpack $ Text.intercalate " " ["FETCH FORWARD", tShow n, "FROM", cursorName] + rows <- queryListRows sql + pure $ NEL.nonEmpty (f <$> rows) + +-- | Fold over the cursor in batches of N rows. +-- N.B. Fold is strict in the accumulator. +foldBatched :: forall r m a. (QueryM m, Monoid a) => PGCursor r -> Int32 -> (NonEmpty r -> m a) -> m a +foldBatched cursor batchSize f = do + batch <- fetchN cursor batchSize + case batch of + Nothing -> pure mempty + Just rows -> do + acc <- f rows + (acc <>) <$!> foldBatched cursor batchSize f diff --git a/src/Share/Postgres/NameLookups/Ops.hs b/src/Share/Postgres/NameLookups/Ops.hs index 859752c..1c4ba66 100644 --- a/src/Share/Postgres/NameLookups/Ops.hs +++ b/src/Share/Postgres/NameLookups/Ops.hs @@ -9,6 +9,8 @@ module Share.Postgres.NameLookups.Ops checkBranchHashNameLookupExists, deleteNameLookupsExceptFor, ensureNameLookupForBranchId, + Q.termsWithinNamespace, + Q.typesWithinNamespace, ) where diff --git a/src/Share/Postgres/NameLookups/Queries.hs b/src/Share/Postgres/NameLookups/Queries.hs index 543a6f2..685d05b 100644 --- a/src/Share/Postgres/NameLookups/Queries.hs +++ b/src/Share/Postgres/NameLookups/Queries.hs @@ -11,6 +11,10 @@ module Share.Postgres.NameLookups.Queries fuzzySearchTypes, FuzzySearchScore, + -- * Cursors + termsWithinNamespace, + typesWithinNamespace, + -- * Name lookup management listNameLookupMounts, checkBranchHashNameLookupExists, @@ -22,17 +26,22 @@ import Control.Lens hiding (from) import Data.Foldable qualified as Foldable import Data.List.NonEmpty qualified as NEL import Data.Text qualified as Text +import Share.Postgres import Share.Postgres qualified as PG +import Share.Postgres.Cursors (PGCursor) +import Share.Postgres.Cursors qualified as Cursors import Share.Postgres.IDs import Share.Postgres.NameLookups.Types import Share.Postgres.Refs.Types (PGReference, PGReferent, referenceFields, referentFields) import Share.Prelude -import U.Codebase.Referent (ConstructorType) +import U.Codebase.Reference (Reference) +import U.Codebase.Referent (ConstructorType, Referent) +import Unison.Name (Name) import Unison.Util.Monoid qualified as Monoid -- | Get the list of term names and suffixifications for a given Referent within a given namespace. -- Considers one level of dependencies, but not transitive dependencies. -termNamesForRefWithinNamespace :: PG.QueryM m => NameLookupReceipt -> BranchHashId -> PathSegments -> PGReferent -> Maybe ReversedName -> m [(ReversedName, ReversedName)] +termNamesForRefWithinNamespace :: (PG.QueryM m) => NameLookupReceipt -> BranchHashId -> PathSegments -> PGReferent -> Maybe ReversedName -> m [(ReversedName, ReversedName)] termNamesForRefWithinNamespace !_nameLookupReceipt bhId namespaceRoot ref maySuffix = do let namespacePrefix = toNamespacePrefix namespaceRoot let reversedNamePrefix = case maySuffix of @@ -114,7 +123,7 @@ termNamesForRefWithinNamespace !_nameLookupReceipt bhId namespaceRoot ref maySuf -- | Get the list of type names for a given Reference within a given namespace. -- Considers one level of dependencies, but not transitive dependencies. -typeNamesForRefWithinNamespace :: PG.QueryM m => NameLookupReceipt -> BranchHashId -> PathSegments -> PGReference -> Maybe ReversedName -> m [(ReversedName, ReversedName)] +typeNamesForRefWithinNamespace :: (PG.QueryM m) => NameLookupReceipt -> BranchHashId -> PathSegments -> PGReference -> Maybe ReversedName -> m [(ReversedName, ReversedName)] typeNamesForRefWithinNamespace !_nameLookupReceipt bhId namespaceRoot ref maySuffix = do let namespacePrefix = toNamespacePrefix namespaceRoot let reversedNamePrefix = case maySuffix of @@ -215,7 +224,7 @@ transitiveDependenciesSql rootBranchHashId = -- id. It's the caller's job to select the correct name lookup for your exact name. -- -- See termRefsForExactName in U.Codebase.Sqlite.Operations -termRefsForExactName :: PG.QueryM m => NameLookupReceipt -> BranchHashId -> ReversedName -> m [NamedRef (PGReferent, Maybe ConstructorType)] +termRefsForExactName :: (PG.QueryM m) => NameLookupReceipt -> BranchHashId -> ReversedName -> m [NamedRef (PGReferent, Maybe ConstructorType)] termRefsForExactName !_nameLookupReceipt bhId reversedName = do results :: [NamedRef (PGReferent PG.:. PG.Only (Maybe ConstructorType))] <- PG.queryListRows @@ -234,7 +243,7 @@ termRefsForExactName !_nameLookupReceipt bhId reversedName = do -- id. It's the caller's job to select the correct name lookup for your exact name. -- -- See termRefsForExactName in U.Codebase.Sqlite.Operations -typeRefsForExactName :: PG.QueryM m => NameLookupReceipt -> BranchHashId -> ReversedName -> m [NamedRef PGReference] +typeRefsForExactName :: (PG.QueryM m) => NameLookupReceipt -> BranchHashId -> ReversedName -> m [NamedRef PGReference] typeRefsForExactName !_nameLookupReceipt bhId reversedName = do PG.queryListRows [PG.sql| @@ -245,7 +254,7 @@ typeRefsForExactName !_nameLookupReceipt bhId reversedName = do |] -- | Check if we've already got an index for the desired root branch hash. -checkBranchHashNameLookupExists :: PG.QueryM m => BranchHashId -> m Bool +checkBranchHashNameLookupExists :: (PG.QueryM m) => BranchHashId -> m Bool checkBranchHashNameLookupExists hashId = do PG.queryExpect1Col [PG.sql| @@ -279,7 +288,7 @@ deleteNameLookupsExceptFor hashIds = do |] -- | Fetch the name lookup mounts for a given name lookup index. -listNameLookupMounts :: PG.QueryM m => NameLookupReceipt -> BranchHashId -> m [(PathSegments, BranchHashId)] +listNameLookupMounts :: (PG.QueryM m) => NameLookupReceipt -> BranchHashId -> m [(PathSegments, BranchHashId)] listNameLookupMounts !_nameLookupReceipt rootBranchHashId = do PG.queryListRows @@ -299,7 +308,7 @@ type FuzzySearchScore = (Bool, Bool, Int64, Int64) -- | Searches for all names within the given name lookup which contain the provided list of segments -- in order. -- Search is case insensitive. -fuzzySearchTerms :: PG.QueryM m => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> m [(FuzzySearchScore, NamedRef (PGReferent, Maybe ConstructorType))] +fuzzySearchTerms :: (PG.QueryM m) => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> m [(FuzzySearchScore, NamedRef (PGReferent, Maybe ConstructorType))] fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace querySegments = do fmap unRow <$> PG.queryListRows @@ -359,7 +368,7 @@ fuzzySearchTerms !_nameLookupReceipt includeDependencies bhId limit namespace qu -- in order. -- -- Search is case insensitive. -fuzzySearchTypes :: PG.QueryM m => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> m [(FuzzySearchScore, NamedRef PGReference)] +fuzzySearchTypes :: (PG.QueryM m) => NameLookupReceipt -> Bool -> BranchHashId -> Int64 -> PathSegments -> NonEmpty Text -> m [(FuzzySearchScore, NamedRef PGReference)] fuzzySearchTypes !_nameLookupReceipt includeDependencies bhId limit namespace querySegments = do fmap unRow <$> PG.queryListRows @@ -453,3 +462,27 @@ toNamespacePrefix = \case -- "foo.bar." toReversedNamePrefix :: ReversedName -> Text toReversedNamePrefix suffix = Text.intercalate "." (into @[Text] suffix) <> "." + +termsWithinNamespace :: NameLookupReceipt -> BranchHashId -> Transaction e (PGCursor (Name, Referent)) +termsWithinNamespace !_nlReceipt bhId = do + Cursors.newRowCursor @(NamedRef Referent) + "termsForSearchSyncCursor" + [sql| + SELECT reversed_name, referent_builtin, referent_component_hash.base32, referent_component_index, referent_constructor_index + FROM scoped_term_name_lookup + JOIN component_hashes referent_component_hash ON referent_component_hash.id = referent_component_hash_id + WHERE root_branch_hash_id = #{bhId} + |] + <&> fmap (\NamedRef {reversedSegments, ref} -> (reversedNameToName reversedSegments, ref)) + +typesWithinNamespace :: NameLookupReceipt -> BranchHashId -> Transaction e (PGCursor (Name, Reference)) +typesWithinNamespace !_nlReceipt bhId = do + Cursors.newRowCursor @(NamedRef Reference) + "typesForSearchSyncCursor" + [sql| + SELECT reversed_name, reference_builtin, reference_component_hash.base32, reference_component_index + FROM scoped_type_name_lookup + JOIN component_hashes reference_component_hash ON reference_component_hash.id = reference_component_hash_id + WHERE root_branch_hash_id = #{bhId} + |] + <&> fmap (\NamedRef {reversedSegments, ref} -> (reversedNameToName reversedSegments, ref)) diff --git a/src/Share/Postgres/Ops.hs b/src/Share/Postgres/Ops.hs index 4d4209d..5f6b796 100644 --- a/src/Share/Postgres/Ops.hs +++ b/src/Share/Postgres/Ops.hs @@ -45,9 +45,6 @@ projectIdByUserHandleAndSlug :: UserHandle -> ProjectSlug -> WebApp ProjectId projectIdByUserHandleAndSlug userHandle projectSlug = do PG.runTransaction (Q.projectIDFromHandleAndSlug userHandle projectSlug) `or404` (EntityMissing (ErrorID "no-project-for-handle-and-slug") $ "Project not found: " <> IDs.toText userHandle <> "/" <> IDs.toText projectSlug) -expectProjectById :: ProjectId -> WebApp Project -expectProjectById projectId = PG.runTransaction (Q.projectById projectId) `or404` (EntityMissing (ErrorID "no-project-for-project-id") $ "Project not found for id: " <> IDs.toText projectId) - createProject :: UserId -> ProjectSlug -> Maybe Text -> Set ProjectTag -> ProjectVisibility -> WebApp ProjectId createProject ownerUserId slug summary tags visibility = do PG.runTransactionOrRespondError do diff --git a/src/Share/Postgres/Orphans.hs b/src/Share/Postgres/Orphans.hs index 7b1d226..461d415 100644 --- a/src/Share/Postgres/Orphans.hs +++ b/src/Share/Postgres/Orphans.hs @@ -32,7 +32,9 @@ import Unison.Hash (Hash) import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 +import Unison.Name (Name) import Unison.NameSegment.Internal (NameSegment (..)) +import Unison.Syntax.Name qualified as Name -- Orphans for 'Hash' instance Hasql.EncodeValue Hash where @@ -100,6 +102,16 @@ deriving via Text instance Hasql.DecodeValue NameSegment deriving via Text instance Hasql.EncodeValue NameSegment +instance Hasql.DecodeValue Name where + decodeValue = + Hasql.decodeValue @Text + & Decoders.refine Name.parseTextEither + +instance Hasql.EncodeValue Name where + encodeValue = + Hasql.encodeValue @Text + & contramap Name.toText + instance (Hasql.DecodeValue t, Hasql.DecodeValue h, Show t, Show h) => Hasql.DecodeRow (Reference' t h) where decodeRow = do t <- decodeField @(Maybe t) @@ -203,20 +215,27 @@ instance Hasql.DecodeValue SqliteTermEdit.Typing where _ -> Nothing ) -instance ToServerError Hasql.QueryError where +instance ToServerError Hasql.SessionError where toServerError _ = (ErrorID "query-error", err500) -instance Logging.Loggable Hasql.QueryError where - toLog (Hasql.QueryError template params err) = - Logging.withSeverity Logging.Error . Logging.textLog $ - Text.unlines - [ "QueryError:", - indent (tShow err), - "TEMPLATE:", - indent (Text.decodeUtf8 template), - "PARAMS:", - indent (tShow params) - ] +instance Logging.Loggable Hasql.SessionError where + toLog = \case + (Hasql.QueryError template params err) -> + Logging.withSeverity Logging.Error . Logging.textLog $ + Text.unlines + [ "QueryError:", + indent (tShow err), + "TEMPLATE:", + indent (Text.decodeUtf8 template), + "PARAMS:", + indent (tShow params) + ] + (Hasql.PipelineError cmdErr) -> + Logging.withSeverity Logging.Error . Logging.textLog $ + Text.unlines + [ "PipelineError:", + indent (tShow cmdErr) + ] where indent :: Text -> Text indent = Text.unlines . fmap (" " <>) . Text.lines diff --git a/src/Share/Postgres/Queries.hs b/src/Share/Postgres/Queries.hs index 1f822c6..93a9400 100644 --- a/src/Share/Postgres/Queries.hs +++ b/src/Share/Postgres/Queries.hs @@ -21,6 +21,7 @@ import Share.Github import Share.IDs import Share.IDs qualified as IDs import Share.OAuth.Types +import Share.Postgres (unrecoverableError) import Share.Postgres qualified as PG import Share.Postgres.IDs import Share.Postgres.LooseCode.Queries qualified as LCQ @@ -33,13 +34,20 @@ import Share.Ticket qualified as Ticket import Share.User import Share.Utils.API import Share.Web.Authorization qualified as AuthZ +import Share.Web.Errors (EntityMissing (EntityMissing), ErrorID (..)) import Share.Web.Share.Branches.Types (BranchKindFilter (..)) import Share.Web.Share.Projects.Types (ContributionStats (..), DownloadStats (..), FavData, ProjectOwner, TicketStats (..)) import Share.Web.Share.Releases.Types (ReleaseStatusFilter (..), StatusUpdate (..)) import Unison.Util.List qualified as Utils import Unison.Util.Monoid (intercalateMap) -userByUserId :: PG.QueryM m => UserId -> m (Maybe User) +expectUserByUserId :: (PG.QueryM m) => UserId -> m User +expectUserByUserId uid = do + userByUserId uid >>= \case + Just user -> pure user + Nothing -> unrecoverableError $ EntityMissing (ErrorID "user:missing") ("User with id " <> IDs.toText uid <> " not found") + +userByUserId :: (PG.QueryM m) => UserId -> m (Maybe User) userByUserId uid = do PG.query1Row [PG.sql| @@ -87,6 +95,11 @@ projectById projectId = do WHERE p.id = #{projectId} |] +expectProjectById :: ProjectId -> PG.Transaction e Project +expectProjectById projectId = do + mayResult <- projectById projectId + whenNothing mayResult $ unrecoverableError $ EntityMissing (ErrorID "project:missing") ("Project with id " <> IDs.toText projectId <> " not found") + -- | returns (project, favData, projectOwner, default branch, latest release version) projectByIdWithMetadata :: Maybe UserId -> ProjectId -> PG.Transaction e (Maybe (Project, FavData, ProjectOwner, Maybe BranchName, Maybe ReleaseVersion)) projectByIdWithMetadata caller projectId = do @@ -490,7 +503,7 @@ updateProject projectId newSummary tagChanges newVisibility = -- This method is a bit naive, we just get the old project, update the fields accordingly, -- then save the entire project again. isJust <$> runMaybeT do - Project {..} <- MaybeT $ projectById projectId + Project {..} <- lift $ expectProjectById projectId let updatedSummary = fromNullableUpdate summary newSummary let updatedTags = Set.toList $ applySetUpdate tags tagChanges let updatedVisibility = fromMaybe visibility newVisibility @@ -698,7 +711,7 @@ createBranch !_nlReceipt projectId branchName contributorId causalId mergeTarget |] createRelease :: - PG.QueryM m => + (PG.QueryM m) => NameLookupReceipt -> ProjectId -> ReleaseVersion -> @@ -1085,6 +1098,11 @@ releaseById releaseId = do WHERE release.id = #{releaseId} |] +expectReleaseById :: ReleaseId -> PG.Transaction e (Release CausalId UserId) +expectReleaseById releaseId = do + mayRow <- releaseById releaseId + whenNothing mayRow $ unrecoverableError $ EntityMissing (ErrorID "release:missing") ("Release with id " <> IDs.toText releaseId <> " not found") + releaseByProjectReleaseShortHand :: ProjectReleaseShortHand -> PG.Transaction e (Maybe (Release CausalId UserId)) releaseByProjectReleaseShortHand ProjectReleaseShortHand {userHandle, projectSlug, releaseVersion = ReleaseVersion {major, minor, patch}} = do PG.query1Row @@ -1252,7 +1270,7 @@ data UpdateReleaseResult updateRelease :: UserId -> ReleaseId -> Maybe StatusUpdate -> PG.Transaction e UpdateReleaseResult updateRelease caller releaseId newStatus = do fromMaybe UpdateRelease'NotFound <$> runMaybeT do - Release {..} <- MaybeT $ releaseById releaseId + Release {..} <- lift $ expectReleaseById releaseId -- Can go from draft -> published -> deprecated -- or straight from draft -> deprecated -- but can't go from published -> draft or deprecated -> draft. diff --git a/src/Share/Postgres/Search/DefinitionSearch/Queries.hs b/src/Share/Postgres/Search/DefinitionSearch/Queries.hs new file mode 100644 index 0000000..7e9b952 --- /dev/null +++ b/src/Share/Postgres/Search/DefinitionSearch/Queries.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE TypeOperators #-} + +module Share.Postgres.Search.DefinitionSearch.Queries + ( submitReleaseToBeSynced, + claimUnsyncedRelease, + insertDefinitionDocuments, + cleanIndexForRelease, + defNameSearch, + DefnNameSearchFilter (..), + ) +where + +import Data.Aeson qualified as Aeson +import Data.Set qualified as Set +import Data.Text qualified as Text +import Hasql.Interpolate qualified as Hasql +import Share.BackgroundJobs.Search.DefinitionSync.Types +import Share.IDs (ProjectId, ReleaseId, UserId) +import Share.Postgres +import Share.Prelude +import Share.Utils.API (Limit, Query (Query)) +import Unison.DataDeclaration qualified as DD +import Unison.Name (Name) +import Unison.NameSegment (NameSegment) +import Unison.Server.Types (TermTag (..), TypeTag (..)) +import Unison.ShortHash (ShortHash) +import Unison.Syntax.Name qualified as Name +import Unison.Syntax.NameSegment qualified as NameSegment + +submitReleaseToBeSynced :: ReleaseId -> Transaction e () +submitReleaseToBeSynced releaseId = do + execute_ + [sql| + INSERT INTO global_definition_search_release_queue (id) + VALUES (#{releaseId}) + |] + +-- | Claim the oldest unsynced release to be indexed. +claimUnsyncedRelease :: Transaction e (Maybe ReleaseId) +claimUnsyncedRelease = do + query1Col + [sql| + WITH chosen_release(release_id) AS ( + SELECT q.release_id + FROM global_definition_search_release_queue q + ORDER BY q.created_at ASC + LIMIT 1 + -- Skip any that are being synced by other workers. + FOR UPDATE SKIP LOCKED + ) + DELETE FROM global_definition_search_release_queue + USING chosen_release + WHERE global_definition_search_release_queue.release_id = chosen_release.release_id + RETURNING chosen_release.release_id + |] + +-- | Save definition documents to be indexed for search. +insertDefinitionDocuments :: [DefinitionDocument ProjectId ReleaseId Name (NameSegment, ShortHash)] -> Transaction e () +insertDefinitionDocuments docs = pipelined $ do + let docsTable = docRow <$> docs + for_ docsTable \(projectId, releaseId, fqn, tokens, arity, metadata) -> do + -- Ideally we'd do a bulk insert, but Hasql doesn't provide any method for passing arrays of + -- arrays as parameters, so instead we insert each record individually so we can use our + -- only level of array-ness for the tokens. + execute_ $ + [sql| + INSERT INTO global_definition_search_docs (project_id, release_id, name, search_tokens, arity, metadata) + VALUES (#{projectId}, #{releaseId}, #{fqn}, array_to_tsvector(#{tokens}), #{arity}, #{metadata}::jsonb) + ON CONFLICT DO NOTHING + |] + where + docRow :: DefinitionDocument ProjectId ReleaseId Name (NameSegment, ShortHash) -> (ProjectId, ReleaseId, Text, [Text], Int32, Hasql.Jsonb) + docRow DefinitionDocument {project, release, fqn, tokens, arity, metadata} = + ( project, + release, + Name.toText fqn, + foldMap searchTokenToText $ Set.toList tokens, + fromIntegral arity, + Hasql.Jsonb $ Aeson.toJSON metadata + ) + +-- | Wipe out any rows for the given release, useful when re-indexing. +cleanIndexForRelease :: ReleaseId -> Transaction e () +cleanIndexForRelease releaseId = do + execute_ + [sql| + DELETE FROM global_definition_search_docs + WHERE release_id = #{releaseId} + |] + +-- | Convert a search token to a TSVector. +-- +-- >>> import Unison.Syntax.Name qualified as Name +-- >>> searchTokenToText (NameToken (Name.unsafeParseText "my.cool.name")) +-- ["n:my.cool.name"] +-- +-- >>> import Unison.ShortHash qualified as SH +-- >>> import Data.Maybe (fromJust) +-- >>> searchTokenToText (TypeMentionToken (NameSegment.unsafeParseText "Thing", fromJust $ SH.fromText "#2tWjVAuc7") (Occurrence 1)) +-- ["mn:Thing:1","mh:#2tWjVAuc7:1"] +-- +-- >>> searchTokenToText (TypeVarToken (VarId 1) (Occurrence 1)) +-- ["v:1:1"] +-- +-- >>> searchTokenToText (TermTagToken Doc) +-- ["t:doc"] +-- >>> searchTokenToText (TermTagToken (Constructor Data)) +-- WAS WAS WAS "t:data-con" +-- ["t:data-con"] +-- >>> searchTokenToText (TypeTagToken Data) +-- ["t:data"] +searchTokenToText :: DefnSearchToken (NameSegment, ShortHash) -> [Text] +searchTokenToText = \case + NameToken name -> [makeSearchToken nameType (Name.toText name) Nothing] + TypeMentionToken (ns, typeRef) occ -> + [ makeSearchToken typeMentionTypeByNameType (NameSegment.toEscapedText ns) (Just occ), + makeSearchToken typeMentionTypeByHashType (into @Text @ShortHash typeRef) (Just occ) + ] + TypeVarToken varId occ -> [makeSearchToken typeVarType (varIdText varId) (Just occ)] + HashToken sh -> [makeSearchToken hashType (into @Text sh) Nothing] + TermTagToken termTag -> [makeSearchToken tagType (termTagText termTag) Nothing] + TypeTagToken typTag -> [makeSearchToken tagType (typeTagText typTag) Nothing] + TypeModToken mod -> [makeSearchToken typeModType (typeModText mod) Nothing] + where + typeModText = \case + DD.Structural -> "structural" + DD.Unique {} -> "unique" + varIdText :: VarId -> Text + varIdText (VarId n) = tShow n + termTagText :: TermTag -> Text + termTagText = \case + Doc -> "doc" + Test -> "test" + Plain -> "plain" + Constructor typeTag -> typeTagText typeTag <> "-con" + typeTagText :: TypeTag -> Text + typeTagText = \case + Data -> "data" + Ability -> "ability" + nameType :: Text + nameType = "n" + typeMentionTypeByNameType :: Text + typeMentionTypeByNameType = "mn" + typeMentionTypeByHashType :: Text + typeMentionTypeByHashType = "mh" + typeVarType :: Text + typeVarType = "v" + hashType :: Text + hashType = "h" + tagType :: Text + tagType = "t" + typeModType :: Text + typeModType = "mod" + makeSearchToken :: Text -> Text -> Maybe (Maybe Occurrence) -> Text + makeSearchToken kind txt occ = do + Text.intercalate ":" $ + [kind, Text.replace ":" "" txt] + <> case occ of + Just (Just (Occurrence n)) -> [tShow n] + Just Nothing -> ["r"] + Nothing -> [] + +data DefnNameSearchFilter + = ProjectFilter ProjectId + | ReleaseFilter ReleaseId + | UserFilter UserId + +defNameSearch :: Maybe UserId -> Maybe DefnNameSearchFilter -> Query -> Limit -> Transaction e [(ProjectId, ReleaseId, Name)] +defNameSearch mayCaller mayFilter (Query query) limit = do + let filters = case mayFilter of + Just (ProjectFilter projId) -> [sql| AND project_id = #{projId} |] + Just (ReleaseFilter relId) -> [sql| AND release_id = #{relId} |] + Just (UserFilter userId) -> [sql| AND p.owner_id = #{userId} |] + Nothing -> mempty + queryListRows @(ProjectId, ReleaseId, Name) + [sql| + WITH matches_deduped_by_project(project_id, release_id, name) AS ( + SELECT DISTINCT ON (project_id, name) project_id, release_id, name FROM global_definition_search_docs doc + JOIN projects p ON p.id = doc.project_id + JOIN releases r ON r.id = doc.release_id + WHERE + -- Search name by a trigram 'word similarity' + -- which will match if the query is similar to any 'word' (e.g. name segment) + -- in the name. + #{query} <% name + AND (NOT p.private OR (#{mayCaller} IS NOT NULL AND EXISTS (SELECT FROM accessible_private_projects WHERE user_id = #{mayCaller} AND project_id = p.id))) + ^{filters} + ORDER BY project_id, name, release.major_version, release.minor_version, release.patch_version + ), + -- Find the best matches + best_results(project_id, release_id, name) AS ( + SELECT project_id, release_id, name + FROM matches_deduped_by_project + ORDER BY similarity(#{query}, name) DESC + LIMIT #{limit} + ) + -- THEN sort docs to the bottom. + SELECT project_id, release_id, name + FROM best_results + -- docs and tests to the bottom, but otherwise sort by quality of the match. + ORDER BY (tag = 'doc', tag = 'test', similarity(#{query}, name)) DESC + |] diff --git a/src/Share/Prelude/Orphans.hs b/src/Share/Prelude/Orphans.hs index 397713b..6a4925e 100644 --- a/src/Share/Prelude/Orphans.hs +++ b/src/Share/Prelude/Orphans.hs @@ -7,10 +7,16 @@ module Share.Prelude.Orphans () where import Control.Comonad.Cofree (Cofree (..)) import Data.Align (Semialign (..)) +import Data.Text (Text) import Data.These (These (..)) +import Data.UUID (UUID) +import Data.UUID qualified as UUID import GHC.TypeLits qualified as TypeError import Hasql.Interpolate qualified as Interp import Unison.Server.Orphans () +import Unison.ShortHash (ShortHash) +import Unison.ShortHash qualified as SH +import Witch instance {-# OVERLAPPING #-} TypeError.TypeError ('TypeError.Text "A String will be encoded as char[], Did you mean to use Text instead?") => Interp.EncodeValue String where encodeValue = error "unpossible" @@ -29,3 +35,9 @@ instance Semialign f => Semialign (Cofree f) where This x -> This <$> x That y -> That <$> y These x y -> align x y + +instance From UUID Text where + from = UUID.toText + +instance From ShortHash Text where + from = SH.toText diff --git a/src/Share/Web/App.hs b/src/Share/Web/App.hs index ee92108..da1411b 100644 --- a/src/Share/Web/App.hs +++ b/src/Share/Web/App.hs @@ -81,7 +81,7 @@ freshRequestCtx = do -- | Get the tags associated with the current request. getTags :: (MonadReader (Env RequestCtx) m, MonadIO m) => m (Map Text Text) getTags = do - RequestCtx {reqTagsVar, localTags} <- asks requestCtx + RequestCtx {reqTagsVar, localTags} <- asks ctx reqTags <- liftIO $ readTVarIO reqTagsVar -- local tags take precedence over request tags pure $ localTags <> reqTags @@ -89,7 +89,7 @@ getTags = do -- | Add a tag to the current request. This tag will be used in logging and error reports addRequestTag :: (MonadReader (Env RequestCtx) m, MonadIO m) => Text -> Text -> m () addRequestTag k v = do - RequestCtx {reqTagsVar} <- asks requestCtx + RequestCtx {reqTagsVar} <- asks ctx atomically $ modifyTVar' reqTagsVar (Map.insert k v) addServerTag :: HasServer api '[] => Proxy api -> Text -> Text -> ServerT api WebApp -> ServerT api WebApp @@ -113,11 +113,11 @@ withLocalTag k v action = do localRequestCtx (\ctx -> ctx {localTags = Map.insert k v $ localTags ctx}) action localRequestCtx :: (MonadReader (Env RequestCtx) m) => (RequestCtx -> RequestCtx) -> m a -> m a -localRequestCtx f = local \env -> env {requestCtx = f (requestCtx env)} +localRequestCtx f = local \env -> env {ctx = f (ctx env)} shouldUseCaching :: (MonadReader (Env RequestCtx) m) => m Bool shouldUseCaching = - asks (useCaching . requestCtx) + asks (useCaching . ctx) -- | Construct a full URI to a path within share, with provided query params. sharePathQ :: [Text] -> Map Text Text -> AppM reqCtx URI diff --git a/src/Share/Web/Authorization.hs b/src/Share/Web/Authorization.hs index 5331bba..4fce8ba 100644 --- a/src/Share/Web/Authorization.hs +++ b/src/Share/Web/Authorization.hs @@ -48,6 +48,7 @@ module Share.Web.Authorization readPath, writePath, adminOverride, + backgroundJobAuthZ, migrationOverride, userCreationOverride, Permission (..), @@ -71,6 +72,7 @@ import Data.Set.NonEmpty qualified as NESet import Data.Text.Encoding qualified as Text import Data.Time qualified as Time import Servant +import Share.BackgroundJobs.Monad (Background) import Share.Branch import Share.Contribution (Contribution (..), ContributionStatus (..)) import Share.IDs @@ -661,6 +663,9 @@ migrationOverride = AuthZReceipt Nothing userCreationOverride :: AuthZReceipt userCreationOverride = AuthZReceipt Nothing +backgroundJobAuthZ :: Background AuthZReceipt +backgroundJobAuthZ = pure $ AuthZReceipt Nothing + permissionGuard :: WebApp (Either AuthZFailure a) -> WebApp a permissionGuard m = m >>= \case diff --git a/src/Share/Web/Errors.hs b/src/Share/Web/Errors.hs index cf276ad..227267a 100644 --- a/src/Share/Web/Errors.hs +++ b/src/Share/Web/Errors.hs @@ -43,6 +43,9 @@ import Data.String (IsString) import Data.Text (pack) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import GHC.Stack qualified as GHC +import Servant +import Servant.Client import Share.Env qualified as Env import Share.Monitoring qualified as Monitoring import Share.OAuth.Errors (OAuth2Error (..), OAuth2ErrorCode (..), OAuth2ErrorRedirect (..)) @@ -51,9 +54,6 @@ import Share.Prelude import Share.Utils.Logging import Share.Utils.URI (URIParam (..), addQueryParam) import Share.Web.App -import GHC.Stack qualified as GHC -import Servant -import Servant.Client import Unison.Server.Backend qualified as Backend import Unison.Server.Errors qualified as Backend import Unison.Sync.Types qualified as Sync @@ -128,7 +128,7 @@ reportError :: (HasCallStack, ToServerError e, Loggable e) => e -> WebApp () reportError e = do let (ErrorID errID, serverErr) = toServerError e env <- ask - RequestCtx {pathInfo, rawURI} <- asks Env.requestCtx + RequestCtx {pathInfo, rawURI} <- asks Env.ctx reqTags <- getTags let errLog@LogMsg {msg} = withTag ("error-id", errID) $ toLog e -- We emit a separate log message for each error, but it's also diff --git a/src/Share/Web/Share/API.hs b/src/Share/Web/Share/API.hs index d0f25d1..bb770a9 100644 --- a/src/Share/Web/Share/API.hs +++ b/src/Share/Web/Share/API.hs @@ -3,6 +3,7 @@ module Share.Web.Share.API where +import Servant import Share.IDs import Share.OAuth.Session (AuthenticatedSession, AuthenticatedUserId, MaybeAuthenticatedSession) import Share.Prelude (NonEmpty) @@ -14,7 +15,6 @@ import Share.Web.Share.CodeBrowsing.API (CodeBrowseAPI) import Share.Web.Share.Contributions.API (ContributionsByUserAPI) import Share.Web.Share.Projects.API (ProjectsAPI) import Share.Web.Share.Types -import Servant type UserAPI = MaybeAuthenticatedSession @@ -51,6 +51,25 @@ type SearchEndpoint = :> QueryParam "limit" Limit :> Get '[JSON] [SearchResult] +-- | Search for names to use in a definition search. +type SearchDefinitionNamesEndpoint = + MaybeAuthenticatedSession + :> RequiredQueryParam "query" Query + :> QueryParam "limit" Limit + :> QueryParam "user-filter" UserHandle + :> QueryParam "project-filter" ProjectShortHand + :> QueryParam "release-filter" ReleaseVersion + :> Get '[JSON] [DefinitionNameSearchResult] + +-- | Submit a definition search +type SearchDefinitionsEndpoint = + MaybeAuthenticatedSession + :> RequiredQueryParam "query" Query + :> QueryParam "limit" Limit + :> QueryParam "user-filter" UserHandle + :> QueryParam "project-filter" ProjectShortHand + :> Get '[JSON] [DefinitionSearchResult] + type AccountAPI = AuthenticatedSession :> ( AccountEndpoint diff --git a/src/Share/Web/Share/Branches/Impl.hs b/src/Share/Web/Share/Branches/Impl.hs index 8a1a6cf..7fad76c 100644 --- a/src/Share/Web/Share/Branches/Impl.hs +++ b/src/Share/Web/Share/Branches/Impl.hs @@ -48,7 +48,8 @@ import Unison.NameSegment.Internal (NameSegment (..)) import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Server.Share.DefinitionSummary (TermSummary, TypeSummary, serveTermSummary, serveTypeSummary) +import Unison.Server.Share.DefinitionSummary (serveTermSummary, serveTypeSummary) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary, TypeSummary) import Unison.Server.Share.Definitions qualified as ShareBackend import Unison.Server.Share.FuzzyFind qualified as Fuzzy import Unison.Server.Share.NamespaceDetails qualified as ND @@ -65,7 +66,7 @@ getProjectBranch :: getProjectBranch projectBranchShortHand = do onNothingM missingBranch . PG.runTransaction . runMaybeT $ do branch@Branch {projectId} <- MaybeT $ Q.branchByProjectBranchShortHand projectBranchShortHand - project <- MaybeT $ Q.projectById projectId + project <- lift $ Q.expectProjectById projectId pure (project, branch) where missingBranch = respondError (EntityMissing (ErrorID "missing-project-branch") "Branch could not be found") @@ -222,7 +223,7 @@ projectBranchTypeSummaryEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHand causalId <- resolveRootHash codebase branchHead rootHash Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-branch-type-summary" cacheParams causalId $ do Codebase.runCodebaseTransaction codebase $ do - serveTypeSummary ref mayName causalId relativeTo renderWidth + serveTypeSummary ref mayName renderWidth where projectBranchShortHand = ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName} cacheParams = [IDs.toText projectBranchShortHand, toUrlPiece ref, maybe "" Name.toText mayName, tShow $ fromMaybe Path.empty relativeTo, foldMap toUrlPiece renderWidth] diff --git a/src/Share/Web/Share/CodeBrowsing/API.hs b/src/Share/Web/Share/CodeBrowsing/API.hs index cd9d064..097bd94 100644 --- a/src/Share/Web/Share/CodeBrowsing/API.hs +++ b/src/Share/Web/Share/CodeBrowsing/API.hs @@ -4,16 +4,16 @@ module Share.Web.Share.CodeBrowsing.API where import Data.Text (Text) +import Servant import Share.Utils.Caching import Share.Utils.Servant (OptionalCapture, RequiredQueryParam) -import Servant import U.Codebase.HashTags (CausalHash) import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ import Unison.Name (Name) import Unison.Reference (Reference) import Unison.Referent (Referent) -import Unison.Server.Share.DefinitionSummary (TermSummary, TypeSummary) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary, TypeSummary) import Unison.Server.Share.FuzzyFind qualified as Fuzzy import Unison.Server.Share.NamespaceListing (NamespaceListing) import Unison.Server.Types (DefinitionDisplayResults, NamespaceDetails) diff --git a/src/Share/Web/Share/Impl.hs b/src/Share/Web/Share/Impl.hs index 0648348..5d5b9cf 100644 --- a/src/Share/Web/Share/Impl.hs +++ b/src/Share/Web/Share/Impl.hs @@ -6,6 +6,7 @@ module Share.Web.Share.Impl where +import Servant import Share.Codebase qualified as Codebase import Share.Codebase.Types qualified as Codebase import Share.IDs (TourId, UserHandle) @@ -17,9 +18,11 @@ import Share.Postgres qualified as PG import Share.Postgres.IDs (CausalHash) import Share.Postgres.Ops qualified as PGO import Share.Postgres.Queries qualified as Q +import Share.Postgres.Search.DefinitionSearch.Queries qualified as DDQ import Share.Postgres.Users.Queries qualified as UsersQ import Share.Prelude import Share.Project (Project (..)) +import Share.Release (Release (..)) import Share.User (User (..)) import Share.UserProfile (UserProfile (..)) import Share.Utils.API @@ -35,14 +38,14 @@ import Share.Web.Share.CodeBrowsing.API (CodeBrowseAPI) import Share.Web.Share.Contributions.Impl qualified as Contributions import Share.Web.Share.Projects.Impl qualified as Projects import Share.Web.Share.Types -import Servant import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ import Unison.Name (Name) import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Server.Share.DefinitionSummary (TermSummary, TypeSummary, serveTermSummary, serveTypeSummary) +import Unison.Server.Share.DefinitionSummary (serveTermSummary, serveTypeSummary) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary, TypeSummary) import Unison.Server.Share.Definitions qualified as ShareBackend import Unison.Server.Share.FuzzyFind qualified as Fuzzy import Unison.Server.Share.NamespaceDetails qualified as ND @@ -213,7 +216,7 @@ typeSummaryEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle ref mayNam (rootCausalId, _rootCausalHash) <- Codebase.runCodebaseTransaction codebase Codebase.expectLooseCodeRoot Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "type-summary" cacheParams rootCausalId $ do Codebase.runCodebaseTransaction codebase $ do - serveTypeSummary ref mayName rootCausalId relativeTo renderWidth + serveTypeSummary ref mayName renderWidth where cacheParams = [toUrlPiece ref, maybe "" Name.toText mayName, tShow $ fromMaybe Path.empty relativeTo, foldMap toUrlPiece renderWidth] authPath :: Path.Path @@ -351,6 +354,37 @@ searchEndpoint (MaybeAuthedUserID callerUserId) query (fromMaybe (Limit 20) -> l in SearchResultProject projectShortHand summary visibility pure $ userResults <> projectResults +searchDefinitionNamesEndpoint :: + Maybe UserId -> + Query -> + Maybe Limit -> + Maybe UserHandle -> + Maybe IDs.ProjectShortHand -> + Maybe IDs.ReleaseVersion -> + WebApp [DefinitionNameSearchResult] +searchDefinitionNamesEndpoint callerUserId query mayLimit userFilter projectFilter releaseFilter = do + filter <- runMaybeT $ resolveProjectAndReleaseFilter <|> resolveUserFilter + matches <- PG.runTransaction $ DDQ.defNameSearch callerUserId filter query limit + -- TODO: Fix this: + let response = matches <&> \(_projId, _releaseId, name) -> DefinitionNameSearchResult (Name.toText name) "name" + pure response + where + limit = fromMaybe (Limit 20) mayLimit + resolveProjectAndReleaseFilter :: MaybeT WebApp DDQ.DefnNameSearchFilter + resolveProjectAndReleaseFilter = do + projectShortHand <- hoistMaybe projectFilter + Project {projectId} <- lift . PG.runTransactionOrRespondError $ Q.projectByShortHand projectShortHand `whenNothingM` throwError (EntityMissing (ErrorID "no-project-found") $ "No project found for short hand: " <> IDs.toText projectShortHand) + case releaseFilter of + Nothing -> pure $ DDQ.ProjectFilter projectId + Just releaseVersion -> do + Release {releaseId} <- lift . PG.runTransactionOrRespondError $ Q.releaseByProjectIdAndReleaseShortHand projectId (IDs.ReleaseShortHand releaseVersion) `whenNothingM` throwError (EntityMissing (ErrorID "no-release-found") $ "No release found for project: " <> IDs.toText projectShortHand <> " and version: " <> IDs.toText releaseVersion) + pure $ DDQ.ReleaseFilter releaseId + resolveUserFilter :: MaybeT WebApp DDQ.DefnNameSearchFilter + resolveUserFilter = do + userHandle <- hoistMaybe userFilter + User {user_id} <- lift $ PG.runTransactionOrRespondError $ Q.userByHandle userHandle `whenNothingM` throwError (EntityMissing (ErrorID "no-user-for-handle") $ "User not found for handle: " <> IDs.toText userHandle) + pure $ DDQ.UserFilter user_id + accountInfoEndpoint :: Session -> WebApp UserAccountInfo accountInfoEndpoint Session {sessionUserId} = do User {user_name, avatar_url, user_email, handle, user_id} <- PGO.expectUserById sessionUserId diff --git a/src/Share/Web/Share/Releases/Impl.hs b/src/Share/Web/Share/Releases/Impl.hs index 3eeefe7..680d7ba 100644 --- a/src/Share/Web/Share/Releases/Impl.hs +++ b/src/Share/Web/Share/Releases/Impl.hs @@ -50,7 +50,8 @@ import Unison.NameSegment.Internal (NameSegment (..)) import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Server.Share.DefinitionSummary (TermSummary, TypeSummary, serveTermSummary, serveTypeSummary) +import Unison.Server.Share.DefinitionSummary (serveTermSummary, serveTypeSummary) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary, TypeSummary) import Unison.Server.Share.Definitions qualified as ShareBackend import Unison.Server.Share.FuzzyFind qualified as Fuzzy import Unison.Server.Share.NamespaceDetails qualified as ND @@ -97,7 +98,7 @@ getProjectRelease projectReleaseShortHand = do addRequestTag "release" (IDs.toText projectReleaseShortHand) onNothingM missingRelease . PG.runTransaction . runMaybeT $ do release@Release {projectId} <- MaybeT $ Q.releaseByProjectReleaseShortHand projectReleaseShortHand - project <- MaybeT $ Q.projectById projectId + project <- lift $ Q.expectProjectById projectId pure (project, release) where missingRelease = respondError (EntityMissing (ErrorID "missing-project-release") "Release could not be found") @@ -218,7 +219,7 @@ projectReleaseTypeSummaryEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHan let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-release-type-summary" cacheParams releaseHead $ do Codebase.runCodebaseTransaction codebase $ do - serveTypeSummary ref mayName releaseHead relativeTo renderWidth + serveTypeSummary ref mayName renderWidth where projectReleaseShortHand = ProjectReleaseShortHand {userHandle, projectSlug, releaseVersion} cacheParams = [IDs.toText projectReleaseShortHand, toUrlPiece ref, maybe "" Name.toText mayName, tShow $ fromMaybe Path.empty relativeTo, foldMap toUrlPiece renderWidth] @@ -285,9 +286,7 @@ getProjectReleaseEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle proj `whenNothingM` throwError (EntityMissing (ErrorID "missing-project-release") "Release could not be found") releaseWithHandle <- forOf releaseUsers_ release \uid -> do User.handle <$> Q.userByUserId uid `whenNothingM` throwError (EntityMissing (ErrorID "missing-user") "User could not be found") - project <- - Q.projectById projectId - `whenNothingM` throwError (EntityMissing (ErrorID "missing-project") "Project could not be found") + project <- Q.expectProjectById projectId releaseWithCausalHashes <- CausalQ.expectCausalHashesByIdsOf releaseCausals_ releaseWithHandle pure (project, releaseWithCausalHashes) _authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkReleaseGet callerUserId project release diff --git a/src/Share/Web/Share/Types.hs b/src/Share/Web/Share/Types.hs index 48f1c07..e673b7e 100644 --- a/src/Share/Web/Share/Types.hs +++ b/src/Share/Web/Share/Types.hs @@ -6,12 +6,14 @@ module Share.Web.Share.Types where import Data.Aeson (KeyValue ((.=)), ToJSON (..)) import Data.Aeson qualified as Aeson +import Network.URI (URI) +import Share.BackgroundJobs.Search.DefinitionSync.Types qualified as DefSync import Share.IDs import Share.Prelude import Share.Project (ProjectVisibility) import Share.Utils.API (NullableUpdate, parseNullableUpdate) import Share.Utils.URI -import Network.URI (URI) +import Unison.Name (Name) import Unison.Server.Doc (Doc) data UpdateUserRequest = UpdateUserRequest @@ -151,3 +153,17 @@ instance ToJSON UserDisplayInfo where "avatarUrl" Aeson..= avatarUrl, "userId" Aeson..= userId ] + +data DefinitionNameSearchResult + = DefinitionNameSearchResult + { token :: Text, + kind :: Text + } + +data DefinitionSearchResult + = DefinitionSearchResult + { fqn :: Name, + summary :: DefSync.TermOrTypeSummary, + project :: ProjectShortHand, + release :: ReleaseShortHand + } diff --git a/src/Unison/Server/Share/DefinitionSummary.hs b/src/Unison/Server/Share/DefinitionSummary.hs index b826684..c7f2360 100644 --- a/src/Unison/Server/Share/DefinitionSummary.hs +++ b/src/Unison/Server/Share/DefinitionSummary.hs @@ -9,97 +9,43 @@ {-# LANGUAGE TypeOperators #-} module Unison.Server.Share.DefinitionSummary - ( TermSummaryAPI, - serveTermSummary, - TermSummary (..), - TypeSummaryAPI, + ( serveTermSummary, + termSummaryForReferent, serveTypeSummary, - TypeSummary (..), + typeSummaryForReference, ) where -import Data.Aeson -import Servant (Capture, QueryParam, (:>)) -import Servant.Server (err500) import Share.Backend qualified as Backend import Share.Codebase qualified as Codebase import Share.Codebase.Types (CodebaseM) -import Share.Postgres (QueryM (unrecoverableError)) +import Share.Postgres (unrecoverableError) import Share.Postgres.Hashes.Queries qualified as HashQ -import Share.Postgres.IDs (CausalId) +import Share.Postgres.IDs (BranchHashId, CausalId) import Share.Postgres.NameLookups.Ops qualified as NLOps import Share.Postgres.NameLookups.Types qualified as NameLookups -import Share.Utils.Logging qualified as Logging -import Share.Web.Errors (ToServerError (..)) +import U.Codebase.Referent qualified as V2Referent import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash) -import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv +import Unison.Codebase.SqliteCodebase.Conversions qualified as CV import Unison.HashQualified qualified as HQ import Unison.Name (Name) import Unison.NameSegment.Internal qualified as NameSegment +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) -import Unison.Referent qualified as Referent -import Unison.Server.Syntax (SyntaxText) +import Unison.Server.Backend (BackendError (..)) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary (..), TypeSummary (..)) import Unison.Server.Types - ( APIGet, - TermTag (..), - TypeTag, - mayDefaultWidth, + ( mayDefaultWidth, ) -import Unison.ShortHash qualified as SH +import Unison.Symbol (Symbol) import Unison.Type qualified as Type import Unison.Util.Pretty (Width) -data SummaryError = MissingSignatureForTerm Reference - deriving (Show) - -instance ToServerError SummaryError where - toServerError = \case - MissingSignatureForTerm _reference -> - ("missing-term-signature", err500) - -instance Logging.Loggable SummaryError where - toLog = \case - e@(MissingSignatureForTerm {}) -> - Logging.withSeverity Logging.Error . Logging.showLog $ e - -type TermSummaryAPI = - "definitions" - :> "terms" - :> "by-hash" - :> Capture "hash" Referent - :> "summary" - -- Optional name to include in summary. - -- It's propagated through to the response as-is. - -- If missing, the short hash will be used instead. - :> QueryParam "name" Name - :> QueryParam "rootBranch" ShortCausalHash - :> QueryParam "relativeTo" Path.Path - :> QueryParam "renderWidth" Width - :> APIGet TermSummary - -data TermSummary = TermSummary - { displayName :: HQ.HashQualified Name, - hash :: SH.ShortHash, - summary :: DisplayObject SyntaxText SyntaxText, - tag :: TermTag - } - deriving (Generic, Show) - -instance ToJSON TermSummary where - toJSON (TermSummary {..}) = - object - [ "displayName" .= displayName, - "hash" .= hash, - "summary" .= summary, - "tag" .= tag - ] - serveTermSummary :: Referent -> Maybe Name -> @@ -108,72 +54,55 @@ serveTermSummary :: Maybe Width -> CodebaseM e TermSummary serveTermSummary referent mayName rootCausalId relativeTo mayWidth = do - let shortHash = Referent.toShortHash referent + rootBranchHashId <- HashQ.expectNamespaceIdsByCausalIdsOf id rootCausalId + let v2Referent = CV.referent1to2 referent + sig <- + Codebase.loadTypeOfReferent v2Referent + `whenNothingM` unrecoverableError (MissingSignatureForTerm $ V2Referent.toReference v2Referent) + termSummaryForReferent v2Referent sig mayName rootBranchHashId relativeTo mayWidth + +termSummaryForReferent :: + V2Referent.Referent -> + Type.Type Symbol Ann -> + Maybe Name -> + BranchHashId -> + Maybe Path.Path -> + Maybe Width -> + CodebaseM e TermSummary +termSummaryForReferent referent typeSig mayName rootBranchHashId relativeTo mayWidth = do + let shortHash = V2Referent.toShortHash referent let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName let relativeToPath = fromMaybe Path.empty relativeTo - let termReference = Referent.toReference referent - let v2Referent = Cv.referent1to2 referent - rootBranchHashId <- HashQ.expectNamespaceIdsByCausalIdsOf id rootCausalId - sig <- Codebase.loadTypeOfReferent v2Referent - case sig of - Nothing -> - unrecoverableError (MissingSignatureForTerm termReference) - Just typeSig -> do - let deps = Type.labeledDependencies typeSig - namesPerspective <- NLOps.namesPerspectiveForRootAndPath rootBranchHashId (NameLookups.PathSegments . fmap NameSegment.toUnescapedText . Path.toList $ relativeToPath) - pped <- PPEPostgres.ppedForReferences namesPerspective deps - let formattedTermSig = Backend.formatSuffixedType pped width typeSig - let summary = mkSummary termReference formattedTermSig - tag <- Backend.getTermTag v2Referent typeSig - pure $ TermSummary displayName shortHash summary tag + let termReference = V2Referent.toReference referent + let deps = Type.labeledDependencies typeSig + namesPerspective <- NLOps.namesPerspectiveForRootAndPath rootBranchHashId (NameLookups.PathSegments . fmap NameSegment.toUnescapedText . Path.toList $ relativeToPath) + pped <- PPEPostgres.ppedForReferences namesPerspective deps + let formattedTypeSig = Backend.formatSuffixedType pped width typeSig + let summary = mkSummary termReference formattedTypeSig + tag <- Backend.getTermTag referent typeSig + pure $ TermSummary displayName shortHash summary tag where width = mayDefaultWidth mayWidth - mkSummary reference termSig = + mkSummary reference sig = if Reference.isBuiltin reference - then BuiltinObject termSig - else UserObject termSig - -type TypeSummaryAPI = - "definitions" - :> "types" - :> "by-hash" - :> Capture "hash" Reference - :> "summary" - -- Optional name to include in summary. - -- It's propagated through to the response as-is. - -- If missing, the short hash will be used instead. - :> QueryParam "name" Name - :> QueryParam "rootBranch" ShortCausalHash - :> QueryParam "relativeTo" Path.Path - :> QueryParam "renderWidth" Width - :> APIGet TypeSummary - -data TypeSummary = TypeSummary - { displayName :: HQ.HashQualified Name, - hash :: SH.ShortHash, - summary :: DisplayObject SyntaxText SyntaxText, - tag :: TypeTag - } - deriving (Generic, Show) - -instance ToJSON TypeSummary where - toJSON (TypeSummary {..}) = - object - [ "displayName" .= displayName, - "hash" .= hash, - "summary" .= summary, - "tag" .= tag - ] + then BuiltinObject sig + else UserObject sig serveTypeSummary :: Reference -> Maybe Name -> - CausalId -> - Maybe Path.Path -> Maybe Width -> CodebaseM e TypeSummary -serveTypeSummary reference mayName _root _relativeTo mayWidth = do +serveTypeSummary reference mayName mayWidth = do + typeSummaryForReference reference mayName mayWidth + +typeSummaryForReference :: + Reference -> + Maybe Name -> + Maybe Width -> + CodebaseM e TypeSummary +typeSummaryForReference reference mayName mayWidth = do let shortHash = Reference.toShortHash reference let displayName = maybe (HQ.HashOnly shortHash) HQ.NameOnly mayName tag <- Backend.getTypeTag reference diff --git a/src/Unison/Server/Share/DefinitionSummary/Types.hs b/src/Unison/Server/Share/DefinitionSummary/Types.hs new file mode 100644 index 0000000..dcb4c37 --- /dev/null +++ b/src/Unison/Server/Share/DefinitionSummary/Types.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +module Unison.Server.Share.DefinitionSummary.Types + ( TermSummaryAPI, + TermSummary (..), + TypeSummaryAPI, + TypeSummary (..), + ) +where + +import Data.Aeson +import Servant (Capture, QueryParam, (:>)) +import Servant.Server (err500) +import Share.Utils.Logging qualified as Logging +import Share.Web.Errors (ToServerError (..)) +import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) +import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ShortCausalHash (ShortCausalHash) +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) +import Unison.Prelude +import Unison.Reference (Reference) +import Unison.Referent (Referent) +import Unison.Server.Syntax (SyntaxText) +import Unison.Server.Types + ( APIGet, + TermTag (..), + TypeTag, + ) +import Unison.ShortHash qualified as SH +import Unison.Util.Pretty (Width) + +data SummaryError = MissingSignatureForTerm Reference + deriving (Show) + +instance ToServerError SummaryError where + toServerError = \case + MissingSignatureForTerm _reference -> + ("missing-term-signature", err500) + +instance Logging.Loggable SummaryError where + toLog = \case + e@(MissingSignatureForTerm {}) -> + Logging.withSeverity Logging.Error . Logging.showLog $ e + +type TermSummaryAPI = + "definitions" + :> "terms" + :> "by-hash" + :> Capture "hash" Referent + :> "summary" + -- Optional name to include in summary. + -- It's propagated through to the response as-is. + -- If missing, the short hash will be used instead. + :> QueryParam "name" Name + :> QueryParam "rootBranch" ShortCausalHash + :> QueryParam "relativeTo" Path.Path + :> QueryParam "renderWidth" Width + :> APIGet TermSummary + +data TermSummary = TermSummary + { displayName :: HQ.HashQualified Name, + hash :: SH.ShortHash, + summary :: DisplayObject SyntaxText SyntaxText, + tag :: TermTag + } + deriving (Generic, Show) + +instance ToJSON TermSummary where + toJSON (TermSummary {..}) = + object + [ "displayName" .= displayName, + "hash" .= hash, + "summary" .= summary, + "tag" .= tag + ] + +instance FromJSON TermSummary where + parseJSON = withObject "TermSummary" $ \o -> do + displayName <- o .: "displayName" + hash <- o .: "hash" + summary <- o .: "summary" + tag <- o .: "tag" + pure $ TermSummary {..} + +type TypeSummaryAPI = + "definitions" + :> "types" + :> "by-hash" + :> Capture "hash" Reference + :> "summary" + -- Optional name to include in summary. + -- It's propagated through to the response as-is. + -- If missing, the short hash will be used instead. + :> QueryParam "name" Name + :> QueryParam "rootBranch" ShortCausalHash + :> QueryParam "relativeTo" Path.Path + :> QueryParam "renderWidth" Width + :> APIGet TypeSummary + +data TypeSummary = TypeSummary + { displayName :: HQ.HashQualified Name, + hash :: SH.ShortHash, + summary :: DisplayObject SyntaxText SyntaxText, + tag :: TypeTag + } + deriving (Generic, Show) + +instance ToJSON TypeSummary where + toJSON (TypeSummary {..}) = + object + [ "displayName" .= displayName, + "hash" .= hash, + "summary" .= summary, + "tag" .= tag + ] + +instance FromJSON TypeSummary where + parseJSON = withObject "TypeSummary" $ \o -> do + displayName <- o .: "displayName" + hash <- o .: "hash" + summary <- o .: "summary" + tag <- o .: "tag" + pure $ TypeSummary {..} diff --git a/stack.yaml b/stack.yaml index 4a51a48..8bf136d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,10 +45,16 @@ extra-deps: - monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 - raven-haskell-0.1.4.1@sha256:0d27e37968327faba577558a2ee4465ebfd3b6929b09cf4881dfa62a6873c85a,1393 - strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 -- hasql-interpolate-0.2.2.0@sha256:e6dcd161bd7147915f5f837b2dfc6f1710d6f0ce47341944ea1925194b8ed1fd,3206 - network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 - recover-rtti-0.5.0@sha256:7d598b0c89dac9e170b488a7a50b322fcae06342fbd2da18cb8a7f93a0b44e68,4913 +# Bumping hasql up to get Pipelining mode +- hasql-1.8 +- hasql-pool-1.2.0.2 +- hasql-interpolate-1.0.1.0 +- postgresql-binary-0.14@sha256:3f3518f841cf80b107862800715bc64f43c2c71696c4129f63404c1ff61cc919,4025 +- postgresql-libpq-0.10.1.0@sha256:6a45edff0a9e30b32cda6e443107950492322622c4fbefc8fb4dcf6452dcf0b4,3203 + ghc-options: # All packages "$locals": -Wall -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info diff --git a/stack.yaml.lock b/stack.yaml.lock index 85ab95b..fbea855 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -53,13 +53,6 @@ packages: size: 212 original: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 -- completed: - hackage: hasql-interpolate-0.2.2.0@sha256:e6dcd161bd7147915f5f837b2dfc6f1710d6f0ce47341944ea1925194b8ed1fd,3206 - pantry-tree: - sha256: e826a06d038ef9e2f1fdbaec5c0e3fb1baca63dbb463498fbf1e2d7540545c67 - size: 1276 - original: - hackage: hasql-interpolate-0.2.2.0@sha256:e6dcd161bd7147915f5f837b2dfc6f1710d6f0ce47341944ea1925194b8ed1fd,3206 - completed: hackage: network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 pantry-tree: @@ -74,6 +67,41 @@ packages: size: 2489 original: hackage: recover-rtti-0.5.0@sha256:7d598b0c89dac9e170b488a7a50b322fcae06342fbd2da18cb8a7f93a0b44e68,4913 +- completed: + hackage: hasql-1.8@sha256:52b61231259a79733428a4b51f5661c0eb7934001f6a3b3b637203a4a745c951,5642 + pantry-tree: + sha256: 3aea9d8e5f3eccd419ba31336d0f2d737e0cc23b82fc0306cdc8975c281a272f + size: 3438 + original: + hackage: hasql-1.8 +- completed: + hackage: hasql-pool-1.2.0.2@sha256:621e3997d701b424a777fc6cd0218e385c89dff9417a933305d19b03820deb3f,2389 + pantry-tree: + sha256: 8dd1ee8e3a41894266708e28076a902c8d51b275af22c3f182d6bfe219ea7fa7 + size: 982 + original: + hackage: hasql-pool-1.2.0.2 +- completed: + hackage: hasql-interpolate-1.0.1.0@sha256:07980986467ed196e812a54c2762a42ceca56ca899cb4ef3cdb4f4191b07d338,3298 + pantry-tree: + sha256: f7d9f29c576c4d36cb2f44d2f9a672e08e84d79060928aa9ed005e9e30c35202 + size: 1276 + original: + hackage: hasql-interpolate-1.0.1.0 +- completed: + hackage: postgresql-binary-0.14@sha256:3f3518f841cf80b107862800715bc64f43c2c71696c4129f63404c1ff61cc919,4025 + pantry-tree: + sha256: 29cfa313f2642c8b1d3ca15afbd2911ab842ae130e65d99fb5f18e8a24df8c88 + size: 1661 + original: + hackage: postgresql-binary-0.14@sha256:3f3518f841cf80b107862800715bc64f43c2c71696c4129f63404c1ff61cc919,4025 +- completed: + hackage: postgresql-libpq-0.10.1.0@sha256:6a45edff0a9e30b32cda6e443107950492322622c4fbefc8fb4dcf6452dcf0b4,3203 + pantry-tree: + sha256: 1c0120f2cd6d15bfdf64060ebde4b037f01381a8d04d188d753b43e1c978d164 + size: 1096 + original: + hackage: postgresql-libpq-0.10.1.0@sha256:6a45edff0a9e30b32cda6e443107950492322622c4fbefc8fb4dcf6452dcf0b4,3203 snapshots: - completed: sha256: 8e7996960d864443a66eb4105338bbdd6830377b9f6f99cd5527ef73c10c01e7 diff --git a/unison b/unison index 605e062..cdab05d 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 605e062bcfc3118ee83ca35c7d86a4036adea22f +Subproject commit cdab05d25992537ea1ce699a1dbe2d4413810b41