⅄ trunk → 21-12-04-use-unison-sqlite

after

@@ -0,0 +1,18 @@
+
+handleBackendError :: Backend.BackendError -> Action m i v ()
+handleBackendError = \case
+  Backend.NoSuchNamespace path ->
+    respond . BranchNotFound $ Path.absoluteToPath' path
+  Backend.BadNamespace msg namespace ->
+    respond $ BadNamespace msg namespace
+  Backend.BadRootBranch e -> respond $ BadRootBranch e
+  Backend.NoBranchForHash h -> do
+    sbhLength <- eval BranchHashLength
+    respond . NoBranchWithHash $ SBH.fromHash sbhLength h
+  Backend.CouldntLoadBranch h -> do
+    respond . CouldntLoadBranch $ h
+  Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh
+  Backend.AmbiguousBranchHash h hashes ->
+    respond $ BranchHashAmbiguous h hashes
+  Backend.MissingSignatureForTerm r ->
+    respond $ TermMissingType r

before

@@ -0,0 +1,16 @@
+
+handleBackendError :: Backend.BackendError -> Action m i v ()
+handleBackendError = \case
+  Backend.NoSuchNamespace path ->
+    respond . BranchNotFound $ Path.absoluteToPath' path
+  Backend.BadRootBranch e -> respond $ BadRootBranch e
+  Backend.NoBranchForHash h -> do
+    sbhLength <- eval BranchHashLength
+    respond . NoBranchWithHash $ SBH.fromHash sbhLength h
+  Backend.CouldntLoadBranch h -> do
+    respond . CouldntLoadBranch $ h
+  Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh
+  Backend.AmbiguousBranchHash h hashes ->
+    respond $ BranchHashAmbiguous h hashes
+  Backend.MissingSignatureForTerm r ->
+    respond $ TermMissingType r

parser-typechecker/src/Unison/Codebase/Init.hs

@@ -63,6 +63,7 @@ data InitError
   = FoundV1Codebase
   | InitErrorOpen OpenCodebaseError
   | CouldntCreateCodebase Pretty
+  deriving (Show, Eq)
 
 data InitResult
   = OpenedCodebase

parser-typechecker/src/Unison/Codebase/Init/OpenCodebaseError.hs

@@ -14,5 +14,5 @@ data OpenCodebaseError
     OpenCodebaseDoesntExist
   | -- | The codebase exists, but its schema version is unknown to this application.
     OpenCodebaseUnknownSchemaVersion Word64
-  deriving stock (Show)
+  deriving stock (Show, Eq)
   deriving anyclass (Exception)

parser-typechecker/src/Unison/Runtime/Interface.hs

@@ -490,10 +490,11 @@ decodeStandalone b = bimap thd thd $ runGetOrFail g b
         <*> getNat
         <*> getStoredCache
 
--- | Whether the runtime is hosted within a UCM session or as a standalone process.
+-- | Whether the runtime is hosted within a persistent session or as a one-off process.
+-- This affects the amount of clean-up and book-keeping the runtime does.
 data RuntimeHost
-  = Standalone
-  | UCM
+  = OneOff
+  | Persistent
 
 startRuntime :: RuntimeHost -> Text -> IO (Runtime Symbol)
 startRuntime runtimeHost version = do
@@ -501,10 +502,10 @@ startRuntime runtimeHost version = do
   (activeThreads, cleanupThreads) <- case runtimeHost of
     -- Don't bother tracking open threads when running standalone, they'll all be cleaned up
     -- when the process itself exits.
-    Standalone -> pure (Nothing, pure ())
+    OneOff -> pure (Nothing, pure ())
     -- Track all forked threads so that they can be killed when the main process returns,
     -- otherwise they'll be orphaned and left running.
-    UCM -> do
+    Persistent -> do
       activeThreads <- newIORef Set.empty
       let cleanupThreads = do
             threads <- readIORef activeThreads

parser-typechecker/tests/Unison/Test/UnisonSources.hs

@@ -59,7 +59,7 @@ bad r = EasyTest.expectLeft r >> done
 
 test :: Test ()
 test = do
-  rt <- io (RTI.startRuntime RTI.Standalone "")
+  rt <- io (RTI.startRuntime RTI.OneOff "")
   scope "unison-src"
     . tests
     $ [ go rt shouldPassNow good,

parser-typechecker/unison-parser-typechecker.cabal

@@ -132,21 +132,6 @@ library
       Unison.Runtime.SparseVector
       Unison.Runtime.Stack
       Unison.Runtime.Vector
-      Unison.Server.Backend
-      Unison.Server.CodebaseServer
-      Unison.Server.Doc
-      Unison.Server.Doc.AsHtml
-      Unison.Server.Endpoints.FuzzyFind
-      Unison.Server.Endpoints.GetDefinitions
-      Unison.Server.Endpoints.NamespaceDetails
-      Unison.Server.Endpoints.NamespaceListing
-      Unison.Server.Endpoints.Projects
-      Unison.Server.Errors
-      Unison.Server.QueryResult
-      Unison.Server.SearchResult
-      Unison.Server.SearchResult'
-      Unison.Server.Syntax
-      Unison.Server.Types
       Unison.TermParser
       Unison.TermPrinter
       Unison.Typechecker
@@ -170,7 +155,6 @@ library
       Unison.Util.CyclicOrd
       Unison.Util.EnumContainers
       Unison.Util.Exception
-      Unison.Util.Find
       Unison.Util.Free
       Unison.Util.Logger
       Unison.Util.PinBoard

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -142,6 +142,7 @@ data Output v
   | TermAmbiguous (HQ.HashQualified Name) (Set Referent)
   | HashAmbiguous ShortHash (Set Referent)
   | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash)
+  | BadNamespace String String
   | BranchNotFound Path'
   | NameNotFound Path.HQSplit'
   | PatchNotFound Path.Split'
@@ -307,6 +308,7 @@ isFailure o = case o of
   TermAmbiguous {} -> True
   BranchHashAmbiguous {} -> True
   BadName {} -> True
+  BadNamespace {} -> True
   BranchNotFound {} -> True
   NameNotFound {} -> True
   PatchNotFound {} -> True

unison-cli/src/Unison/Codebase/TranscriptParser.hs

@@ -158,7 +158,7 @@ withTranscriptRunner ucmVersion configFile action = do
     withRuntime :: ((Runtime.Runtime Symbol -> m a) -> m a)
     withRuntime action =
       UnliftIO.bracket
-        (liftIO $ RTI.startRuntime RTI.UCM ucmVersion)
+        (liftIO $ RTI.startRuntime RTI.Persistent ucmVersion)
         (liftIO . Runtime.terminate)
         action
     withConfig :: forall a. ((Maybe Config -> m a) -> m a)

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -782,6 +782,8 @@ notifyUser dir o = case o of
         "The file "
           <> P.blue (P.shown name)
           <> " could not be loaded."
+  BadNamespace msg path ->
+    pure . P.warnCallout $ "Invalid namespace " <> P.blue (P.string path) <> ", " <> P.string msg
   BranchNotFound b ->
     pure . P.warnCallout $ "The namespace " <> P.blue (P.shown b) <> " doesn't exist."
   CreatedNewBranch path ->

unison-cli/unison/Main.hs

@@ -113,7 +113,7 @@ main = withCP65001 do
             )
       Run (RunFromSymbol mainName) args -> do
         getCodebaseOrExit mCodePathOption \(_, _, theCodebase) -> do
-          runtime <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate
+          runtime <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate
           withArgs args $ execute theCodebase runtime mainName
       Run (RunFromFile file mainName) args
         | not (isDotU file) -> PT.putPrettyLn $ P.callout "⚠️" "Files must have a .u extension."
@@ -123,7 +123,7 @@ main = withCP65001 do
             Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
             Right contents -> do
               getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
-                rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate
+                rt <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate
                 let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
                 launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes
       Run (RunFromPipe mainName) args -> do
@@ -132,7 +132,7 @@ main = withCP65001 do
           Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input."
           Right contents -> do
             getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
-              rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate
+              rt <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate
               let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
               launch
                 currentDir
@@ -208,7 +208,7 @@ main = withCP65001 do
         runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
       Launch isHeadless codebaseServerOpts downloadBase -> do
         getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do
-          runtime <- RTI.startRuntime RTI.UCM Version.gitDescribeWithDate
+          runtime <- RTI.startRuntime RTI.Persistent Version.gitDescribeWithDate
           Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do
             case isHeadless of
               Headless -> do

unison-share-api/package.yaml

@@ -17,6 +17,33 @@ dependencies:
   - bytestring
   - aeson
   - memory
+  - unison-util-relation
+  - unison-core1
+  - unison-prelude
+  - unison-parser-typechecker
+  - unison-pretty-printer
+  - lucid
+  - openapi3
+  - extra
+  - lens
+  - fuzzyfind
+  - filepath
+  - directory
+  - yaml
+  - errors
+  - servant-server
+  - servant-docs
+  - servant-openapi3
+  - mwc-random
+  - warp
+  - wai
+  - uri-encode
+  - http-types
+  - http-media
+  - NanoID
+  - utf8-string
+  - async
+  - regex-tdfa
 
 ghc-options:
   -Wall

unison-share-api/src/Unison/Server/Backend.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -126,6 +127,12 @@ listEntryName = \case
 
 data BackendError
   = NoSuchNamespace Path.Absolute
+  | -- Failed to parse path
+    BadNamespace
+      String
+      -- ^ error message
+      String
+      -- ^ namespace
   | CouldntExpandBranchHash ShortBranchHash
   | AmbiguousBranchHash ShortBranchHash (Set ShortBranchHash)
   | NoBranchForHash Branch.Hash
@@ -283,7 +290,7 @@ findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBr
   let ppe hqLen = PPE.fromNamesDecl hqLen printNames
 
       renderReadme ppe r = do
-        (_, _, doc) <- liftIO $ renderDoc ppe width runtime codebase (Referent.toReference r)
+        (_, _, doc) <- renderDoc ppe width runtime codebase (Referent.toReference r)
         pure doc
 
       -- allow any of these capitalizations
@@ -293,8 +300,8 @@ findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBr
         where
           lookup seg = R.lookupRan seg rel
           rel = Star3.d1 (Branch._terms (Branch.head namespaceBranch))
-   in do
-        hqLen <- liftIO $ Codebase.hashLength codebase
+   in liftIO $ do
+        hqLen <- Codebase.hashLength codebase
         traverse (renderReadme (ppe hqLen)) (Set.lookupMin readmes)
 
 isDoc :: Monad m => Codebase m Symbol Ann -> Referent -> m Bool

unison-share-api/src/Unison/Server/CodebaseServer.hs

@@ -12,6 +12,7 @@ import Control.Concurrent (newEmptyMVar, putMVar, readMVar)
 import Control.Concurrent.Async (race)
 import Control.Exception (ErrorCall (..), throwIO)
 import Control.Lens ((.~))
+import Control.Monad.Trans.Except
 import Data.Aeson ()
 import qualified Data.ByteString as Strict
 import Data.ByteString.Char8 (unpack)
@@ -26,6 +27,7 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import GHC.Generics ()
 import Network.HTTP.Media ((//), (/:))
+import Network.HTTP.Types (HeaderName)
 import Network.HTTP.Types.Status (ok200)
 import qualified Network.URI.Encode as URI
 import Network.Wai (responseLBS)
@@ -39,7 +41,10 @@ import Network.Wai.Handler.Warp
     withApplicationSettings,
   )
 import Servant
-  ( MimeRender (..),
+  ( Handler,
+    HasServer,
+    MimeRender (..),
+    ServerT,
     serve,
     throwError,
   )
@@ -63,12 +68,13 @@ import Servant.Docs
 import Servant.OpenApi (HasOpenApi (toOpenApi))
 import Servant.Server
   ( Application,
-    Handler,
+    Handler (Handler),
     Server,
     ServerError (..),
     Tagged (Tagged),
     err401,
     err404,
+    hoistServer,
   )
 import Servant.Server.StaticFiles (serveDirectoryWebApp)
 import System.Directory (canonicalizePath, doesFileExist)
@@ -80,6 +86,7 @@ import Unison.Codebase (Codebase)
 import qualified Unison.Codebase.Runtime as Rt
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
+import Unison.Server.Backend (Backend)
 import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind)
 import Unison.Server.Endpoints.GetDefinitions
   ( DefinitionsAPI,
@@ -88,7 +95,8 @@ import Unison.Server.Endpoints.GetDefinitions
 import qualified Unison.Server.Endpoints.NamespaceDetails as NamespaceDetails
 import qualified Unison.Server.Endpoints.NamespaceListing as NamespaceListing
 import qualified Unison.Server.Endpoints.Projects as Projects
-import Unison.Server.Types (mungeString)
+import Unison.Server.Errors (backendError)
+import Unison.Server.Types (mungeString, setCacheControl)
 import Unison.Symbol (Symbol)
 
 -- HTML content type
@@ -104,7 +112,7 @@ instance MimeRender HTML RawHtml where
 
 type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi
 
-type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw
+type UnisonAndDocsAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw
 
 type UnisonAPI =
   NamespaceListing.NamespaceListingAPI
@@ -115,9 +123,13 @@ type UnisonAPI =
 
 type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml
 
-type ServerAPI = ("ui" :> WebUI) :<|> ("api" :> DocAPI)
+type ServerAPI = ("ui" :> WebUI) :<|> ("api" :> UnisonAndDocsAPI)
 
-type AuthedServerAPI = ("static" :> Raw) :<|> (Capture "token" Text :> ServerAPI)
+type StaticAPI = "static" :> Raw
+
+type Authed api = (Capture "token" Text :> api)
+
+type AppAPI = StaticAPI :<|> Authed ServerAPI
 
 instance ToSample Char where
   toSamples _ = singleSample 'x'
@@ -173,15 +185,18 @@ docsBS = mungeString . markdown $ docsWithIntros [intro] api
         (Text.unpack $ _infoTitle infoObject)
         (toList $ Text.unpack <$> _infoDescription infoObject)
 
-docAPI :: Proxy DocAPI
-docAPI = Proxy
+unisonAndDocsAPI :: Proxy UnisonAndDocsAPI
+unisonAndDocsAPI = Proxy
 
 api :: Proxy UnisonAPI
 api = Proxy
 
-serverAPI :: Proxy AuthedServerAPI
+serverAPI :: Proxy ServerAPI
 serverAPI = Proxy
 
+appAPI :: Proxy AppAPI
+appAPI = Proxy
+
 app ::
   Rt.Runtime Symbol ->
   Codebase IO Symbol Ann ->
@@ -189,9 +204,9 @@ app ::
   Strict.ByteString ->
   Application
 app rt codebase uiPath expectedToken =
-  serve serverAPI $ server rt codebase uiPath expectedToken
+  serve appAPI $ server rt codebase uiPath expectedToken
 
--- The Token is used to help prevent multiple users on a machine gain access to
+-- | The Token is used to help prevent multiple users on a machine gain access to
 -- each others codebases.
 genToken :: IO Strict.ByteString
 genToken = do
@@ -285,31 +300,52 @@ serveIndex path = do
                   <> " environment variable to the directory where the UI is installed."
           }
 
-serveUI :: Handler () -> FilePath -> Server WebUI
-serveUI tryAuth path _ = tryAuth *> serveIndex path
+serveUI :: FilePath -> Server WebUI
+serveUI path _ = serveIndex path
 
 server ::
   Rt.Runtime Symbol ->
   Codebase IO Symbol Ann ->
   FilePath ->
   Strict.ByteString ->
-  Server AuthedServerAPI
-server rt codebase uiPath token =
+  Server AppAPI
+server rt codebase uiPath expectedToken =
   serveDirectoryWebApp (uiPath </> "static")
-    :<|> ( \token ->
-             serveUI (tryAuth token) uiPath
-               :<|> unisonApi token
-               :<|> serveOpenAPI
-               :<|> Tagged serveDocs
-         )
+    :<|> hoistWithAuth serverAPI expectedToken serveServer
   where
-    serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS
-    serveOpenAPI = pure openAPI
+    serveServer :: Server ServerAPI
+    serveServer =
+      ( serveUI uiPath
+          :<|> serveUnisonAndDocs rt codebase
+      )
+
+serveUnisonAndDocs :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Server UnisonAndDocsAPI
+serveUnisonAndDocs rt codebase = serveUnison codebase rt :<|> serveOpenAPI :<|> Tagged serveDocs
+
+serveDocs :: Application
+serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS
+  where
+    plain :: (HeaderName, ByteString)
     plain = ("Content-Type", "text/plain")
-    tryAuth = handleAuth token
-    unisonApi t =
-      NamespaceListing.serve (tryAuth t) codebase
-        :<|> NamespaceDetails.serve (tryAuth t) rt codebase
-        :<|> Projects.serve (tryAuth t) codebase
-        :<|> serveDefinitions (tryAuth t) rt codebase
-        :<|> serveFuzzyFind (tryAuth t) codebase
+
+serveOpenAPI :: Handler OpenApi
+serveOpenAPI = pure openAPI
+
+hoistWithAuth :: forall api. HasServer api '[] => Proxy api -> ByteString -> ServerT api Handler -> ServerT (Authed api) Handler
+hoistWithAuth api expectedToken server token = hoistServer @api @Handler @Handler api (\h -> handleAuth expectedToken token *> h) server
+
+serveUnison ::
+  Codebase IO Symbol Ann ->
+  Rt.Runtime Symbol ->
+  Server UnisonAPI
+serveUnison codebase rt =
+  hoistServer (Proxy @UnisonAPI) backendHandler $
+    (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase root rel name)
+      :<|> (\namespaceName mayRoot mayWidth -> setCacheControl <$> NamespaceDetails.serve rt codebase namespaceName mayRoot mayWidth)
+      :<|> (\mayRoot mayOwner -> setCacheControl <$> Projects.serve codebase mayRoot mayOwner)
+      :<|> (\mayRoot relativePath rawHqns width suff -> setCacheControl <$> serveDefinitions rt codebase mayRoot relativePath rawHqns width suff)
+      :<|> (\mayRoot relativePath limit typeWidth query -> setCacheControl <$> serveFuzzyFind codebase mayRoot relativePath limit typeWidth query)
+
+backendHandler :: Backend IO a -> Handler a
+backendHandler m =
+  Handler $ withExceptT backendError m

unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs

@@ -10,13 +10,12 @@
 
 module Unison.Server.Endpoints.FuzzyFind where
 
-import Control.Error (runExceptT)
+import Control.Monad.Except
 import Data.Aeson (ToJSON (toEncoding), defaultOptions, genericToEncoding)
 import Data.OpenApi (ToSchema)
 import qualified Data.Text as Text
 import Servant
   ( QueryParam,
-    throwError,
     (:>),
   )
 import Servant.Docs
@@ -27,7 +26,6 @@ import Servant.Docs
     noSamples,
   )
 import Servant.OpenApi ()
-import Servant.Server (Handler)
 import qualified Text.FuzzyFind as FZF
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase as Codebase
@@ -41,18 +39,12 @@ import Unison.NameSegment
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import qualified Unison.Server.Backend as Backend
-import Unison.Server.Errors
-  ( backendError,
-    badNamespace,
-  )
 import Unison.Server.Syntax (SyntaxText)
 import Unison.Server.Types
   ( APIGet,
-    APIHeaders,
     HashQualifiedName,
     NamedTerm,
     NamedType,
-    addHeaders,
     mayDefaultWidth,
   )
 import Unison.Symbol (Symbol)
@@ -134,22 +126,22 @@ instance ToSample FoundResult where
   toSamples _ = noSamples
 
 serveFuzzyFind ::
-  Handler () ->
-  Codebase IO Symbol Ann ->
+  forall m.
+  MonadIO m =>
+  Codebase m Symbol Ann ->
   Maybe SBH.ShortBranchHash ->
   Maybe HashQualifiedName ->
   Maybe Int ->
   Maybe Width ->
   Maybe String ->
-  Handler (APIHeaders [(FZF.Alignment, FoundResult)])
-serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
-  addHeaders <$> do
-    h
+  Backend.Backend m [(FZF.Alignment, FoundResult)]
+serveFuzzyFind codebase mayRoot relativePath limit typeWidth query =
+  do
     rel <-
       maybe mempty Path.fromPath'
         <$> traverse (parsePath . Text.unpack) relativePath
-    hashLength <- liftIO $ Codebase.hashLength codebase
-    ea <- liftIO . runExceptT $ do
+    hashLength <- lift $ Codebase.hashLength codebase
+    ea <- lift . runExceptT $ do
       root <- traverse (Backend.expandShortBranchHash codebase) mayRoot
       branch <- Backend.resolveBranchHash root codebase
       let b0 = Branch.head branch
@@ -157,10 +149,10 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
             take (fromMaybe 10 limit) $ Backend.fuzzyFind rel branch (fromMaybe "" query)
           -- Use AllNames to render source
           ppe = Backend.basicSuffixifiedNames hashLength branch (Backend.AllNames rel)
-      liftIO (join <$> traverse (loadEntry root (Just rel) ppe b0) alignments)
-    errFromEither backendError ea
+      lift (join <$> traverse (loadEntry ppe b0) alignments)
+    liftEither ea
   where
-    loadEntry _root _rel ppe b0 (a, HQ'.NameOnly . NameSegment -> n, refs) =
+    loadEntry ppe b0 (a, HQ'.NameOnly . NameSegment -> n, refs) =
       for refs $
         \case
           Backend.FoundTermRef r ->
@@ -181,5 +173,5 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
             let ft = FoundType typeName typeHeader namedType
             pure (a, FoundTypeResult ft)
 
-    parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
+    parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p
     errFromEither f = either (throwError . f) pure

unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs

@@ -6,12 +6,11 @@
 
 module Unison.Server.Endpoints.GetDefinitions where
 
-import Control.Error (runExceptT)
+import Control.Monad.Except
 import qualified Data.Text as Text
 import Servant
   ( QueryParam,
     QueryParams,
-    throwError,
     (:>),
   )
 import Servant.Docs
@@ -21,7 +20,6 @@ import Servant.Docs
     ToSample (..),
     noSamples,
   )
-import Servant.Server (Handler)
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.Path.Parse as Path
@@ -33,18 +31,12 @@ import qualified Unison.HashQualified as HQ
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import qualified Unison.Server.Backend as Backend
-import Unison.Server.Errors
-  ( backendError,
-    badNamespace,
-  )
 import Unison.Server.Types
   ( APIGet,
-    APIHeaders,
     DefinitionDisplayResults,
     HashQualifiedName,
     NamespaceFQN,
     Suffixify (..),
-    addHeaders,
     defaultWidth,
   )
 import Unison.Symbol (Symbol)
@@ -113,7 +105,7 @@ instance ToSample DefinitionDisplayResults where
   toSamples _ = noSamples
 
 serveDefinitions ::
-  Handler () ->
+  MonadIO m =>
   Rt.Runtime Symbol ->
   Codebase IO Symbol Ann ->
   Maybe ShortBranchHash ->
@@ -121,10 +113,9 @@ serveDefinitions ::
   [HashQualifiedName] ->
   Maybe Width ->
   Maybe Suffixify ->
-  Handler (APIHeaders DefinitionDisplayResults)
-serveDefinitions h rt codebase mayRoot relativePath rawHqns width suff =
-  addHeaders <$> do
-    h
+  Backend.Backend m DefinitionDisplayResults
+serveDefinitions rt codebase mayRoot relativePath rawHqns width suff =
+  do
     rel <-
       fmap Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath
     ea <- liftIO . runExceptT $ do
@@ -143,7 +134,7 @@ serveDefinitions h rt codebase mayRoot relativePath rawHqns width suff =
         rt
         codebase
         hqns
-    errFromEither backendError ea
+    liftEither ea
   where
-    parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
+    parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p
     errFromEither f = either (throwError . f) pure

unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs

@@ -9,14 +9,13 @@
 
 module Unison.Server.Endpoints.NamespaceDetails where
 
-import Control.Error (runExceptT)
+import Control.Monad.Except
 import Data.Aeson
 import Data.OpenApi (ToSchema)
 import qualified Data.Text as Text
-import Servant (Capture, QueryParam, throwError, (:>))
+import Servant (Capture, QueryParam, (:>))
 import Servant.Docs (DocCapture (..), ToCapture (..), ToSample (..))
 import Servant.OpenApi ()
-import Servant.Server (Handler)
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase.Branch as Branch
 import qualified Unison.Codebase.Path as Path
@@ -25,16 +24,14 @@ import qualified Unison.Codebase.Runtime as Rt
 import Unison.Codebase.ShortBranchHash (ShortBranchHash)
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
+import Unison.Server.Backend
 import qualified Unison.Server.Backend as Backend
 import Unison.Server.Doc (Doc)
-import Unison.Server.Errors (backendError, badNamespace)
 import Unison.Server.Types
   ( APIGet,
-    APIHeaders,
     NamespaceFQN,
     UnisonHash,
     UnisonName,
-    addHeaders,
     branchToUnisonHash,
     mayDefaultWidth,
   )
@@ -77,30 +74,25 @@ instance ToJSON NamespaceDetails where
 deriving instance ToSchema NamespaceDetails
 
 serve ::
-  Handler () ->
   Rt.Runtime Symbol ->
   Codebase IO Symbol Ann ->
   NamespaceFQN ->
   Maybe ShortBranchHash ->
   Maybe Width ->
-  Handler (APIHeaders NamespaceDetails)
-serve tryAuth runtime codebase namespaceName mayRoot mayWidth =
-  let doBackend a = do
-        ea <- liftIO $ runExceptT a
-        errFromEither backendError ea
-
-      errFromEither f = either (throwError . f) pure
+  Backend IO NamespaceDetails
+serve runtime codebase namespaceName mayRoot mayWidth =
+  let errFromEither f = either (throwError . f) pure
 
       fqnToPath fqn = do
         let fqnS = Text.unpack fqn
-        path' <- errFromEither (`badNamespace` fqnS) $ parsePath' fqnS
+        path' <- errFromEither (`Backend.BadNamespace` fqnS) $ parsePath' fqnS
         pure (Path.fromPath' path')
 
       width = mayDefaultWidth mayWidth
    in do
         namespacePath <- fqnToPath namespaceName
 
-        namespaceDetails <- doBackend $ do
+        namespaceDetails <- do
           root <- Backend.resolveRootBranchHash mayRoot codebase
 
           let namespaceBranch = Branch.getAt' namespacePath root
@@ -120,4 +112,4 @@ serve tryAuth runtime codebase namespaceName mayRoot mayWidth =
 
           pure $ NamespaceDetails namespaceName (branchToUnisonHash namespaceBranch) readme
 
-        addHeaders <$> (tryAuth $> namespaceDetails)
+        pure $ namespaceDetails

unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs

@@ -9,14 +9,13 @@
 
 module Unison.Server.Endpoints.NamespaceListing where
 
-import Control.Error (runExceptT)
 import Control.Error.Util ((??))
+import Control.Monad.Except
 import Data.Aeson
 import Data.OpenApi (ToSchema)
 import qualified Data.Text as Text
 import Servant
   ( QueryParam,
-    throwError,
     (:>),
   )
 import Servant.Docs
@@ -26,7 +25,6 @@ import Servant.Docs
     ToSample (..),
   )
 import Servant.OpenApi ()
-import Servant.Server (Handler)
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase as Codebase
 import qualified Unison.Codebase.Branch as Branch
@@ -39,13 +37,8 @@ import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
 import qualified Unison.Server.Backend as Backend
-import Unison.Server.Errors
-  ( backendError,
-    badNamespace,
-  )
 import Unison.Server.Types
   ( APIGet,
-    APIHeaders,
     HashQualifiedName,
     NamedTerm (..),
     NamedType (..),
@@ -53,7 +46,6 @@ import Unison.Server.Types
     Size,
     UnisonHash,
     UnisonName,
-    addHeaders,
     branchToUnisonHash,
   )
 import Unison.Symbol (Symbol)
@@ -156,19 +148,18 @@ backendListEntryToNamespaceObject ppe typeWidth = \case
     PatchObject . NamedPatch $ NameSegment.toText name
 
 serve ::
-  Handler () ->
   Codebase IO Symbol Ann ->
   Maybe ShortBranchHash ->
   Maybe NamespaceFQN ->
   Maybe NamespaceFQN ->
-  Handler (APIHeaders NamespaceListing)
-serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName =
+  Backend.Backend IO NamespaceListing
+serve codebase mayRoot mayRelativeTo mayNamespaceName =
   let -- Various helpers
       errFromEither f = either (throwError . f) pure
 
-      parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
+      parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p
 
-      findShallow branch = liftIO $ Backend.findShallowInBranch codebase branch
+      findShallow branch = Backend.findShallowInBranch codebase branch
 
       makeNamespaceListing ppe fqn hash entries =
         pure . NamespaceListing fqn hash $
@@ -179,13 +170,13 @@ serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName =
       -- Lookup paths, root and listing and construct response
       namespaceListing = do
         root <- case mayRoot of
-          Nothing -> liftIO $ Codebase.getRootBranch codebase
+          Nothing -> lift (Codebase.getRootBranch codebase)
           Just sbh -> do
             ea <- liftIO . runExceptT $ do
               h <- Backend.expandShortBranchHash codebase sbh
               mayBranch <- lift $ Codebase.getBranchForHash codebase h
               mayBranch ?? Backend.CouldntLoadBranch h
-            errFromEither backendError ea
+            liftEither ea
 
         -- Relative and Listing Path resolution
         --
@@ -214,7 +205,7 @@ serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName =
         let shallowPPE = Backend.basicSuffixifiedNames hashLength root $ (Backend.Within $ Path.fromPath' path')
         let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path'
         let listingHash = branchToUnisonHash listingBranch
-        listingEntries <- findShallow listingBranch
+        listingEntries <- lift (findShallow listingBranch)
 
         makeNamespaceListing shallowPPE listingFQN listingHash listingEntries
-   in addHeaders <$> (tryAuth *> namespaceListing)
+   in namespaceListing

unison-share-api/src/Unison/Server/Endpoints/Projects.hs

@@ -8,8 +8,8 @@
 
 module Unison.Server.Endpoints.Projects where
 
-import Control.Error (runExceptT)
 import Control.Error.Util ((??))
+import Control.Monad.Except
 import Data.Aeson
 import Data.Char
 import Data.OpenApi
@@ -17,7 +17,7 @@ import Data.OpenApi
     ToSchema (..),
   )
 import qualified Data.Text as Text
-import Servant (QueryParam, ServerError, throwError, (:>))
+import Servant (QueryParam, (:>))
 import Servant.API (FromHttpApiData (..))
 import Servant.Docs
   ( DocQueryParam (..),
@@ -25,7 +25,6 @@ import Servant.Docs
     ToParam (..),
     ToSample (..),
   )
-import Servant.Server (Handler)
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase as Codebase
 import qualified Unison.Codebase.Branch as Branch
@@ -36,9 +35,9 @@ import qualified Unison.Codebase.ShortBranchHash as SBH
 import qualified Unison.NameSegment as NameSegment
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
+import Unison.Server.Backend
 import qualified Unison.Server.Backend as Backend
-import Unison.Server.Errors (backendError, badNamespace)
-import Unison.Server.Types (APIGet, APIHeaders, UnisonHash, addHeaders)
+import Unison.Server.Types (APIGet, UnisonHash)
 import Unison.Symbol (Symbol)
 import Unison.Util.Monoid (foldMapM)
 
@@ -122,24 +121,24 @@ entryToOwner = \case
   _ -> Nothing
 
 serve ::
-  Handler () ->
-  Codebase IO Symbol Ann ->
+  forall m.
+  MonadIO m =>
+  Codebase m Symbol Ann ->
   Maybe ShortBranchHash ->
   Maybe ProjectOwner ->
-  Handler (APIHeaders [ProjectListing])
-serve tryAuth codebase mayRoot mayOwner = addHeaders <$> (tryAuth *> projects)
+  Backend m [ProjectListing]
+serve codebase mayRoot mayOwner = projects
   where
-    projects :: Handler [ProjectListing]
+    projects :: Backend m [ProjectListing]
     projects = do
       root <- case mayRoot of
-        Nothing ->
-          liftIO $ Codebase.getRootBranch codebase
+        Nothing -> lift (Codebase.getRootBranch codebase)
         Just sbh -> do
-          ea <- liftIO . runExceptT $ do
+          ea <- lift . runExceptT $ do
             h <- Backend.expandShortBranchHash codebase sbh
             mayBranch <- lift $ Codebase.getBranchForHash codebase h
             mayBranch ?? Backend.CouldntLoadBranch h
-          errFromEither backendError ea
+          liftEither ea
 
       ownerEntries <- findShallow root
       -- If an owner is provided, we only want projects belonging to them
@@ -149,7 +148,7 @@ serve tryAuth codebase mayRoot mayOwner = addHeaders <$> (tryAuth *> projects)
               Nothing -> mapMaybe entryToOwner ownerEntries
       foldMapM (ownerToProjectListings root) owners
 
-    ownerToProjectListings :: Branch.Branch IO -> ProjectOwner -> Handler [ProjectListing]
+    ownerToProjectListings :: Branch.Branch m -> ProjectOwner -> Backend m [ProjectListing]
     ownerToProjectListings root owner = do
       let (ProjectOwner ownerName) = owner
       ownerPath' <- (parsePath . Text.unpack) ownerName
@@ -160,14 +159,14 @@ serve tryAuth codebase mayRoot mayOwner = addHeaders <$> (tryAuth *> projects)
 
     -- Minor helpers
 
-    findShallow :: Branch.Branch IO -> Handler [Backend.ShallowListEntry Symbol Ann]
+    findShallow :: Branch.Branch m -> Backend m [Backend.ShallowListEntry Symbol Ann]
     findShallow branch =
-      liftIO $ Backend.findShallowInBranch codebase branch
+      lift (Backend.findShallowInBranch codebase branch)
 
-    parsePath :: String -> Handler Path.Path'
+    parsePath :: String -> Backend m Path.Path'
     parsePath p =
-      errFromEither (`badNamespace` p) $ Path.parsePath' p
+      errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p
 
-    errFromEither :: (a -> ServerError) -> Either a a1 -> Handler a1
+    errFromEither :: (e -> BackendError) -> Either e a -> Backend m a
     errFromEither f =
       either (throwError . f) pure

unison-share-api/src/Unison/Server/Errors.hs

@@ -35,6 +35,7 @@ backendError :: Backend.BackendError -> ServerError
 backendError = \case
   Backend.NoSuchNamespace n ->
     noSuchNamespace . Path.toText $ Path.unabsolute n
+  Backend.BadNamespace err namespace -> badNamespace err namespace
   Backend.NoBranchForHash h ->
     noSuchNamespace . Text.toStrict . Text.pack $ show h
   Backend.CouldntLoadBranch h ->

unison-share-api/src/Unison/Server/Types.hs

@@ -259,8 +259,8 @@ discard = const $ pure ()
 mayDefaultWidth :: Maybe Width -> Width
 mayDefaultWidth = fromMaybe defaultWidth
 
-addHeaders :: v -> APIHeaders v
-addHeaders = addHeader "public"
+setCacheControl :: v -> APIHeaders v
+setCacheControl = addHeader @"Cache-Control" "public"
 
 branchToUnisonHash :: Branch.Branch m -> UnisonHash
 branchToUnisonHash b =

unison-share-api/unison-share-api.cabal

@@ -17,8 +17,24 @@ source-repository head
 
 library
   exposed-modules:
+      Unison.Server.Backend
+      Unison.Server.CodebaseServer
+      Unison.Server.Doc
+      Unison.Server.Doc.AsHtml
+      Unison.Server.Endpoints.FuzzyFind
+      Unison.Server.Endpoints.GetDefinitions
+      Unison.Server.Endpoints.NamespaceDetails
+      Unison.Server.Endpoints.NamespaceListing
+      Unison.Server.Endpoints.Projects
+      Unison.Server.Errors
+      Unison.Server.QueryResult
+      Unison.Server.SearchResult
+      Unison.Server.SearchResult'
+      Unison.Server.Syntax
+      Unison.Server.Types
       Unison.Sync.API
       Unison.Sync.Types
+      Unison.Util.Find
   other-modules:
       Paths_unison_share_api
   hs-source-dirs:
@@ -50,15 +66,42 @@ library
       ViewPatterns
   ghc-options: -Wall
   build-depends:
-      aeson
+      NanoID
+    , aeson
+    , async
     , base
     , bytestring
     , containers
+    , directory
+    , errors
+    , extra
+    , filepath
+    , fuzzyfind
+    , http-media
+    , http-types
+    , lens
+    , lucid
     , memory
     , mtl
+    , mwc-random
     , nonempty-containers
+    , openapi3
+    , regex-tdfa
     , servant
+    , servant-docs
+    , servant-openapi3
+    , servant-server
     , text
     , transformers
+    , unison-core1
+    , unison-parser-typechecker
+    , unison-prelude
+    , unison-pretty-printer
+    , unison-util-relation
     , unliftio
+    , uri-encode
+    , utf8-string
+    , wai
+    , warp
+    , yaml
   default-language: Haskell2010