diff --git a/.gitignore b/.gitignore index 890ba1e..58d7006 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,6 @@ docker/tmp *.prof *.prof.html prelude.output.md + +# Scratch files +*.u 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/docker/docker-compose.yml b/docker/docker-compose.yml index f92ce9b..2e73248 100644 --- a/docker/docker-compose.yml +++ b/docker/docker-compose.yml @@ -17,10 +17,10 @@ services: POSTGRES_PASSWORD: sekrit volumes: - ../sql:/docker-entrypoint-initdb.d - # # Optionally persist the data between container invocations - # - postgresVolume:/var/lib/postgresql/data + # Optionally persist the data between container invocations + - postgresVolume:/var/lib/postgresql/data - ./postgresql.conf:/etc/postgresql/postgresql.conf - command: postgres -c config_file=/etc/postgresql/postgresql.conf # -c log_statement=all + command: postgres -c config_file=/etc/postgresql/postgresql.conf # -c log_statement=all redis: @@ -85,5 +85,5 @@ services: - redis - postgres -# volumes: -# postgresVolume: +volumes: + postgresVolume: diff --git a/package.yaml b/package.yaml index 158703f..9dd4ac6 100644 --- a/package.yaml +++ b/package.yaml @@ -62,17 +62,20 @@ dependencies: - http-media - http-types - jose +- ki-unlifted - lens - megaparsec - memory - mmorph - monad-validate +- monoidal-containers - mtl - network - network-simple - network-uri - nonempty-containers - parallel +- parser-combinators - pem - hasql - hasql-pool @@ -159,6 +162,7 @@ default-extensions: - BlockArguments - QuasiQuotes - ImportQualifiedPost + - OverloadedRecordDot library: source-dirs: src diff --git a/share-api.cabal b/share-api.cabal index df1ea10..c5ebdad 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,8 @@ library Share.Postgres.Projects.Queries Share.Postgres.Queries Share.Postgres.Refs.Types + Share.Postgres.Releases.Queries + Share.Postgres.Search.DefinitionSearch.Queries Share.Postgres.Serialization Share.Postgres.Sync.Conversions Share.Postgres.Sync.Queries @@ -118,6 +127,7 @@ library Share.Web.Share.Contributions.Impl Share.Web.Share.Contributions.MergeDetection Share.Web.Share.Contributions.Types + Share.Web.Share.DefinitionSearch Share.Web.Share.Diffs.Impl Share.Web.Share.Diffs.Types Share.Web.Share.Impl @@ -144,6 +154,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 @@ -180,6 +191,7 @@ library BlockArguments QuasiQuotes ImportQualifiedPost + OverloadedRecordDot ghc-options: -Wall -Werror -Wname-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields build-depends: Diff @@ -217,17 +229,20 @@ library , http-media , http-types , jose + , ki-unlifted , lens , megaparsec , memory , mmorph , monad-validate + , monoidal-containers , mtl , network , network-simple , network-uri , nonempty-containers , parallel + , parser-combinators , pem , prometheus-client , prometheus-metrics-ghc @@ -319,6 +334,7 @@ executable share-api BlockArguments QuasiQuotes ImportQualifiedPost + OverloadedRecordDot ghc-options: -Wall -Werror -Wname-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields -threaded -rtsopts "-with-rtsopts=-N -A32m -qn2 -T" build-depends: Diff @@ -356,17 +372,20 @@ executable share-api , http-media , http-types , jose + , ki-unlifted , lens , megaparsec , memory , mmorph , monad-validate + , monoidal-containers , mtl , network , network-simple , network-uri , nonempty-containers , parallel + , parser-combinators , pem , prometheus-client , prometheus-metrics-ghc 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-18-00-00_defn_search.sql b/sql/2024-07-18-00-00_defn_search.sql new file mode 100644 index 0000000..91990d1 --- /dev/null +++ b/sql/2024-07-18-00-00_defn_search.sql @@ -0,0 +1,43 @@ +-- 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 +); + +-- Every defn fits into one of these categories. +CREATE TYPE definition_tag AS ENUM ('doc', 'test', 'plain', 'data', 'ability', 'data-constructor', 'ability-constructor'); + +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, + tag definition_tag 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, tag, 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 7678b55..d489840 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..aa8bb50 --- /dev/null +++ b/src/Share/BackgroundJobs/Search/DefinitionSync.hs @@ -0,0 +1,326 @@ +{-# 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 (Arity (..), DefinitionDocument (..), DefnSearchToken (..), Occurrence, TermOrTypeSummary (..), TermOrTypeTag (..), 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 (..)) +import Share.Release (Release (..)) +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.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} <- lift $ PG.expectProjectById projectId + 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) + let displayName = + fqn + & Name.reverseSegments + -- For now we treat the display name for search as just the last 2 segments of the name. + & \case + (ns :| rest) -> ns :| take 1 rest + & Name.fromReverseSegments + termSummary <- lift $ Summary.termSummaryForReferent ref typ (Just displayName) 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, + tag = ToTTermTag (termSummary.tag), + 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 (Name, ShortHash)] + namedDocs = + refDocs + & traversed . field @"tokens" %~ Set.mapMaybe \token -> do + for token \ref -> do + name <- PPE.types ppe ref + pure $ (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), Arity) +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), Arity) +typeSigTokens typ = + let occMap :: MonoidalMap (Either VarId TypeReference) (Occurrence, Any) + arity :: Arity + (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 Arity)) -> + TokenGenM v (MonoidalMap (Either VarId TypeReference) (Occurrence, Any {- Is return type -}), Sum Arity) + 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, Arity 0) + Reference.DerivedId refId -> do + decl <- lift (Codebase.loadTypeDeclaration refId) `whenNothingM` throwError (NoDeclForType fqn ref) + pure $ (tokensForDecl refId decl, Arity . fromIntegral . 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, + tag = ToTTypeTag (typeSummary.tag), + 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 (Name, ShortHash)] + namedDocs = + refDocs + & traversed . field @"tokens" %~ Set.mapMaybe \token -> do + for token \ref -> do + name <- PPE.types ppe ref + pure $ (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..f35fd52 --- /dev/null +++ b/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Share.BackgroundJobs.Search.DefinitionSync.Types + ( TermOrTypeSummary (..), + TermOrTypeTag (..), + DefinitionDocument (..), + DefnSearchToken (..), + Occurrence (..), + VarId (..), + Arity (..), + ) +where + +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Monoid (Sum (..)) +import Data.Text qualified as Text +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Interpolate qualified as Hasql +import Servant (FromHttpApiData) +import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) +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 + +data TermOrTypeTag = ToTTermTag TermTag | ToTTypeTag TypeTag + deriving stock (Show, Eq, Ord) + +instance FromHttpApiData TermOrTypeTag where + parseQueryParam = \case + "doc" -> Right $ ToTTermTag Doc + "test" -> Right $ ToTTermTag Test + "plain" -> Right $ ToTTermTag Plain + "data-constructor" -> Right $ ToTTermTag $ Constructor Data + "ability-constructor" -> Right $ ToTTermTag $ Constructor Ability + "data" -> Right $ ToTTypeTag Data + "ability" -> Right $ ToTTypeTag Ability + _ -> Left "Invalid TermOrTypeTag" + +instance ToHttpApiData TermOrTypeTag where + toQueryParam = \case + ToTTermTag Doc -> "doc" + ToTTermTag Test -> "test" + ToTTermTag Plain -> "plain" + ToTTermTag (Constructor Data) -> "data-constructor" + ToTTermTag (Constructor Ability) -> "ability-constructor" + ToTTypeTag Data -> "data" + ToTTypeTag Ability -> "ability" + +instance ToJSON TermOrTypeTag where + toJSON = String . toQueryParam + +instance Hasql.EncodeValue TermOrTypeTag where + encodeValue = + Encoders.enum + ( \case + ToTTermTag tt -> encodeTermTag tt + ToTTypeTag tt -> encodeTypeTag tt + ) + where + encodeTermTag = \case + Doc -> "doc" + Test -> "test" + Plain -> "plain" + Constructor Data -> "data-constructor" + Constructor Ability -> "ability-constructor" + encodeTypeTag = \case + Data -> "data" + Ability -> "ability" + +instance Hasql.DecodeValue TermOrTypeTag where + decodeValue = Decoders.enum $ \case + "doc" -> pure $ ToTTermTag Doc + "test" -> pure $ ToTTermTag Test + "plain" -> pure $ ToTTermTag Plain + "data-constructor" -> pure $ ToTTermTag $ Constructor Data + "ability-constructor" -> pure $ ToTTermTag $ Constructor Ability + "data" -> pure $ ToTTypeTag Data + "ability" -> pure $ ToTTypeTag Ability + _ -> fail "Invalid TermOrTypeTag" + +-- | 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) + +newtype Arity = Arity Int32 + deriving newtype (Show, Read, Eq, Ord, Num, ToJSON, Enum, Hasql.EncodeValue, Hasql.DecodeValue) + +-- | 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) + +makePrisms ''DefnSearchToken + +-- | 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 :: Arity, + tag :: TermOrTypeTag, + 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/Hashes/Queries.hs b/src/Share/Postgres/Hashes/Queries.hs index 52c852c..3f5b5ea 100644 --- a/src/Share/Postgres/Hashes/Queries.hs +++ b/src/Share/Postgres/Hashes/Queries.hs @@ -287,7 +287,7 @@ expectCausalIdsOf trav = do then unrecoverableError $ EntityMissing "missing-expected-causal" $ "Missing one of these causals: " <> Text.intercalate ", " (into @Text <$> hashes) else pure results -expectNamespaceIdsByCausalIdsOf :: QueryM m => Traversal s t CausalId BranchHashId -> s -> m t +expectNamespaceIdsByCausalIdsOf :: (QueryM m) => Traversal s t CausalId BranchHashId -> s -> m t expectNamespaceIdsByCausalIdsOf trav s = do s & unsafePartsOf trav %%~ \causalIds -> do @@ -334,7 +334,7 @@ loadCausalIdByHash causalHash = do AND EXISTS (SELECT FROM causal_ownership o WHERE o.causal_id = causals.id AND o.user_id = #{codebaseOwner}) |] -expectCausalIdByHash :: HasCallStack => CausalHash -> Codebase.CodebaseM e CausalId +expectCausalIdByHash :: (HasCallStack) => CausalHash -> Codebase.CodebaseM e CausalId expectCausalIdByHash causalHash = do loadCausalIdByHash causalHash `whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected causal id for hash: " <> tShow causalHash) 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/Projects/Queries.hs b/src/Share/Postgres/Projects/Queries.hs index 546a4c1..2b56178 100644 --- a/src/Share/Postgres/Projects/Queries.hs +++ b/src/Share/Postgres/Projects/Queries.hs @@ -5,30 +5,31 @@ module Share.Postgres.Projects.Queries listProjectMaintainers, addMaintainers, updateMaintainers, + expectProjectShortHandsOf, ) where import Control.Lens import Control.Monad.Except (MonadError (..), runExceptT) import Share.IDs -import Share.Postgres qualified as PG +import Share.Postgres import Share.Prelude import Share.Web.Authorization.Types (ProjectMaintainerPermissions (..)) import Share.Web.Share.Projects.Types (Maintainer (..)) -isPremiumProject :: ProjectId -> PG.Transaction e Bool +isPremiumProject :: ProjectId -> Transaction e Bool isPremiumProject projId = fromMaybe False <$> do - PG.query1Col - [PG.sql| + query1Col + [sql| SELECT EXISTS (SELECT FROM premium_projects WHERE project_id = #{projId}) |] -listProjectMaintainers :: ProjectId -> PG.Transaction e [Maintainer UserId] +listProjectMaintainers :: ProjectId -> Transaction e [Maintainer UserId] listProjectMaintainers projId = do results <- - PG.queryListRows @(UserId, Bool, Bool, Bool) - [PG.sql| + queryListRows @(UserId, Bool, Bool, Bool) + [sql| SELECT pm.user_id, pm.can_view, pm.can_maintain, pm.can_admin FROM project_maintainers pm WHERE pm.project_id = #{projId} @@ -40,16 +41,16 @@ listProjectMaintainers projId = do in Maintainer {user = userId, permissions} & pure -addMaintainers :: ProjectId -> [Maintainer UserId] -> PG.Transaction e (Either [UserId] [Maintainer UserId]) +addMaintainers :: ProjectId -> [Maintainer UserId] -> Transaction e (Either [UserId] [Maintainer UserId]) addMaintainers projId maintainers = runExceptT $ do let userIds = fmap user maintainers -- Check if any of the maintainers already exist alreadyExistingUserIds <- lift $ - PG.queryListCol @UserId - [PG.sql| + queryListCol @UserId + [sql| WITH values(user_id) AS ( - SELECT * FROM ^{PG.singleColumnTable userIds} + SELECT * FROM ^{singleColumnTable userIds} ) SELECT values.user_id FROM values WHERE EXISTS (SELECT FROM project_maintainers pm @@ -64,26 +65,26 @@ addMaintainers projId maintainers = runExceptT $ do let newMaintainersTable = maintainers <&> \Maintainer {user, permissions = ProjectMaintainerPermissions {canView, canMaintain, canAdmin}} -> (projId, user, canView, canMaintain, canAdmin) -- Insert the maintainers lift $ - PG.execute_ - [PG.sql| + execute_ + [sql| WITH values(project_id, user_id, can_view, can_maintain, can_admin) AS ( - SELECT * FROM ^{PG.toTable newMaintainersTable} + SELECT * FROM ^{toTable newMaintainersTable} ) INSERT INTO project_maintainers (project_id, user_id, can_view, can_maintain, can_admin) SELECT v.project_id, v.user_id, v.can_view, v.can_maintain, v.can_admin FROM values v |] lift $ listProjectMaintainers projId -updateMaintainers :: ProjectId -> [Maintainer UserId] -> PG.Transaction e (Either [UserId] [Maintainer UserId]) +updateMaintainers :: ProjectId -> [Maintainer UserId] -> Transaction e (Either [UserId] [Maintainer UserId]) updateMaintainers projId maintainers = runExceptT $ do let userIds = fmap user maintainers -- Check if any of the maintainers don't already exist missingUserIds <- lift $ - PG.queryListCol @UserId - [PG.sql| + queryListCol @UserId + [sql| WITH values(user_id) AS ( - SELECT * FROM ^{PG.singleColumnTable userIds} + SELECT * FROM ^{singleColumnTable userIds} ) SELECT values.user_id FROM values WHERE NOT EXISTS (SELECT FROM project_maintainers pm @@ -97,10 +98,10 @@ updateMaintainers projId maintainers = runExceptT $ do [] -> do let updatedMaintainersTable = maintainers <&> \Maintainer {user, permissions = ProjectMaintainerPermissions {canView, canMaintain, canAdmin}} -> (projId, user, canView, canMaintain, canAdmin) lift $ - PG.execute_ - [PG.sql| + execute_ + [sql| WITH values(project_id, user_id, can_view, can_maintain, can_admin) AS ( - SELECT * FROM ^{PG.toTable updatedMaintainersTable} + SELECT * FROM ^{toTable updatedMaintainersTable} ) UPDATE project_maintainers SET can_view = v.can_view, can_maintain = v.can_maintain, can_admin = v.can_admin FROM values v @@ -109,8 +110,8 @@ updateMaintainers projId maintainers = runExceptT $ do |] -- Delete any maintainers that have no permissions lift $ - PG.execute_ - [PG.sql| + execute_ + [sql| DELETE FROM project_maintainers pm WHERE pm.project_id = #{projId} AND pm.can_view = false @@ -118,3 +119,25 @@ updateMaintainers projId maintainers = runExceptT $ do AND pm.can_admin = false |] lift $ listProjectMaintainers projId + +expectProjectShortHandsOf :: Traversal s t ProjectId ProjectShortHand -> s -> Transaction e t +expectProjectShortHandsOf trav s = do + s + & unsafePartsOf trav %%~ \projIds -> do + let numberedProjIds = zip [1 :: Int32 ..] projIds + results :: [ProjectShortHand] <- + queryListRows @(UserHandle, ProjectSlug) + [sql| + WITH proj_ids(ord, id) AS ( + SELECT * FROM ^{toTable numberedProjIds} + ) + SELECT u.handle, p.slug + FROM proj_ids JOIN projects p ON proj_ids.id = p.id + JOIN users u ON p.owner_user_id = u.id + ORDER BY proj_ids.ord ASC + |] + <&> fmap \(userHandle, projectSlug) -> ProjectShortHand {userHandle, projectSlug} + + if length results /= length projIds + then error "expectProjectShortHandsOf: Missing expected project short hand" + else pure results diff --git a/src/Share/Postgres/Queries.hs b/src/Share/Postgres/Queries.hs index 18c6b71..fd53297 100644 --- a/src/Share/Postgres/Queries.hs +++ b/src/Share/Postgres/Queries.hs @@ -21,10 +21,12 @@ 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 import Share.Postgres.NameLookups.Types (NameLookupReceipt) +import Share.Postgres.Search.DefinitionSearch.Queries qualified as DDQ import Share.Prelude import Share.Project import Share.Release @@ -33,12 +35,19 @@ 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) +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 @@ -87,6 +96,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 @@ -491,7 +505,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 @@ -708,8 +722,9 @@ createRelease :: UserId -> m (Release CausalId UserId) createRelease !_nlReceipt projectId ReleaseVersion {major, minor, patch} squashedCausalId unsquashedCausalId creatorId = do - PG.queryExpect1Row - [PG.sql| + release@Release {releaseId} <- + PG.queryExpect1Row + [PG.sql| INSERT INTO project_releases( project_id, created_by, @@ -736,6 +751,8 @@ createRelease !_nlReceipt projectId ReleaseVersion {major, minor, patch} squashe minor_version, patch_version |] + DDQ.submitReleaseToBeSynced releaseId + pure release setBranchCausalHash :: NameLookupReceipt -> @@ -1086,6 +1103,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 @@ -1253,7 +1275,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/Releases/Queries.hs b/src/Share/Postgres/Releases/Queries.hs new file mode 100644 index 0000000..11df966 --- /dev/null +++ b/src/Share/Postgres/Releases/Queries.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeOperators #-} + +module Share.Postgres.Releases.Queries + ( expectReleaseVersionsOf, + ) +where + +import Control.Lens +import Share.IDs +import Share.Postgres +import Share.Prelude + +expectReleaseVersionsOf :: Traversal s t ReleaseId ReleaseVersion -> s -> Transaction e t +expectReleaseVersionsOf trav s = do + s + & unsafePartsOf trav %%~ \releaseIds -> do + let numberedReleaseIds = zip [1 :: Int32 ..] releaseIds + results :: [ReleaseVersion] <- + queryListRows @ReleaseVersion + [sql| + WITH release_ids(ord, id) AS ( + SELECT * FROM ^{toTable numberedReleaseIds} + ) + SELECT r.major_version, r.minor_version, r.patch_version + FROM release_ids JOIN project_releases r ON release_ids.id = r.id + ORDER BY release_ids.ord ASC + |] + if length results /= length releaseIds + then error "expectReleaseVersionsOf: Missing expected release version" + else pure results diff --git a/src/Share/Postgres/Search/DefinitionSearch/Queries.hs b/src/Share/Postgres/Search/DefinitionSearch/Queries.hs new file mode 100644 index 0000000..b642ad7 --- /dev/null +++ b/src/Share/Postgres/Search/DefinitionSearch/Queries.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE TypeOperators #-} + +module Share.Postgres.Search.DefinitionSearch.Queries + ( submitReleaseToBeSynced, + claimUnsyncedRelease, + insertDefinitionDocuments, + cleanIndexForRelease, + defNameSearch, + definitionSearch, + DefnNameSearchFilter (..), + ) +where + +import Control.Lens +import Data.Aeson (fromJSON) +import Data.Aeson qualified as Aeson +import Data.Foldable qualified as Foldable +import Data.Set qualified as Set +import Data.Text qualified as Text +import Hasql.Interpolate qualified as Hasql +import Servant (ServerError (..)) +import Servant.Server (err500) +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 Share.Utils.Logging qualified as Logging +import Share.Web.Errors qualified as Errors +import Unison.DataDeclaration qualified as DD +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.Server.Types (TermTag (..), TypeTag (..)) +import Unison.ShortHash (ShortHash) +import Unison.Syntax.Name qualified as Name +import Unison.Syntax.NameSegment qualified as NameSegment + +data DefinitionSearchError = FailedToDecodeMetadata Aeson.Value Text + deriving stock (Show, Eq, Ord) + +instance Errors.ToServerError DefinitionSearchError where + toServerError = \case + FailedToDecodeMetadata _v _err -> (Errors.ErrorID "invalid-definition-search-metadata", err500 {errBody = "Internal Server Error"}) + +instance Logging.Loggable DefinitionSearchError where + toLog = \case + FailedToDecodeMetadata v err -> + Logging.textLog ("Failed to decode metadata: " <> tShow v <> " " <> err) + & Logging.withSeverity Logging.Error + +submitReleaseToBeSynced :: (QueryM m) => ReleaseId -> m () +submitReleaseToBeSynced releaseId = do + execute_ + [sql| + INSERT INTO global_definition_search_release_queue (release_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 (Name, ShortHash)] -> Transaction e () +insertDefinitionDocuments docs = pipelined $ do + let docsTable = docRow <$> docs + execute_ $ + [sql| + WITH docs(project_id, release_id, name, token_text, arity, tag, metadata) AS ( + SELECT * FROM ^{toTable docsTable} + ) INSERT INTO global_definition_search_docs (project_id, release_id, name, search_tokens, arity, tag, metadata) + SELECT d.project_id, d.release_id, d.name, tsvector(d.token_text::text), d.arity, d.tag::definition_tag, d.metadata + FROM docs d + ON CONFLICT DO NOTHING + |] + where + docRow :: DefinitionDocument ProjectId ReleaseId Name (Name, ShortHash) -> (ProjectId, ReleaseId, Text, Text, Arity, TermOrTypeTag, Hasql.Jsonb) + docRow DefinitionDocument {project, release, fqn, tokens, arity, tag, metadata} = + let expandedTokens :: [DefnSearchToken (Either Name ShortHash)] + expandedTokens = + tokens & foldMap \case + NameToken name -> [NameToken name] + TypeMentionToken (name, ref) occ -> [TypeMentionToken (Left name) occ, TypeMentionToken (Right ref) occ] + TypeVarToken v occ -> [TypeVarToken v occ] + HashToken sh -> [HashToken sh] + TermTagToken tag -> [TermTagToken tag] + TypeTagToken tag -> [TypeTagToken tag] + TypeModToken mod -> [TypeModToken mod] + in ( project, + release, + Name.toText fqn, + Text.unwords (searchTokenToText False <$> expandedTokens), + arity, + tag, + 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. +-- +-- +-- Note: Names in tokens have their segments reversed, this is because PG Gin indexes only support +-- prefix-matching on lexemes, and this lets us match on any valid name suffix. +-- This is also why Hashes and Names come LAST in the token, so we can do, e.g. `mn,1,map.List:*` +-- +-- >>> import Unison.Syntax.Name qualified as Name +-- >>> searchTokenToText False (NameToken (Name.unsafeParseText "my.cool.name")) +-- "n,name.cool.my" +-- +-- >>> searchTokenToText False (TypeMentionToken (Left $ Name.unsafeParseText "Thing") (Just $ Occurrence 1)) +-- "mn,1,Thing" +-- +-- >>> import Unison.ShortHash qualified as SH +-- >>> import Data.Maybe (fromJust) +-- >>> searchTokenToText False (TypeMentionToken (Right . fromJust $ SH.fromText "#2tWjVAuc7") (Just $ Occurrence 1)) +-- "mh,1,#2tWjVAuc7" +-- +-- >>> searchTokenToText False (TypeMentionToken (Left $ Name.unsafeParseText "Thing") Nothing) +-- "mn,r,Thing" +-- +-- >>> searchTokenToText False (TypeMentionToken (Right $ fromJust $ SH.fromText "#2tWjVAuc7") Nothing) +-- "mh,r,#2tWjVAuc7" +-- +-- >>> searchTokenToText False (TypeVarToken (VarId 1) (Just $ Occurrence 2)) +-- "v,2,1" +-- +-- >>> searchTokenToText False (TermTagToken Doc) +-- "t,doc" +-- >>> searchTokenToText False (TermTagToken (Constructor Data)) +-- "t,data-con" +-- >>> searchTokenToText False (TypeTagToken Data) +-- "t,data" +-- +-- Should backslash escape special symbols. +-- >>> searchTokenToText False (NameToken (Name.unsafeParseText "my.name!")) +-- "n,name\\!.my" +-- +-- >>> searchTokenToText False (NameToken (Name.unsafeParseText "operators.\\&:|!|")) +-- "n,\\\\\\&\\:\\|\\!\\|.operators" +-- +-- Should add wildcards to the end of name, hash, and type mention tokens, but not others. +-- >>> searchTokenToText True (NameToken (Name.unsafeParseText "my.name")) +-- "n,name.my:*" +-- +-- >>> searchTokenToText True (TypeMentionToken (Left $ Name.unsafeParseText "Thing") (Just $ Occurrence 1)) +-- "mn,1,Thing:*" +-- +-- >>> searchTokenToText True (TypeMentionToken (Right . fromJust $ SH.fromText "#2tWjVAuc7") (Just $ Occurrence 1)) +-- "mh,1,#2tWjVAuc7:*" +-- +-- >>> searchTokenToText True (TypeVarToken (VarId 1) (Just $ Occurrence 1)) +-- "v,1,1" +searchTokenToText :: Bool -> DefnSearchToken (Either Name ShortHash) -> Text +searchTokenToText shouldAddWildcards = \case + NameToken name -> + makeSearchToken nameType (reversedNameText name) Nothing + & addWildCard + TypeMentionToken (Left name) occ -> + makeSearchToken typeMentionTypeByNameType (reversedNameText name) (Just occ) + & addWildCard + TypeMentionToken (Right sh) occ -> + makeSearchToken typeMentionTypeByHashType (into @Text @ShortHash sh) (Just occ) + & addWildCard + TypeVarToken varId occ -> makeSearchToken typeVarType (varIdText varId) (Just occ) + HashToken sh -> + makeSearchToken hashType (into @Text sh) Nothing + & addWildCard + TermTagToken termTag -> makeSearchToken tagType (termTagText termTag) Nothing + TypeTagToken typTag -> makeSearchToken tagType (typeTagText typTag) Nothing + TypeModToken mod -> makeSearchToken typeModType (typeModText mod) Nothing + where + addWildCard token = if shouldAddWildcards then (token <> ":*") else token + 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" + escapeToken :: Text -> Text + escapeToken txt = + txt + -- FIRST we escape all existing backslashes + & Text.replace "\\" "\\\\" + -- Then fold over the provided characters, escaping them with a preceding backslash + & \t -> foldr (\c acc -> Text.replace (Text.singleton c) (Text.pack ['\\', c]) acc) t ("()|& :*!," :: String) + makeSearchToken :: Text -> Text -> Maybe (Maybe Occurrence) -> Text + makeSearchToken kind txt occTxt = do + let occ = case occTxt of + Just (Just (Occurrence n)) -> [tShow n] + Just Nothing -> ["r"] + Nothing -> [] + in Text.intercalate "," $ + [kind] <> occ <> [escapeToken txt] + +reversedNameText :: Name -> Text +reversedNameText n = Text.intercalate "." $ Foldable.toList $ fmap NameSegment.toEscapedText $ Name.reverseSegments n + +searchTokensToTsQuery :: Set (DefnSearchToken (Either Name ShortHash)) -> Text +searchTokensToTsQuery tokens = + tokens + & Set.toList + & fmap (searchTokenToText True) + & Text.intercalate " & " + +data DefnNameSearchFilter + = ProjectFilter ProjectId + | ReleaseFilter ReleaseId + | UserFilter UserId + +defNameSearch :: Maybe UserId -> Maybe DefnNameSearchFilter -> Query -> Limit -> Transaction e [(ProjectId, ReleaseId, Name, TermOrTypeTag)] +defNameSearch mayCaller mayFilter (Query query) limit = do + let filters = case mayFilter of + Just (ProjectFilter projId) -> [sql| AND doc.project_id = #{projId} |] + Just (ReleaseFilter relId) -> [sql| AND doc.release_id = #{relId} |] + Just (UserFilter userId) -> [sql| AND p.owner_id = #{userId} |] + Nothing -> mempty + queryListRows @(ProjectId, ReleaseId, Name, TermOrTypeTag) + [sql| + WITH matches_deduped_by_project(project_id, release_id, name, tag) AS ( + SELECT DISTINCT ON (doc.project_id, doc.name) doc.project_id, doc.release_id, doc.name, doc.tag FROM global_definition_search_docs doc + JOIN projects p ON p.id = doc.project_id + JOIN project_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} <% doc.name + AND (NOT p.private OR (#{mayCaller} IS NOT NULL AND EXISTS (SELECT FROM accessible_private_projects pp WHERE pp.user_id = #{mayCaller} AND pp.project_id = p.id))) + ^{filters} + ORDER BY doc.project_id, doc.name, r.major_version, r.minor_version, r.patch_version + ), + -- Find the best matches + best_results(project_id, release_id, name, tag) AS ( + SELECT m.project_id, m.release_id, m.name, m.tag + FROM matches_deduped_by_project m + ORDER BY similarity(#{query}, m.name) DESC + LIMIT #{limit} + ) + -- THEN sort docs to the bottom. + SELECT br.project_id, br.release_id, br.name, br.tag + FROM best_results br + -- docs and tests to the bottom, but otherwise sort by quality of the match. + ORDER BY (br.tag <> 'doc'::definition_tag, br.tag <> 'test'::definition_tag, br.name LIKE ('%' || like_escape(#{query})), similarity(#{query}, br.name)) DESC + |] + +definitionSearch :: Maybe UserId -> Maybe DefnNameSearchFilter -> Limit -> Set (DefnSearchToken (Either Name ShortHash)) -> Maybe Arity -> Transaction e [(ProjectId, ReleaseId, Name, TermOrTypeSummary)] +definitionSearch mayCaller mayFilter limit searchTokens preferredArity = do + let filters = case mayFilter of + Just (ProjectFilter projId) -> [sql| AND doc.project_id = #{projId} |] + Just (ReleaseFilter relId) -> [sql| AND doc.release_id = #{relId} |] + Just (UserFilter userId) -> [sql| AND p.owner_id = #{userId} |] + Nothing -> mempty + let tsQueryText = searchTokensToTsQuery searchTokens + rows <- + queryListRows @(ProjectId, ReleaseId, Name, Hasql.Jsonb) + [sql| + WITH matches_deduped_by_project(project_id, release_id, name, arity, metadata, num_search_tokens) AS ( + SELECT DISTINCT ON (doc.project_id, doc.name) doc.project_id, doc.release_id, doc.name, doc.arity, doc.metadata, length(doc.search_tokens) FROM global_definition_search_docs doc + JOIN projects p ON p.id = doc.project_id + JOIN project_releases r ON r.id = doc.release_id + WHERE + -- match on search tokens using GIN index. + tsquery(#{tsQueryText}) @@ doc.search_tokens + AND (NOT p.private OR (#{mayCaller} IS NOT NULL AND EXISTS (SELECT FROM accessible_private_projects pp WHERE pp.user_id = #{mayCaller} AND pp.project_id = p.id))) + ^{filters} + ORDER BY doc.project_id, doc.name, r.major_version, r.minor_version, r.patch_version + ) SELECT m.project_id, m.release_id, m.name, m.metadata + FROM matches_deduped_by_project m + -- prefer results which have at LEAST the requested arity, then prefer shorter + -- arities. + ORDER BY (m.arity >= #{preferredArity}) DESC, m.arity ASC, m.num_search_tokens ASC + LIMIT #{limit} + |] + rows & traverseOf (traversed . _4) \(Hasql.Jsonb v) -> do + case fromJSON v of + Aeson.Error err -> unrecoverableError $ FailedToDecodeMetadata v (Text.pack err) + Aeson.Success summary -> pure summary diff --git a/src/Share/Prelude/Orphans.hs b/src/Share/Prelude/Orphans.hs index 397713b..4ea5e9f 100644 --- a/src/Share/Prelude/Orphans.hs +++ b/src/Share/Prelude/Orphans.hs @@ -7,20 +7,26 @@ 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 +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" -instance {-# OVERLAPPING #-} TypeError.TypeError ('TypeError.Text "Strings are decoded as a char[], Did you mean to use Text instead?") => Interp.DecodeValue String where +instance {-# OVERLAPPING #-} (TypeError.TypeError ('TypeError.Text "Strings are decoded as a char[], Did you mean to use Text instead?")) => Interp.DecodeValue String where decodeValue = error "unpossible" -- Useful instance, but doesn't exist in either lib, likely because they just don't want to depend on one another. -instance Semialign f => Semialign (Cofree f) where - align :: Semialign f => Cofree f a -> Cofree f b -> Cofree f (These a b) +instance (Semialign f) => Semialign (Cofree f) where + align :: (Semialign f) => Cofree f a -> Cofree f b -> Cofree f (These a b) align (a :< l) (b :< r) = These a b :< alignWith go l r where @@ -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/API.hs b/src/Share/Web/API.hs index a53c7c5..d188e3e 100644 --- a/src/Share/Web/API.hs +++ b/src/Share/Web/API.hs @@ -3,6 +3,7 @@ module Share.Web.API where +import Servant import Share.OAuth.API qualified as OAuth import Share.OAuth.Session (MaybeAuthenticatedSession) import Share.Prelude @@ -12,7 +13,6 @@ import Share.Web.Share.API qualified as Share import Share.Web.Share.Projects.API qualified as Projects import Share.Web.Support.API qualified as Support import Share.Web.Types -import Servant import Unison.Share.API.Projects qualified as UCMProjects import Unison.Sync.API qualified as Unison.Sync @@ -22,6 +22,8 @@ type API = :<|> ("codebases" :> Share.UserPublicCodebaseAPI) :<|> ("users" :> Share.UserAPI) :<|> ("search" :> Share.SearchEndpoint) + :<|> ("search-names" :> Share.SearchDefinitionNamesEndpoint) + :<|> ("search-definitions" :> Share.SearchDefinitionsEndpoint) :<|> ("account" :> Share.AccountAPI) :<|> ("catalog" :> Projects.CatalogAPI) -- This path is part of the standard: https://datatracker.ietf.org/doc/html/rfc5785 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/Impl.hs b/src/Share/Web/Impl.hs index a6cc4ab..7228424 100644 --- a/src/Share/Web/Impl.hs +++ b/src/Share/Web/Impl.hs @@ -60,6 +60,8 @@ server = :<|> Share.userCodebaseServer :<|> Share.userServer :<|> Share.searchEndpoint + :<|> Share.searchDefinitionNamesEndpoint + :<|> Share.searchDefinitionsEndpoint :<|> Share.accountServer :<|> Projects.catalogServer :<|> discoveryEndpoint diff --git a/src/Share/Web/Share/API.hs b/src/Share/Web/Share/API.hs index d0f25d1..145afe5 100644 --- a/src/Share/Web/Share/API.hs +++ b/src/Share/Web/Share/API.hs @@ -3,8 +3,9 @@ module Share.Web.Share.API where +import Servant import Share.IDs -import Share.OAuth.Session (AuthenticatedSession, AuthenticatedUserId, MaybeAuthenticatedSession) +import Share.OAuth.Session (AuthenticatedSession, AuthenticatedUserId, MaybeAuthenticatedSession, MaybeAuthenticatedUserId) import Share.Prelude (NonEmpty) import Share.Utils.API import Share.Utils.Caching @@ -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,26 @@ type SearchEndpoint = :> QueryParam "limit" Limit :> Get '[JSON] [SearchResult] +-- | Search for names to use in a definition search. +type SearchDefinitionNamesEndpoint = + MaybeAuthenticatedUserId + :> 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 = + MaybeAuthenticatedUserId + :> RequiredQueryParam "query" Query + :> QueryParam "limit" Limit + :> QueryParam "user-filter" UserHandle + :> QueryParam "project-filter" ProjectShortHand + :> QueryParam "release-filter" ReleaseVersion + :> Get '[JSON] DefinitionSearchResults + 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/DefinitionSearch.hs b/src/Share/Web/Share/DefinitionSearch.hs new file mode 100644 index 0000000..4282f20 --- /dev/null +++ b/src/Share/Web/Share/DefinitionSearch.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE DataKinds #-} + +module Share.Web.Share.DefinitionSearch (queryToTokens) where + +import Control.Lens +import Data.Char qualified as Char +import Data.List qualified as List +import Data.Map.Monoidal (MonoidalMap) +import Data.Map.Monoidal qualified as MonMap +import Data.Monoid (Sum (..)) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Share.BackgroundJobs.Search.DefinitionSync.Types (Arity, DefnSearchToken (..), Occurrence, VarId (..)) +import Share.Prelude +import Text.Megaparsec qualified as MP +import Text.Megaparsec.Char qualified as MP +import Text.Megaparsec.Char.Lexer qualified as MP hiding (space) +import Unison.Name (Name) +import Unison.Name qualified as Name +import Unison.ShortHash (ShortHash) +import Unison.ShortHash qualified as SH +import Unison.Syntax.Name qualified as Name +import Unison.Syntax.NameSegment qualified as NameSegment + +data QueryError + = InvalidHash Text + | InvalidName Text + deriving stock (Show, Eq, Ord) + +instance MP.ShowErrorComponent QueryError where + showErrorComponent = \case + InvalidHash hash -> "Encountered invalid hash: " <> Text.unpack hash + InvalidName name -> "Encountered Invalid name: " <> Text.unpack name + +data MentionRef + = HashMention ShortHash + | NameMention Name + | TypeNameMention Name + | TypeVarMention Text + | TypeHashMention ShortHash + deriving stock (Show, Eq, Ord) + +type P = MP.Parsec QueryError Text + +-- | A very lax parser which converts a query into structured tokens for searching definitions. +-- +-- A query may look like: +-- +-- Simple definition name query: +-- E.g. foldMap +-- +-- Type signature query +-- E.g.: +-- k -> v -> Map k v -> Map k v +-- +-- Ad-hoc query: +-- +-- Nat Text Abort +-- +-- Hash-query +-- +-- #abc1234 +-- +-- >>> queryToTokens "foldMap" +-- Right (fromList [NameToken (Name Relative (NameSegment {toUnescapedText = "foldMap"} :| []))],Nothing) +-- +-- >>> queryToTokens "#abc1234" +-- Right (fromList [HashToken (ShortHash {prefix = "abc1234", cycle = Nothing, cid = Nothing})],Nothing) +-- +-- >>> queryToTokens "##Nat" +-- Right (fromList [HashToken (Builtin "Nat")],Nothing) +-- +-- >>> queryToTokens "Nat Text #deadbeef Abort" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Abort"} :| []))) (Just 1),TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Nat"} :| []))) (Just 1),TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Text"} :| []))) (Just 1),TypeMentionToken (Right (ShortHash {prefix = "deadbeef", cycle = Nothing, cid = Nothing})) (Just 1)],Nothing) +-- +-- >>> queryToTokens "k -> v -> Map k v -> Map k v" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Map"} :| []))) (Just 2),TypeVarToken 0 (Just 3),TypeVarToken 1 (Just 3)],Just 3) +-- +-- >>> queryToTokens ": b -> a -> b" +-- Right (fromList [TypeVarToken 0 (Just 1),TypeVarToken 1 (Just 2)],Just 2) +-- +-- >>> queryToTokens "(a ->{𝕖} b) -> [a] ->{𝕖} [b]" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "List"} :| []))) (Just 2),TypeVarToken 0 (Just 2),TypeVarToken 1 (Just 2)],Just 2) +-- +-- >>> queryToTokens "'{Abort} ()" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Abort"} :| []))) (Just 1)],Nothing) +-- +-- Unfinished query: +-- >>> queryToTokens "(Text -> Text" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Text"} :| []))) (Just 2)],Nothing) +-- +-- Horribly mishapen query: +-- >>> queryToTokens "[{ &Text !{𝕖} (Optional)" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Optional"} :| []))) (Just 1),TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Text"} :| []))) (Just 1)],Nothing) +-- +-- >>> queryToTokens "e -> abilities.Exception" +-- Right (fromList [TypeMentionToken (Left (Name Relative (NameSegment {toUnescapedText = "Exception"} :| [NameSegment {toUnescapedText = "abilities"}]))) (Just 1),TypeVarToken 0 (Just 1)],Just 1) +-- +-- >>> queryToTokens "Json.Text" +-- Right (fromList [NameToken (Name Relative (NameSegment {toUnescapedText = "Text"} :| [NameSegment {toUnescapedText = "Json"}]))],Nothing) +queryToTokens :: Text -> Either Text (Set (DefnSearchToken (Either Name ShortHash)), Maybe Arity) +queryToTokens query = + let cleanQuery = + query + & Text.filter Char.isAscii + parseResult = + MP.runParser queryParser "query" cleanQuery + & \case + (Left _err) -> + let simpleQuery = + cleanQuery + & Text.map (\c -> if Char.isAlphaNum c || c `elem` ("#." :: String) then c else ' ') + & Text.words + & Text.unwords + in -- If even the lax parser fails, try simplifying the query even further to see if + -- we can parse anything at all. + mapLeft (Text.pack . MP.errorBundlePretty) $ MP.runParser queryParser "query" simpleQuery + (Right r) -> Right r + in case parseResult of + Left err -> Left err + Right (mayArity, occurrences) -> + let (hashAndNameTokens, typeVarMentions) = + MonMap.toList + occurrences + & foldMap \case + (HashMention hash, _occ) -> ([HashToken hash], []) + (NameMention name, _occ) -> ([NameToken name], []) + (TypeNameMention name, occ) -> ([TypeMentionToken (Left name) $ Just occ], []) + (TypeVarMention var, occ) -> ([], [(var, occ)]) + (TypeHashMention hash, occ) -> ([TypeMentionToken (Right hash) $ Just occ], []) + + -- Normalize type vars so varIds are sorted according to number of occurences. + normalizedTypeVarTokens = + List.sortOn snd typeVarMentions + & imap (\i (_vId, occ) -> TypeVarToken (VarId i) $ Just occ) + -- if there's no indication the user is trying to do a 'real' type query then + -- ignore arity. + arity = do + Sum n <- mayArity + if n <= 0 + then Nothing + else Just n + in Right (Set.fromList $ hashAndNameTokens <> normalizedTypeVarTokens, arity) + +queryParser :: P (Maybe (Sum Arity), MonoidalMap MentionRef Occurrence) +queryParser = do + MP.choice + [ (Nothing,) <$> MP.try simpleHashQueryP, + (Nothing,) <$> MP.try simpleNameQueryP, + first Just <$> typeQueryP + ] + <* MP.eof + +lexeme :: P a -> P a +lexeme = MP.lexeme MP.space + +simpleHashQueryP :: P (MonoidalMap MentionRef Occurrence) +simpleHashQueryP = do + possibleHash <- lexeme hashP + -- Simple queries have ONLY the hash + MP.eof + pure $ MonMap.singleton (HashMention possibleHash) 1 + +simpleNameQueryP :: P (MonoidalMap MentionRef Occurrence) +simpleNameQueryP = do + name <- initialNameP + -- Simple queries have ONLY the name + MP.eof + pure $ MonMap.singleton (NameMention name) 1 + +-- | Parse a type query, returning the arity of the top-level type +typeQueryP :: P (Sum Arity, MonoidalMap MentionRef Occurrence) +typeQueryP = do + _ <- optional $ lexeme (MP.char ':') + fmap fold . some $ do + tokens <- + lexeme $ + MP.choice + [ typeQueryTokenP, + listP, + MP.try unitP, + MP.try tupleP, + -- We do anything smart with bracketed types yet. + MP.between (lexeme (MP.char '(')) (optional $ lexeme (MP.char ')')) (snd <$> typeQueryP), + -- Remove type var mentions from ability lists, we don't consider them when building + -- the index so they just wreck search results. + removeTypeVarMentions <$> MP.between (lexeme (MP.char '{')) (optional $ lexeme (MP.char '}')) (foldMap snd <$> MP.sepBy typeQueryP (lexeme $ MP.char ',')) + ] + arityBump <- + optional (lexeme (MP.string "->")) + <&> \case + Nothing -> Sum 0 + Just _ -> Sum 1 + pure (arityBump, tokens) + where + removeTypeVarMentions :: MonoidalMap MentionRef Occurrence -> MonoidalMap MentionRef Occurrence + removeTypeVarMentions = MonMap.filterWithKey \k _v -> case k of + TypeVarMention _ -> False + _ -> True + +-- We just ignore units for now, they don't contribute much to the search. +unitP :: P (MonoidalMap MentionRef Occurrence) +unitP = MP.choice [MP.string "()", MP.string "Unit", MP.string "'"] $> mempty + +tupleP :: P (MonoidalMap MentionRef Occurrence) +tupleP = MP.between (MP.char '(') (MP.char ')') do + typeQueryP + _ <- MP.char ',' + typeQueryP + pure $ MonMap.singleton (TypeNameMention (Name.unsafeParseText "Tuple")) 1 + +listP :: P (MonoidalMap MentionRef Occurrence) +listP = MP.between (lexeme (MP.char '[')) (lexeme (MP.char ']')) do + (_, tokens) <- typeQueryP + pure $ tokens <> MonMap.singleton (TypeNameMention (Name.unsafeParseText "List")) 1 + +typeQueryTokenP :: P (MonoidalMap MentionRef Occurrence) +typeQueryTokenP = do + MP.choice + [ hashMentionTokenP, + typeMentionP + ] + where + hashMentionTokenP :: P (MonoidalMap MentionRef Occurrence) + hashMentionTokenP = do + hash <- hashP + pure $ MonMap.singleton (TypeHashMention hash) 1 + +typeMentionP :: P (MonoidalMap MentionRef Occurrence) +typeMentionP = do + name <- nameP + case name of + n + | Just (c, _) <- Text.uncons . NameSegment.toEscapedText . Name.lastSegment $ n, + Char.isLower c, + Name.countSegments n == 1 -> + pure $ MonMap.singleton (TypeVarMention (Name.toText n)) 1 + | otherwise -> pure $ MonMap.singleton (TypeNameMention name) 1 + +hashP :: P ShortHash +hashP = do + -- Start with at least one hash; + _ <- MP.char '#' + possibleHash <- ('#' :) <$> (some $ MP.alphaNumChar <|> MP.char '#') + case SH.fromText (Text.pack possibleHash) of + Nothing -> MP.customFailure . InvalidHash $ Text.pack possibleHash + Just hash -> pure hash + +nameP :: P Name +nameP = do + name <- List.intercalate "." <$> MP.sepBy (liftA2 (:) (MP.satisfy NameSegment.wordyIdStartChar) (many (MP.satisfy NameSegment.wordyIdChar))) (MP.char '.') + case Name.parseTextEither (Text.pack name) of + Left _ -> MP.customFailure . InvalidName $ Text.pack name + Right name -> pure name + +initialNameP :: P Name +initialNameP = do + name <- List.intercalate "." <$> MP.sepBy (some (MP.satisfy NameSegment.symbolyIdChar) <|> (liftA2 (:) (MP.satisfy NameSegment.wordyIdStartChar) (many (MP.satisfy NameSegment.wordyIdChar)))) (MP.char '.') + case Name.parseTextEither (Text.pack name) of + Left _ -> MP.customFailure . InvalidName $ Text.pack name + Right name -> pure name diff --git a/src/Share/Web/Share/Impl.hs b/src/Share/Web/Share/Impl.hs index d929e94..f051b6f 100644 --- a/src/Share/Web/Share/Impl.hs +++ b/src/Share/Web/Share/Impl.hs @@ -8,6 +8,7 @@ module Share.Web.Share.Impl where import Data.Text qualified as Text import Servant +import Control.Lens import Share.Codebase qualified as Codebase import Share.Codebase.Types qualified as Codebase import Share.IDs (TourId, UserHandle (..)) @@ -18,15 +19,20 @@ import Share.OAuth.Types (UserId) import Share.Postgres qualified as PG import Share.Postgres.IDs (CausalHash) import Share.Postgres.Ops qualified as PGO +import Share.Postgres.Projects.Queries qualified as PQ import Share.Postgres.Queries qualified as Q +import Share.Postgres.Releases.Queries qualified as RQ +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.User qualified as User import Share.UserProfile (UserProfile (..)) import Share.Utils.API import Share.Utils.Caching +import Share.Utils.Logging qualified as Logging import Share.Utils.Servant.Cookies qualified as Cookies import Share.Web.App import Share.Web.Authentication qualified as AuthN @@ -36,6 +42,7 @@ import Share.Web.Share.API qualified as Share import Share.Web.Share.Branches.Impl qualified as Branches import Share.Web.Share.CodeBrowsing.API (CodeBrowseAPI) import Share.Web.Share.Contributions.Impl qualified as Contributions +import Share.Web.Share.DefinitionSearch qualified as DefinitionSearch import Share.Web.Share.Projects.Impl qualified as Projects import Share.Web.Share.Types import Unison.Codebase.Path qualified as Path @@ -44,7 +51,8 @@ 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 @@ -215,7 +223,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 @@ -363,6 +371,71 @@ searchEndpoint (MaybeAuthedUserID callerUserId) (Query query) (fromMaybe (Limit 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 projectFilter releaseFilter <|> resolveUserFilter userFilter + matches <- PG.runTransaction $ DDQ.defNameSearch callerUserId filter query limit + let response = matches <&> \(_projId, _releaseId, name, tag) -> DefinitionNameSearchResult name tag + pure response + where + limit = fromMaybe (Limit 20) mayLimit + +resolveProjectAndReleaseFilter :: Maybe IDs.ProjectShortHand -> Maybe IDs.ReleaseVersion -> MaybeT WebApp DDQ.DefnNameSearchFilter +resolveProjectAndReleaseFilter projectFilter releaseFilter = 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 :: Maybe UserHandle -> MaybeT WebApp DDQ.DefnNameSearchFilter +resolveUserFilter userFilter = 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 + +searchDefinitionsEndpoint :: + Maybe UserId -> + Query -> + Maybe Limit -> + Maybe UserHandle -> + Maybe IDs.ProjectShortHand -> + Maybe IDs.ReleaseVersion -> + WebApp DefinitionSearchResults +searchDefinitionsEndpoint callerUserId (Query query) mayLimit userFilter projectFilter releaseFilter = do + filter <- runMaybeT $ resolveProjectAndReleaseFilter projectFilter releaseFilter <|> resolveUserFilter userFilter + case DefinitionSearch.queryToTokens query of + Left _err -> do + Logging.logErrorText $ "Failed to parse query: " <> query + pure $ DefinitionSearchResults [] + Right (searchTokens, mayArity) -> do + matches <- + PG.runTransactionMode PG.ReadCommitted PG.Read $ + DDQ.definitionSearch callerUserId filter limit searchTokens mayArity + >>= PQ.expectProjectShortHandsOf (traversed . _1) + >>= RQ.expectReleaseVersionsOf (traversed . _2) + <&> over (traversed . _2) IDs.ReleaseShortHand + let results = + matches <&> \(project, release, fqn, summary) -> + DefinitionSearchResult + { fqn, + summary, + project, + release + } + pure $ DefinitionSearchResults results + where + limit = fromMaybe (Limit 20) mayLimit + 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..1c2764e 100644 --- a/src/Share/Web/Share/Types.hs +++ b/src/Share/Web/Share/Types.hs @@ -6,13 +6,17 @@ 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 (TermOrTypeTag) +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) +import Unison.Server.Share.DefinitionSummary.Types (TermSummary (..), TypeSummary (..)) data UpdateUserRequest = UpdateUserRequest { name :: NullableUpdate Text, @@ -151,3 +155,64 @@ instance ToJSON UserDisplayInfo where "avatarUrl" Aeson..= avatarUrl, "userId" Aeson..= userId ] + +data DefinitionNameSearchResult + = DefinitionNameSearchResult + { token :: Name, + tag :: TermOrTypeTag + } + +instance ToJSON DefinitionNameSearchResult where + toJSON DefinitionNameSearchResult {..} = + Aeson.object + [ "token" .= token, + "tag" .= tag + ] + +newtype DefinitionSearchResults = DefinitionSearchResults + { results :: [DefinitionSearchResult] + } + +instance ToJSON DefinitionSearchResults where + toJSON DefinitionSearchResults {..} = + Aeson.object + [ "results" .= results + ] + +data DefinitionSearchResult + = DefinitionSearchResult + { fqn :: Name, + summary :: DefSync.TermOrTypeSummary, + project :: ProjectShortHand, + release :: ReleaseShortHand + } + +instance ToJSON DefinitionSearchResult where + toJSON DefinitionSearchResult {..} = + Aeson.object + [ "fqn" Aeson..= fqn, + "projectRef" Aeson..= project, + "branchRef" Aeson..= release, + "kind" Aeson..= kind, + "definition" Aeson..= definition + ] + where + (kind, definition) = case summary of + DefSync.ToTTermSummary TermSummary {displayName, hash, summary, tag} -> + ( Aeson.String "term", + Aeson.object + [ "displayName" Aeson..= displayName, + "hash" Aeson..= hash, + "summary" Aeson..= summary, + "tag" Aeson..= tag + ] + ) + DefSync.ToTTypeSummary TypeSummary {displayName, hash, summary, tag} -> + ( Aeson.String "type", + Aeson.object + [ "displayName" Aeson..= displayName, + "hash" Aeson..= hash, + "summary" Aeson..= summary, + "tag" Aeson..= tag + ] + ) 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/transcripts/run-transcripts.zsh b/transcripts/run-transcripts.zsh index 0f2ed0a..f41e984 100755 --- a/transcripts/run-transcripts.zsh +++ b/transcripts/run-transcripts.zsh @@ -11,6 +11,7 @@ source "$(realpath "$(dirname "$0")")/transcript_helpers.sh" typeset -A transcripts transcripts=( + search transcripts/share-apis/search/ users transcripts/share-apis/users/ contribution-diffs transcripts/share-apis/contribution-diffs/ definition-diffs transcripts/share-apis/definition-diffs/ diff --git a/transcripts/share-apis/search/complex-type-mention-search.json b/transcripts/share-apis/search/complex-type-mention-search.json new file mode 100644 index 0000000..c47a5aa --- /dev/null +++ b/transcripts/share-apis/search/complex-type-mention-search.json @@ -0,0 +1,159 @@ +{ + "body": { + "results": [ + { + "branchRef": "releases/1.2.3", + "definition": { + "displayName": "List.map", + "hash": "#53u6nne5tneggsh2ngr76khq4kfdpvuf4l7kv6sq39kr9hjvh3qg4midcc5b69qhjlfii3io7pe2rn1on7rr6h76qsmjbc66n2ivpeo", + "summary": { + "contents": [ + { + "annotation": null, + "segment": "(" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "b" + }, + { + "annotation": null, + "segment": ")" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#22ffou62u91ks8av7bdmhq10jct5ulot40c84j0k3kfdrh5rj2o6a3ditsfpo6sv6mkde2p13um06mkrsdckudmeh6k4oa7v53887f8", + "tag": "TypeReference" + }, + "segment": "List" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#22ffou62u91ks8av7bdmhq10jct5ulot40c84j0k3kfdrh5rj2o6a3ditsfpo6sv6mkde2p13um06mkrsdckudmeh6k4oa7v53887f8", + "tag": "TypeReference" + }, + "segment": "List" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "b" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + }, + "fqn": "List.map", + "kind": "term", + "projectRef": "@transcripts/search" + } + ] + }, + "status": [ + { + "status_code": 200 + } + ] +} diff --git a/transcripts/share-apis/search/create-release.json b/transcripts/share-apis/search/create-release.json new file mode 100644 index 0000000..792cd50 --- /dev/null +++ b/transcripts/share-apis/search/create-release.json @@ -0,0 +1,21 @@ +{ + "body": { + "causalHashSquashed": "#ih4vtflqotqkapjcmcfsbn7ohs94rp5mr4lo4tddlbja0hf6n0bp964dbqumfli49jbvu40uu9i3257aq406kt3v0nt6jrei9ajf9j0", + "causalHashUnsquashed": "#ih4vtflqotqkapjcmcfsbn7ohs94rp5mr4lo4tddlbja0hf6n0bp964dbqumfli49jbvu40uu9i3257aq406kt3v0nt6jrei9ajf9j0", + "createdAt": "", + "createdBy": "@transcripts", + "projectRef": "@transcripts/search", + "status": { + "publishedAt": "", + "publishedBy": "@transcripts", + "status": "published" + }, + "updatedAt": "", + "version": "1.2.3" + }, + "status": [ + { + "status_code": 201 + } + ] +} diff --git a/transcripts/share-apis/search/name-search-prefix.json b/transcripts/share-apis/search/name-search-prefix.json new file mode 100644 index 0000000..4be7867 --- /dev/null +++ b/transcripts/share-apis/search/name-search-prefix.json @@ -0,0 +1,13 @@ +{ + "body": [ + { + "tag": "plain", + "token": "function.const" + } + ], + "status": [ + { + "status_code": 200 + } + ] +} diff --git a/transcripts/share-apis/search/name-search-suffix.json b/transcripts/share-apis/search/name-search-suffix.json new file mode 100644 index 0000000..e710bbb --- /dev/null +++ b/transcripts/share-apis/search/name-search-suffix.json @@ -0,0 +1,17 @@ +{ + "body": [ + { + "tag": "plain", + "token": "function.const" + }, + { + "tag": "data-constructor", + "token": "List.Cons" + } + ], + "status": [ + { + "status_code": 200 + } + ] +} diff --git a/transcripts/share-apis/search/prelude.md b/transcripts/share-apis/search/prelude.md new file mode 100644 index 0000000..3367312 --- /dev/null +++ b/transcripts/share-apis/search/prelude.md @@ -0,0 +1,20 @@ +```unison +structural type List a = Nil | Cons a (List a) + +function.const : a -> b -> a +function.const a b = a + +structural ability Throw e where + throw : e -> a + +List.map : (a -> {g} b) -> List a -> {g} List b +List.map f = cases + (Cons a rest) -> Cons (f a) (List.map f rest) + Nil -> Nil +``` + + +```ucm +scratch/main> add +scratch/main> push @transcripts/search/main +``` diff --git a/transcripts/share-apis/search/run.zsh b/transcripts/share-apis/search/run.zsh new file mode 100755 index 0000000..9c16ec6 --- /dev/null +++ b/transcripts/share-apis/search/run.zsh @@ -0,0 +1,47 @@ +#!/usr/bin/env zsh + +set -e +source ../../transcript_helpers.sh + +# Reset DB to a known state +pg_reset_fixtures + +login_user_for_ucm 'transcripts' +transcript_ucm transcript prelude.md + +echo 'get-causal-hash' +causalHash="$(fetch_data "$transcript_user" GET 'get-causal-hash' '/users/transcripts/projects/search/branches/main/browse' 2>/dev/null | jq -r '.namespaceListingHash')" + +echo 'create-release' +# Create a release so it will be indexed +fetch "$transcript_user" POST create-release '/users/transcripts/projects/search/releases' "{ + \"causalHash\": \"${causalHash}\", + \"major\": 1, + \"minor\": 2, + \"patch\": 3 +}" + +echo 'check-indexed' +# We have to wait for it to be indexed +for i in {1..10}; do + if fetch_data "$transcript_user" GET 'check-indexed' '/search-names?query=const' | jq -e '(. | length) > 0' 2>/dev/null >/dev/null; then + echo 'Found definition search results, continuing...'; + break; + # If we're on the last iteration fail the transcript + elif [[ "$i" -ge 10 ]] then + echo 'Failed to find any definition search results before timeout.'; + exit 1; + fi + sleep 3; +done + +# Name searches +fetch "$transcript_user" GET 'name-search-suffix' '/search-names?query=const' +fetch "$transcript_user" GET 'name-search-prefix' '/search-names?query=Func' + +# Type searches +# "b -> a -> a" +fetch "$transcript_user" GET 'type-var-search' '/search-definitions?query=b%20-%3E%20a%20-%3E%20a' + +# (a -> b) -> List a -> List b +fetch "$transcript_user" GET 'complex-type-mention-search' '/search-definitions?query=(a%20-%3E%20b)%20-%3E%20List%20a%20-%3E%20List%20b' diff --git a/transcripts/share-apis/search/type-var-search.json b/transcripts/share-apis/search/type-var-search.json new file mode 100644 index 0000000..4163433 --- /dev/null +++ b/transcripts/share-apis/search/type-var-search.json @@ -0,0 +1,221 @@ +{ + "body": { + "results": [ + { + "branchRef": "releases/1.2.3", + "definition": { + "displayName": "function.const", + "hash": "#20991ok5ht19nlsedaet8das0lq77c0hjjthlbmicvued7s733uhj7jmeao4is1mu380u98qlf1iosf15b8atsfl1mo4bv3kl3i7hdo", + "summary": { + "contents": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "b" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + }, + "fqn": "function.const", + "kind": "term", + "projectRef": "@transcripts/search" + }, + { + "branchRef": "releases/1.2.3", + "definition": { + "displayName": "List.map", + "hash": "#53u6nne5tneggsh2ngr76khq4kfdpvuf4l7kv6sq39kr9hjvh3qg4midcc5b69qhjlfii3io7pe2rn1on7rr6h76qsmjbc66n2ivpeo", + "summary": { + "contents": [ + { + "annotation": null, + "segment": "(" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "b" + }, + { + "annotation": null, + "segment": ")" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#22ffou62u91ks8av7bdmhq10jct5ulot40c84j0k3kfdrh5rj2o6a3ditsfpo6sv6mkde2p13um06mkrsdckudmeh6k4oa7v53887f8", + "tag": "TypeReference" + }, + "segment": "List" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TypeOperator" + }, + "segment": "->" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "{" + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "g" + }, + { + "annotation": { + "tag": "AbilityBraces" + }, + "segment": "}" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "#22ffou62u91ks8av7bdmhq10jct5ulot40c84j0k3kfdrh5rj2o6a3ditsfpo6sv6mkde2p13um06mkrsdckudmeh6k4oa7v53887f8", + "tag": "TypeReference" + }, + "segment": "List" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "b" + } + ], + "tag": "UserObject" + }, + "tag": "Plain" + }, + "fqn": "List.map", + "kind": "term", + "projectRef": "@transcripts/search" + } + ] + }, + "status": [ + { + "status_code": 200 + } + ] +} diff --git a/transcripts/transcript_helpers.sh b/transcripts/transcript_helpers.sh index 3602678..622f641 100755 --- a/transcripts/transcript_helpers.sh +++ b/transcripts/transcript_helpers.sh @@ -88,6 +88,22 @@ clean_for_transcript() { } fetch() { + testname="$3" + result_file="$(mktemp)" + status_code_file="$(mktemp)" + api_path="$4" + echo "${testname}" "${api_path}" + fetch_data "$@" 2> "${status_code_file}" | clean_for_transcript > "${result_file}" + # Try embedding the json response as-is, but if it's not valid json (e.g. it's an error message instead), embed it as a string. + jq --sort-keys -n --slurpfile status "${status_code_file}" --slurpfile body "${result_file}" '{"status": $status, "body": ($body | .[0])}' > "./$testname.json" 2> /dev/null || { + jq --sort-keys -n --slurpfile status "${status_code_file}" --rawfile body "${result_file}" '{"status": $status, "body": $body}' > "./$testname.json" + } +} + +# fetch which returns the result, +# stderr gets '{"status_code:xxx"}' +# stdout gets the body +fetch_data() { if [ "$#" -lt 4 ]; then echo "fetch requires at least 4 arguments: user_id, method, testname, api_path, [data]" >&2 exit 1 @@ -101,22 +117,16 @@ fetch() { result_file="$(mktemp)" status_code_file="$(mktemp)" - echo "${testname}" "${api_path}" case $method in GET) - curl --request "GET" -L -s --cookie "$cookie_jar" -H "Accept: application/json" -w '%{stderr} {"status_code":%{http_code}}' "$url" 2> "${status_code_file}" | clean_for_transcript > "${result_file}" + curl --request "GET" -L -s --cookie "$cookie_jar" -H "Accept: application/json" -w '%{stderr} {"status_code":%{http_code}}' "$url" ;; *) - curl --request "$method" -L -s --cookie "$cookie_jar" -H "Accept: application/json" -H "Content-Type: application/json" --data-raw "$data" -w '%{stderr} {"status_code":%{http_code}}' "$url" 2> "${status_code_file}" | clean_for_transcript > "${result_file}" + curl --request "$method" -L -s --cookie "$cookie_jar" -H "Accept: application/json" -H "Content-Type: application/json" --data-raw "$data" -w '%{stderr} {"status_code":%{http_code}}' "$url" ;; esac - # Try embedding the json response as-is, but if it's not valid json (e.g. it's an error message instead), embed it as a string. - jq --sort-keys -n --slurpfile status "${status_code_file}" --slurpfile body "${result_file}" '{"status": $status, "body": ($body | .[0])}' > "./$testname.json" 2> /dev/null || { - jq --sort-keys -n --slurpfile status "${status_code_file}" --rawfile body "${result_file}" '{"status": $status, "body": $body}' > "./$testname.json" - } } - # Credentials setup login_user_for_ucm() { diff --git a/unison b/unison index 605e062..cdab05d 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 605e062bcfc3118ee83ca35c7d86a4036adea22f +Subproject commit cdab05d25992537ea1ce699a1dbe2d4413810b41