Codebase Server: Add /projects endpoint

Add a new API endpoint: `/projects` that (for now) compiles a list of
"projects" by finding each namespace on the second level of the codebase
tree, and considers its parent namespace (on the first level), its
owner.

parser-typechecker/src/Unison/Server/CodebaseServer.hs

@@ -1,9 +1,8 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -11,15 +10,15 @@ module Unison.Server.CodebaseServer where
 
 import Control.Concurrent (newEmptyMVar, putMVar, readMVar)
 import Control.Concurrent.Async (race)
-import Data.ByteString.Char8 (unpack)
 import Control.Exception (ErrorCall (..), throwIO)
-import qualified Network.URI.Encode as URI
 import Control.Lens ((.~))
 import Data.Aeson ()
 import qualified Data.ByteString as Strict
+import Data.ByteString.Char8 (unpack)
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy.UTF8 as BLU
+import Data.NanoID (customNanoID, defaultAlphabet, unNanoID)
 import Data.OpenApi (Info (..), License (..), OpenApi, URL (..))
 import qualified Data.OpenApi.Lens as OpenApi
 import Data.Proxy (Proxy (..))
@@ -27,8 +26,8 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import GHC.Generics ()
 import Network.HTTP.Media ((//), (/:))
-import Data.NanoID (customNanoID, defaultAlphabet, unNanoID)
 import Network.HTTP.Types.Status (ok200)
+import qualified Network.URI.Encode as URI
 import Network.Wai (responseLBS)
 import Network.Wai.Handler.Warp
   ( Port,
@@ -88,13 +87,14 @@ 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.Var (Var)
 
 -- HTML content type
 data HTML = HTML
 
-newtype RawHtml = RawHtml { unRaw :: Lazy.ByteString }
+newtype RawHtml = RawHtml {unRaw :: Lazy.ByteString}
 
 instance Accept HTML where
   contentType _ = "text" // "html" /: ("charset", "utf-8")
@@ -109,10 +109,10 @@ type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw
 type UnisonAPI =
   NamespaceListing.NamespaceListingAPI
     :<|> NamespaceDetails.NamespaceDetailsAPI
+    :<|> Projects.ProjectsAPI
     :<|> DefinitionsAPI
     :<|> FuzzyFindAPI
 
-
 type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml
 
 type ServerAPI = ("ui" :> WebUI) :<|> ("api" :> DocAPI)
@@ -141,32 +141,37 @@ urlFor path baseUrl =
     UI -> show baseUrl <> "/ui"
     Api -> show baseUrl <> "/api"
 
-
 handleAuth :: Strict.ByteString -> Text -> Handler ()
 handleAuth expectedToken gotToken =
   if Text.decodeUtf8 expectedToken == gotToken
     then pure ()
     else throw401 "Authentication token missing or incorrect."
-  where throw401 msg = throwError $ err401 { errBody = msg }
+  where
+    throw401 msg = throwError $ err401 {errBody = msg}
 
 openAPI :: OpenApi
 openAPI = toOpenApi api & OpenApi.info .~ infoObject
 
 infoObject :: Info
-infoObject = mempty
-  { _infoTitle       = "Unison Codebase Manager API"
-  , _infoDescription =
-    Just "Provides operations for querying and manipulating a Unison codebase."
-  , _infoLicense     = Just . License "MIT" . Just $ URL
-                         "https://github.com/unisonweb/unison/blob/trunk/LICENSE"
-  , _infoVersion     = "1.0"
-  }
+infoObject =
+  mempty
+    { _infoTitle = "Unison Codebase Manager API",
+      _infoDescription =
+        Just "Provides operations for querying and manipulating a Unison codebase.",
+      _infoLicense =
+        Just . License "MIT" . Just $
+          URL
+            "https://github.com/unisonweb/unison/blob/trunk/LICENSE",
+      _infoVersion = "1.0"
+    }
 
 docsBS :: Lazy.ByteString
 docsBS = mungeString . markdown $ docsWithIntros [intro] api
- where
-  intro = DocIntro (Text.unpack $ _infoTitle infoObject)
-                   (toList $ Text.unpack <$> _infoDescription infoObject)
+  where
+    intro =
+      DocIntro
+        (Text.unpack $ _infoTitle infoObject)
+        (toList $ Text.unpack <$> _infoDescription infoObject)
 
 docAPI :: Proxy DocAPI
 docAPI = Proxy
@@ -177,13 +182,13 @@ api = Proxy
 serverAPI :: Proxy AuthedServerAPI
 serverAPI = Proxy
 
-app
-  :: Var v
-  => Rt.Runtime v
-  -> Codebase IO v Ann
-  -> FilePath
-  -> Strict.ByteString
-  -> Application
+app ::
+  Var v =>
+  Rt.Runtime v ->
+  Codebase IO v Ann ->
+  FilePath ->
+  Strict.ByteString ->
+  Application
 app rt codebase uiPath expectedToken =
   serve serverAPI $ server rt codebase uiPath expectedToken
 
@@ -195,19 +200,19 @@ genToken = do
   n <- customNanoID defaultAlphabet 16 g
   pure $ unNanoID n
 
-data Waiter a
-  = Waiter {
-    notify :: a -> IO (),
+data Waiter a = Waiter
+  { notify :: a -> IO (),
     waitFor :: IO a
   }
 
 mkWaiter :: IO (Waiter a)
 mkWaiter = do
   mvar <- newEmptyMVar
-  return Waiter {
-    notify = putMVar mvar,
-    waitFor = readMVar mvar
-  }
+  return
+    Waiter
+      { notify = putMVar mvar,
+        waitFor = readMVar mvar
+      }
 
 ucmUIVar :: String
 ucmUIVar = "UCM_WEB_UI"
@@ -222,42 +227,46 @@ ucmTokenVar :: String
 ucmTokenVar = "UCM_TOKEN"
 
 data CodebaseServerOpts = CodebaseServerOpts
-  { token :: Maybe String
-  , host :: Maybe String
-  , port :: Maybe Int
-  , codebaseUIPath :: Maybe FilePath
-  } deriving (Show, Eq)
+  { token :: Maybe String,
+    host :: Maybe String,
+    port :: Maybe Int,
+    codebaseUIPath :: Maybe FilePath
+  }
+  deriving (Show, Eq)
 
 -- The auth token required for accessing the server is passed to the function k
-startServer
-  :: Var v
-  => CodebaseServerOpts
-  -> Rt.Runtime v
-  -> Codebase IO v Ann
-  -> (BaseUrl -> IO ())
-  -> IO ()
+startServer ::
+  Var v =>
+  CodebaseServerOpts ->
+  Rt.Runtime v ->
+  Codebase IO v Ann ->
+  (BaseUrl -> IO ()) ->
+  IO ()
 startServer opts rt codebase onStart = do
   -- the `canonicalizePath` resolves symlinks
   exePath <- canonicalizePath =<< getExecutablePath
   envUI <- canonicalizePath $ fromMaybe (FilePath.takeDirectory exePath </> "ui") (codebaseUIPath opts)
   token <- case token opts of
     Just t -> return $ C8.pack t
-    _      -> genToken
+    _ -> genToken
   let baseUrl = BaseUrl "http://127.0.0.1" token
-  let settings = defaultSettings
-               & maybe id setPort (port opts)
-               & maybe id (setHost . fromString) (host opts)
+  let settings =
+        defaultSettings
+          & maybe id setPort (port opts)
+          & maybe id (setHost . fromString) (host opts)
   let a = app rt codebase envUI token
   case port opts of
     Nothing -> withApplicationSettings settings (pure a) (onStart . baseUrl)
-    Just p  -> do
+    Just p -> do
       started <- mkWaiter
       let settings' = setBeforeMainLoop (notify started ()) settings
-      result <- race (runSettings settings' a)
-                     (waitFor started *> onStart (baseUrl p))
+      result <-
+        race
+          (runSettings settings' a)
+          (waitFor started *> onStart (baseUrl p))
       case result of
-        Left  () -> throwIO $ ErrorCall "Server exited unexpectedly!"
-        Right x  -> pure x
+        Left () -> throwIO $ ErrorCall "Server exited unexpectedly!"
+        Right x -> pure x
 
 serveIndex :: FilePath -> Handler RawHtml
 serveIndex path = do
@@ -266,15 +275,17 @@ serveIndex path = do
   if exists
     then fmap RawHtml . liftIO . Lazy.readFile $ path </> "index.html"
     else fail
- where
-  fail = throwError $ err404
-    { errBody =
-      BLU.fromString
-      $  "No codebase UI configured."
-      <> " Set the "
-      <> ucmUIVar
-      <> " environment variable to the directory where the UI is installed."
-    }
+  where
+    fail =
+      throwError $
+        err404
+          { errBody =
+              BLU.fromString $
+                "No codebase UI configured."
+                  <> " Set the "
+                  <> ucmUIVar
+                  <> " environment variable to the directory where the UI is installed."
+          }
 
 serveUI :: Handler () -> FilePath -> Server WebUI
 serveUI tryAuth path _ = tryAuth *> serveIndex path
@@ -302,5 +313,6 @@ server rt codebase uiPath 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

parser-typechecker/src/Unison/Server/Endpoints/Projects.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Unison.Server.Endpoints.Projects where
+
+import Control.Error (runExceptT)
+import Control.Error.Util ((??))
+import Data.Aeson
+import Data.OpenApi (ToSchema)
+import qualified Data.Text as Text
+import Servant (QueryParam, throwError, (:>))
+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
+import qualified Unison.Codebase.Path as Path
+import qualified Unison.Codebase.Path.Parse as Path
+import Unison.Codebase.ShortBranchHash (ShortBranchHash)
+import qualified Unison.Codebase.ShortBranchHash as SBH
+import qualified Unison.NameSegment as NameSegment
+import Unison.Parser.Ann (Ann)
+import Unison.Prelude
+import qualified Unison.Server.Backend as Backend
+import Unison.Server.Errors (backendError, badNamespace, rootBranchError)
+import Unison.Server.Types (APIGet, APIHeaders, UnisonHash, addHeaders)
+import Unison.Var (Var)
+
+type ProjectsAPI =
+  "projects" :> QueryParam "rootBranch" ShortBranchHash
+    :> APIGet [ProjectListing]
+
+instance ToSample ProjectListing where
+  toSamples _ =
+    [ ( "Projects in the root branch",
+        ProjectListing
+          (ProjectOwner "unison")
+          "base"
+          "#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5"
+      )
+    ]
+
+data ProjectOwner = ProjectOwner Text deriving (Generic, Show)
+
+instance ToJSON ProjectOwner where
+  toEncoding = genericToEncoding defaultOptions
+
+deriving instance ToSchema ProjectOwner
+
+data ProjectListing = ProjectListing
+  { owner :: ProjectOwner,
+    name :: Text,
+    hash :: UnisonHash
+  }
+  deriving (Generic, Show)
+
+instance ToJSON ProjectListing where
+  toEncoding = genericToEncoding defaultOptions
+
+deriving instance ToSchema ProjectListing
+
+backendListEntryToProjectListing ::
+  Var v =>
+  ProjectOwner ->
+  Backend.ShallowListEntry v a ->
+  Maybe ProjectListing
+backendListEntryToProjectListing owner = \case
+  Backend.ShallowBranchEntry name hash _ ->
+    Just $
+      ProjectListing
+        { owner = owner,
+          name = NameSegment.toText name,
+          hash = "#" <> SBH.toText hash
+        }
+  _ -> Nothing
+
+entryToOwner ::
+  Var v =>
+  Backend.ShallowListEntry v a ->
+  Maybe ProjectOwner
+entryToOwner = \case
+  Backend.ShallowBranchEntry name _ _ ->
+    Just $ ProjectOwner $ NameSegment.toText name
+  _ -> Nothing
+
+serve ::
+  Var v =>
+  Handler () ->
+  Codebase IO v Ann ->
+  Maybe ShortBranchHash ->
+  Handler (APIHeaders [ProjectListing])
+serve tryAuth codebase mayRoot =
+  let errFromEither f = either (throwError . f) pure
+
+      doBackend a = do
+        ea <- liftIO $ runExceptT a
+        errFromEither backendError ea
+
+      findShallow branch = doBackend $ Backend.findShallowInBranch codebase branch
+
+      parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
+
+      ownerToProjectListings root owner = do
+        let (ProjectOwner ownerName) = owner
+        ownerPath' <- (parsePath . Text.unpack) ownerName
+        let path = Path.fromPath' ownerPath'
+        let ownerBranch = Branch.getAt' path root
+        entries <- findShallow ownerBranch
+        pure $ mapMaybe (backendListEntryToProjectListing owner) entries
+
+      projects = do
+        root <- case mayRoot of
+          Nothing -> do
+            gotRoot <- liftIO $ Codebase.getRootBranch codebase
+            errFromEither rootBranchError gotRoot
+          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
+
+        ownerEntries <- findShallow root
+        let owners = mapMaybe entryToOwner ownerEntries
+        fmap join (traverse (ownerToProjectListings root) owners)
+   in addHeaders <$> (tryAuth *> projects)

parser-typechecker/unison-parser-typechecker.cabal

@@ -122,6 +122,7 @@ library
       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