Add cache-control header

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -6,26 +8,20 @@
 
 module Unison.Server.CodebaseServer where
 
-import Control.Applicative
 import Control.Concurrent (newEmptyMVar, putMVar, readMVar)
 import Control.Concurrent.Async (race)
 import Control.Exception (ErrorCall (..), throwIO)
 import Control.Lens ((&), (.~))
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson ()
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy.UTF8 as BLU
-import Data.Foldable (Foldable (toList))
-import Data.Maybe (fromMaybe)
 import Data.Monoid (Endo (..), appEndo)
 import Data.OpenApi (Info (..), License (..), OpenApi, URL (..))
 import qualified Data.OpenApi.Lens as OpenApi
 import Data.Proxy (Proxy (..))
-import Data.String (fromString)
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import GHC.Generics ()
@@ -58,9 +54,7 @@ import Options.Applicative
     strOption,
   )
 import Servant
-  ( Header,
-    MimeRender (..),
-    addHeader,
+  ( MimeRender (..),
     serve,
     throwError,
   )
@@ -69,13 +63,18 @@ import Servant.API
     Capture,
     CaptureAll,
     Get,
-    Headers,
     JSON,
     Raw,
     (:>),
     type (:<|>) (..),
   )
-import Servant.Docs (DocIntro (DocIntro), docsWithIntros, markdown)
+import Servant.Docs
+  ( DocIntro (DocIntro),
+    ToSample (..),
+    docsWithIntros,
+    markdown,
+    singleSample,
+  )
 import Servant.OpenApi (HasOpenApi (toOpenApi))
 import Servant.Server
   ( Application,
@@ -87,14 +86,14 @@ import Servant.Server
     err404,
   )
 import Servant.Server.StaticFiles (serveDirectoryWebApp)
-import System.Directory (doesFileExist, canonicalizePath)
-import System.Environment (getArgs, lookupEnv, getExecutablePath)
+import System.Directory (canonicalizePath, doesFileExist)
+import System.Environment (getArgs, getExecutablePath, lookupEnv)
 import System.FilePath ((</>))
 import qualified System.FilePath as FilePath
 import System.Random.Stateful (getStdGen, newAtomicGenM, uniformByteStringM)
-import Text.Read (readMaybe)
 import Unison.Codebase (Codebase)
 import Unison.Parser (Ann)
+import Unison.Prelude
 import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind)
 import Unison.Server.Endpoints.GetDefinitions
   ( DefinitionsAPI,
@@ -115,8 +114,7 @@ instance Accept HTML where
 instance MimeRender HTML RawHtml where
   mimeRender _ = unRaw
 
-type OpenApiJSON = "openapi.json"
-  :> Get '[JSON] (Headers '[Header "Access-Control-Allow-Origin" String] OpenApi)
+type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi
 
 type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw
 
@@ -128,6 +126,9 @@ type ServerAPI = ("ui" :> WebUI) :<|> ("api" :> DocAPI)
 
 type AuthedServerAPI = ("static" :> Raw) :<|> (Capture "token" Text :> ServerAPI)
 
+instance ToSample Char where
+  toSamples _ = singleSample 'x'
+
 handleAuth :: Strict.ByteString -> Text -> Handler ()
 handleAuth expectedToken gotToken =
   if Text.decodeUtf8 expectedToken == gotToken
@@ -322,12 +323,12 @@ server codebase uiPath token =
                         :<|> (serveDefinitions (tryAuth t) codebase)
                         :<|> (serveFuzzyFind (tryAuth t) codebase)
                         )
-                   :<|> addHeader "*"
-                   <$>  serveOpenAPI
+                   :<|> serveOpenAPI
                    :<|> Tagged serveDocs
                    )
           )
          )
+
  where
   serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS
   serveOpenAPI = pure openAPI

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

@@ -10,58 +10,62 @@
 
 module Unison.Server.Endpoints.FuzzyFind where
 
-import           Control.Lens                   ( view, _1 )
-import           Control.Error                  ( runExceptT )
-import           Data.Function                  ( on )
-import           Data.Aeson
-import           Data.List                      ( sortBy )
-import           Data.Ord                       ( Down(..) )
-import           Data.OpenApi                   ( ToSchema )
-import           Servant                        ( Get
-                                                , JSON
-                                                , QueryParam
-                                                , throwError
-                                                , (:>)
-                                                )
-import           Servant.Docs                   ( DocQueryParam(..)
-                                                , ParamKind(Normal)
-                                                , ToParam(..)
-                                                , ToSample(..)
-                                                , noSamples
-                                                )
-import           Servant.OpenApi                ( )
-import           Servant.Server                 ( Handler )
-import           Unison.Prelude
-import           Unison.Codebase                ( Codebase )
-import qualified Unison.Codebase               as Codebase
-import qualified Unison.Codebase.Path          as Path
-import qualified Unison.HashQualified'         as HQ'
-import qualified Unison.HashQualified          as HQ
-import           Unison.Parser                  ( Ann )
-import qualified Unison.Server.Backend         as Backend
-import           Unison.Server.Errors           ( backendError
-                                                , badNamespace
-                                                )
-import           Unison.Server.Types            ( mayDefault
-                                                , HashQualifiedName
-                                                , NamedTerm
-                                                , NamedType
-                                                , DefinitionDisplayResults(..)
-                                                , TypeDefinition(..)
-                                                , Suffixify(..)
-                                                )
-import           Unison.Util.Pretty             ( Width )
-import           Unison.Var                     ( Var )
-import qualified Unison.Codebase.ShortBranchHash
-                                               as SBH
-import qualified Data.Text                     as Text
+import Control.Error (runExceptT)
+import Control.Lens (view, _1)
+import Data.Aeson
+import Data.Function (on)
+import Data.List (sortBy)
+import qualified Data.Map as Map
+import Data.OpenApi (ToSchema)
+import Data.Ord (Down (..))
+import qualified Data.Text as Text
+import Servant
+  ( QueryParam,
+    throwError,
+    (:>),
+  )
+import Servant.Docs
+  ( DocQueryParam (..),
+    ParamKind (Normal),
+    ToParam (..),
+    ToSample (..),
+    noSamples,
+  )
+import Servant.OpenApi ()
+import Servant.Server (Handler)
 import qualified Text.FuzzyFind as FZF
+import Unison.Codebase (Codebase)
+import qualified Unison.Codebase as Codebase
 import qualified Unison.Codebase.Branch as Branch
-import Unison.NameSegment
-import           Unison.Server.Syntax           ( SyntaxText )
-import qualified Unison.Reference              as Reference
-import qualified Data.Map                      as Map
 import Unison.Codebase.Editor.DisplayObject
+import qualified Unison.Codebase.Path as Path
+import qualified Unison.Codebase.ShortBranchHash as SBH
+import qualified Unison.HashQualified as HQ
+import qualified Unison.HashQualified' as HQ'
+import Unison.NameSegment
+import Unison.Parser (Ann)
+import Unison.Prelude
+import qualified Unison.Reference as Reference
+import qualified Unison.Server.Backend as Backend
+import Unison.Server.Errors
+  ( backendError,
+    badNamespace,
+  )
+import Unison.Server.Syntax (SyntaxText)
+import Unison.Server.Types
+  ( APIGet,
+    APIHeaders,
+    DefinitionDisplayResults (..),
+    HashQualifiedName,
+    NamedTerm,
+    NamedType,
+    Suffixify (..),
+    TypeDefinition (..),
+    addHeaders,
+    mayDefault,
+  )
+import Unison.Util.Pretty (Width)
+import Unison.Var (Var)
 
 type FuzzyFindAPI =
   "find" :> QueryParam "rootBranch" SBH.ShortBranchHash
@@ -69,7 +73,7 @@ type FuzzyFindAPI =
          :> QueryParam "limit" Int
          :> QueryParam "renderWidth" Width
          :> QueryParam "query" String
-         :> Get '[JSON] [(FZF.Alignment, FoundResult)]
+         :> APIGet [(FZF.Alignment, FoundResult)]
 
 instance ToSample FZF.Alignment where
   toSamples _ = noSamples
@@ -131,7 +135,8 @@ instance ToSample FoundResult where
   toSamples _ = noSamples
 
 serveFuzzyFind
-  :: forall v. Var v
+  :: forall v
+   . Var v
   => Handler ()
   -> Codebase IO v Ann
   -> Maybe SBH.ShortBranchHash
@@ -139,57 +144,64 @@ serveFuzzyFind
   -> Maybe Int
   -> Maybe Width
   -> Maybe String
-  -> Handler [(FZF.Alignment, FoundResult)]
-serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = do
-  h
-  rel <-
-    fromMaybe mempty
-    .   fmap Path.fromPath'
-    <$> traverse (parsePath . Text.unpack) relativePath
-  hashLength <- liftIO $ Codebase.hashLength codebase
-  ea         <- liftIO . runExceptT $ do
-    root   <- traverse (Backend.expandShortBranchHash codebase) mayRoot
-    branch <- Backend.resolveBranchHash root codebase
-    let b0 = Branch.head branch
-        alignments =
-          take (fromMaybe 10 limit)
-            . sortBy (compare `on` (Down . FZF.score . (view _1)))
-            $ Backend.fuzzyFind rel branch (fromMaybe "" query)
-        ppe = Backend.basicSuffixifiedNames hashLength branch rel
-    join <$> traverse (loadEntry root (Just rel) ppe b0) alignments
-  errFromEither backendError ea
+  -> Handler (APIHeaders [(FZF.Alignment, FoundResult)])
+serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
+  addHeaders <$> do
+    h
+    rel <-
+      fromMaybe mempty
+      .   fmap Path.fromPath'
+      <$> traverse (parsePath . Text.unpack) relativePath
+    hashLength <- liftIO $ Codebase.hashLength codebase
+    ea         <- liftIO . runExceptT $ do
+      root   <- traverse (Backend.expandShortBranchHash codebase) mayRoot
+      branch <- Backend.resolveBranchHash root codebase
+      let b0 = Branch.head branch
+          alignments =
+            take (fromMaybe 10 limit)
+              . sortBy (compare `on` (Down . FZF.score . (view _1)))
+              $ Backend.fuzzyFind rel branch (fromMaybe "" query)
+          ppe = Backend.basicSuffixifiedNames hashLength branch rel
+      join <$> traverse (loadEntry root (Just rel) ppe b0) alignments
+    errFromEither backendError ea
  where
-  loadEntry root rel ppe b0 (a, (HQ'.NameOnly . NameSegment) -> n, refs) = traverse
-    (\case
-      Backend.FoundTermRef r ->
-        (\te ->
-            ( a
-            , FoundTermResult
-              . FoundTerm (Backend.bestNameForTerm @v ppe (mayDefault typeWidth) r)
-              $ Backend.termEntryToNamedTerm ppe typeWidth te
+  loadEntry root rel ppe b0 (a, (HQ'.NameOnly . NameSegment) -> n, refs) =
+    traverse
+      (\case
+        Backend.FoundTermRef r ->
+          (\te ->
+              ( a
+              , FoundTermResult
+                . FoundTerm
+                    (Backend.bestNameForTerm @v ppe (mayDefault typeWidth) r)
+                $ Backend.termEntryToNamedTerm ppe typeWidth te
+              )
             )
-          )
-          <$> Backend.termListEntry codebase b0 r n
-      Backend.FoundTypeRef r -> do
-        te                              <- Backend.typeListEntry codebase r n
-        DefinitionDisplayResults _ ts _ <- Backend.prettyDefinitionsBySuffixes
-          rel
-          root
-          typeWidth
-          (Suffixify True)
-          codebase
-          [HQ.HashOnly $ Reference.toShortHash r]
-        let
-          t  = Map.lookup (Reference.toText r) ts
-          td = case t of
-            Just t -> t
-            Nothing ->
-              TypeDefinition mempty mempty Nothing
-                . MissingObject
-                $ Reference.toShortHash r
-          namedType = Backend.typeEntryToNamedType te
-        pure ( a, FoundTypeResult $ FoundType (bestTypeName td) (typeDefinition td) namedType)
-    )
-    refs
+            <$> Backend.termListEntry codebase b0 r n
+        Backend.FoundTypeRef r -> do
+          te                              <- Backend.typeListEntry codebase r n
+          DefinitionDisplayResults _ ts _ <- Backend.prettyDefinitionsBySuffixes
+            rel
+            root
+            typeWidth
+            (Suffixify True)
+            codebase
+            [HQ.HashOnly $ Reference.toShortHash r]
+          let
+            t  = Map.lookup (Reference.toText r) ts
+            td = case t of
+              Just t -> t
+              Nothing ->
+                TypeDefinition mempty mempty Nothing
+                  . MissingObject
+                  $ Reference.toShortHash r
+            namedType = Backend.typeEntryToNamedType te
+          pure
+            ( a
+            , FoundTypeResult
+              $ FoundType (bestTypeName td) (typeDefinition td) namedType
+            )
+      )
+      refs
   parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
   errFromEither f = either (throwError . f) pure

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

@@ -6,40 +6,46 @@
 
 module Unison.Server.Endpoints.GetDefinitions where
 
-import           Control.Error                  ( runExceptT )
-import qualified Data.Text                     as Text
-import           Servant                        ( Get
-                                                , JSON
-                                                , QueryParam
-                                                , QueryParams
-                                                , throwError
-                                                , (:>)
-                                                )
-import           Servant.Docs                   ( DocQueryParam(..)
-                                                , ParamKind(..)
-                                                , ToParam(..)
-                                                , ToSample(..)
-                                                , noSamples
-                                                )
-import           Servant.Server                 ( Handler )
-import qualified Unison.Codebase.Path          as Path
-import qualified Unison.HashQualified          as HQ
-import           Unison.Parser                  ( Ann )
-import qualified Unison.Server.Backend         as Backend
-import           Unison.Server.Types            ( HashQualifiedName
-                                                , DefinitionDisplayResults
-                                                , defaultWidth
-                                                , Suffixify(..)
-                                                )
-import           Unison.Server.Errors           ( backendError
-                                                , badNamespace
-                                                )
-import           Unison.Util.Pretty             ( Width )
-import           Unison.Var                     ( Var )
-import           Unison.Codebase                ( Codebase )
-import           Unison.Codebase.ShortBranchHash
-                                                ( ShortBranchHash )
-import           Unison.Prelude
+import Control.Error (runExceptT)
+import qualified Data.Text as Text
+import Servant
+  ( QueryParam,
+    QueryParams,
+    throwError,
+    (:>),
+  )
+import Servant.Docs
+  ( DocQueryParam (..),
+    ParamKind (..),
+    ToParam (..),
+    ToSample (..),
+    noSamples,
+  )
+import Servant.Server (Handler)
+import Unison.Codebase (Codebase)
+import qualified Unison.Codebase.Path as Path
+import Unison.Codebase.ShortBranchHash
+  ( ShortBranchHash,
+  )
+import qualified Unison.HashQualified as HQ
+import Unison.Parser (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,
+    Suffixify (..),
+    addHeaders,
+    defaultWidth,
+  )
+import Unison.Util.Pretty (Width)
+import Unison.Var (Var)
 
 type DefinitionsAPI =
   "getDefinition" :> QueryParam "rootBranch" ShortBranchHash
@@ -47,7 +53,7 @@ type DefinitionsAPI =
                   :> QueryParams "names" HashQualifiedName
                   :> QueryParam "renderWidth" Width
                   :> QueryParam "suffixifyBindings" Suffixify
-  :> Get '[JSON] DefinitionDisplayResults
+  :> APIGet DefinitionDisplayResults
 
 instance ToParam (QueryParam "renderWidth" Width) where
   toParam _ = DocQueryParam
@@ -108,20 +114,22 @@ serveDefinitions
   -> [HashQualifiedName]
   -> Maybe Width
   -> Maybe Suffixify
-  -> Handler DefinitionDisplayResults
-serveDefinitions h codebase mayRoot relativePath hqns width suff = do
-  h
-  rel <- fmap Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath
-  ea  <- liftIO . runExceptT $ do
-    root <- traverse (Backend.expandShortBranchHash codebase) mayRoot
-    Backend.prettyDefinitionsBySuffixes rel
-                                        root
-                                        width
-                                        (fromMaybe (Suffixify True) suff)
-                                        codebase
-      $   HQ.unsafeFromText
-      <$> hqns
-  errFromEither backendError ea
+  -> Handler (APIHeaders DefinitionDisplayResults)
+serveDefinitions h codebase mayRoot relativePath hqns width suff =
+  addHeaders <$> do
+    h
+    rel <-
+      fmap Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath
+    ea <- liftIO . runExceptT $ do
+      root <- traverse (Backend.expandShortBranchHash codebase) mayRoot
+      Backend.prettyDefinitionsBySuffixes rel
+                                          root
+                                          width
+                                          (fromMaybe (Suffixify True) suff)
+                                          codebase
+        $   HQ.unsafeFromText
+        <$> hqns
+    errFromEither backendError ea
  where
   parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
   errFromEither f = either (throwError . f) pure

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

@@ -9,59 +9,63 @@
 
 module Unison.Server.Endpoints.ListNamespace where
 
-import           Control.Error                  ( runExceptT )
-import           Data.Aeson
-import           Data.OpenApi                   ( ToSchema )
-import           Servant                        ( Get
-                                                , JSON
-                                                , QueryParam
-                                                , ServerError(errBody)
-                                                , err400
-                                                , throwError
-                                                , (:>)
-                                                )
-import           Servant.Docs                   ( DocQueryParam(..)
-                                                , ParamKind(Normal)
-                                                , ToParam(..)
-                                                , ToSample(..)
-                                                )
-import           Servant.OpenApi                ( )
-import           Servant.Server                 ( Handler )
-import           Unison.Prelude
-import           Unison.Codebase                ( Codebase )
-import qualified Unison.Codebase               as Codebase
-import qualified Unison.Codebase.Branch        as Branch
-import qualified Unison.Codebase.Causal        as Causal
-import qualified Unison.Codebase.Path          as Path
-import qualified Unison.Hash                   as Hash
-import qualified Unison.HashQualified          as HQ
-import qualified Unison.Name                   as Name
-import qualified Unison.NameSegment            as NameSegment
-import           Unison.Parser                  ( Ann )
-import qualified Unison.PrettyPrintEnv         as PPE
-import qualified Unison.Server.Backend         as Backend
-import           Unison.Server.Errors           ( backendError
-                                                , badHQN
-                                                , badNamespace
-                                                , rootBranchError
-                                                )
-import           Unison.Server.Types            ( HashQualifiedName
-                                                , Size
-                                                , UnisonHash
-                                                , UnisonName
-                                                , NamedTerm(..)
-                                                , NamedType(..)
-                                                )
-import           Unison.Util.Pretty             ( Width )
-import           Unison.Var                     ( Var )
-import qualified Unison.Codebase.ShortBranchHash
-                                               as SBH
-import qualified Unison.ShortHash              as ShortHash
-import qualified Data.Text                     as Text
+import Control.Error (runExceptT)
+import Data.Aeson
+import Data.OpenApi (ToSchema)
+import qualified Data.Text as Text
+import Servant
+  ( QueryParam,
+    ServerError (errBody),
+    err400,
+    throwError,
+    (:>),
+  )
+import Servant.Docs
+  ( DocQueryParam (..),
+    ParamKind (Normal),
+    ToParam (..),
+    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.Causal as Causal
+import qualified Unison.Codebase.Path as Path
+import qualified Unison.Codebase.ShortBranchHash as SBH
+import qualified Unison.Hash as Hash
+import qualified Unison.HashQualified as HQ
+import qualified Unison.Name as Name
+import qualified Unison.NameSegment as NameSegment
+import Unison.Parser (Ann)
+import Unison.Prelude
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.Server.Backend as Backend
+import Unison.Server.Errors
+  ( backendError,
+    badHQN,
+    badNamespace,
+    rootBranchError,
+  )
+import Unison.Server.Types
+  ( APIGet,
+    APIHeaders,
+    HashQualifiedName,
+    NamedTerm (..),
+    NamedType (..),
+    Size,
+    UnisonHash,
+    UnisonName,
+    addHeaders,
+  )
+import qualified Unison.ShortHash as ShortHash
+import Unison.Util.Pretty (Width)
+import Unison.Var (Var)
 
 type NamespaceAPI =
   "list" :> QueryParam "namespace" HashQualifiedName
-    :> Get '[JSON] NamespaceListing
+    :> APIGet NamespaceListing
 
 instance ToParam (QueryParam "namespace" Text) where
   toParam _ =
@@ -157,41 +161,45 @@ serveNamespace
   => Handler ()
   -> Codebase IO v Ann
   -> Maybe HashQualifiedName
-  -> Handler NamespaceListing
-serveNamespace tryAuth codebase mayHQN = tryAuth *> case mayHQN of
-  Nothing  -> serveNamespace tryAuth codebase $ Just "."
-  Just hqn -> do
-    parsedName <- parseHQN hqn
-    hashLength <- liftIO $ Codebase.hashLength codebase
-    case parsedName of
-      HQ.NameOnly n -> do
-        path'      <- parsePath $ Name.toString n
-        gotRoot    <- liftIO $ Codebase.getRootBranch codebase
-        root       <- errFromEither rootBranchError gotRoot
-        let
-          p = either id (Path.Absolute . Path.unrelative) $ Path.unPath' path'
-          ppe =
-            Backend.basicSuffixifiedNames hashLength root $ Path.fromPath' path'
-        entries <- findShallow p
-        processEntries
-          ppe
-          (Just $ Name.toText n)
-          (("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash root)
-          entries
-      HQ.HashOnly sh -> case SBH.fromText $ ShortHash.toText sh of
-        Nothing ->
-          throwError
-            . badNamespace "Malformed branch hash."
-            $ ShortHash.toString sh
-        Just h -> doBackend $ do
-          hash    <- Backend.expandShortBranchHash codebase h
-          branch  <- Backend.resolveBranchHash (Just hash) codebase
-          entries <- Backend.findShallowInBranch codebase branch
-          let ppe = Backend.basicSuffixifiedNames hashLength branch mempty
-              sbh = Text.pack . show $ SBH.fullFromHash hash
-          processEntries ppe Nothing sbh entries
-      HQ.HashQualified _ _ -> hashQualifiedNotSupported
+  -> Handler (APIHeaders NamespaceListing)
+serveNamespace tryAuth codebase mayHQN =
+  addHeaders <$> (tryAuth *> (go tryAuth codebase mayHQN))
  where
+  go tryAuth codebase mayHQN = case mayHQN of
+    Nothing  -> go tryAuth codebase $ Just "."
+    Just hqn -> do
+      parsedName <- parseHQN hqn
+      hashLength <- liftIO $ Codebase.hashLength codebase
+      case parsedName of
+        HQ.NameOnly n -> do
+          path'   <- parsePath $ Name.toString n
+          gotRoot <- liftIO $ Codebase.getRootBranch codebase
+          root    <- errFromEither rootBranchError gotRoot
+          let
+            p =
+              either id (Path.Absolute . Path.unrelative) $ Path.unPath' path'
+            ppe = Backend.basicSuffixifiedNames hashLength root
+              $ Path.fromPath' path'
+          entries <- findShallow p
+          processEntries
+            ppe
+            (Just $ Name.toText n)
+            (("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash root
+            )
+            entries
+        HQ.HashOnly sh -> case SBH.fromText $ ShortHash.toText sh of
+          Nothing ->
+            throwError
+              . badNamespace "Malformed branch hash."
+              $ ShortHash.toString sh
+          Just h -> doBackend $ do
+            hash    <- Backend.expandShortBranchHash codebase h
+            branch  <- Backend.resolveBranchHash (Just hash) codebase
+            entries <- Backend.findShallowInBranch codebase branch
+            let ppe = Backend.basicSuffixifiedNames hashLength branch mempty
+                sbh = Text.pack . show $ SBH.fullFromHash hash
+            processEntries ppe Nothing sbh entries
+        HQ.HashQualified _ _ -> hashQualifiedNotSupported
   errFromMaybe e = maybe (throwError e) pure
   errFromEither f = either (throwError . f) pure
   parseHQN hqn = errFromMaybe (badHQN hqn) $ HQ.fromText hqn

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
@@ -8,32 +9,52 @@ module Unison.Server.Types where
 
 -- Types common to endpoints --
 
-import           Unison.Prelude
-import           Data.Aeson
-import qualified Data.ByteString.Lazy          as LZ
-import qualified Data.Text.Lazy                as Text
-import qualified Data.Text.Lazy.Encoding       as Text
-import           Data.OpenApi                   ( ToSchema(..)
-                                                , ToParamSchema(..)
-                                                )
-import           Servant.API                    ( FromHttpApiData )
-import qualified Unison.HashQualified          as HQ
-import           Unison.ConstructorType         ( ConstructorType )
-import           Unison.Name                    ( Name )
-import           Unison.ShortHash               ( ShortHash )
-import           Unison.Codebase.ShortBranchHash
-                                                ( ShortBranchHash(..) )
-import           Unison.Util.Pretty             ( Width(..)
-                                                , render
-                                                )
-import           Unison.Var                     ( Var )
-import qualified Unison.PrettyPrintEnv         as PPE
-import           Unison.Type                    ( Type )
-import qualified Unison.TypePrinter            as TypePrinter
-import           Unison.Codebase.Editor.DisplayObject
-                                                ( DisplayObject )
-import           Unison.Server.Syntax           ( SyntaxText )
-import qualified Unison.Server.Syntax          as Syntax
+import Data.Aeson
+import qualified Data.ByteString.Lazy as LZ
+import Data.OpenApi
+  ( ToParamSchema (..),
+    ToSchema (..),
+  )
+import qualified Data.Text.Lazy as Text
+import qualified Data.Text.Lazy.Encoding as Text
+import Servant.API
+  ( FromHttpApiData,
+    Get,
+    Header,
+    Headers,
+    JSON,
+    addHeader,
+  )
+import Unison.Codebase.Editor.DisplayObject
+  ( DisplayObject,
+  )
+import Unison.Codebase.ShortBranchHash
+  ( ShortBranchHash (..),
+  )
+import Unison.ConstructorType (ConstructorType)
+import qualified Unison.HashQualified as HQ
+import Unison.Name (Name)
+import Unison.Prelude
+import qualified Unison.PrettyPrintEnv as PPE
+import Unison.Server.Syntax (SyntaxText)
+import qualified Unison.Server.Syntax as Syntax
+import Unison.ShortHash (ShortHash)
+import Unison.Type (Type)
+import qualified Unison.TypePrinter as TypePrinter
+import Unison.Util.Pretty
+  ( Width (..),
+    render,
+  )
+import Unison.Var (Var)
+
+type APIHeaders x =
+  Headers
+    '[ Header "Access-Control-Allow-Origin" String,
+       Header "Cache-Control" String
+     ]
+    x
+
+type APIGet c = Get '[JSON] (APIHeaders c)
 
 type HashQualifiedName = Text
 
@@ -197,3 +218,5 @@ discard = const $ pure ()
 mayDefault :: Maybe Width -> Width
 mayDefault = fromMaybe defaultWidth
 
+addHeaders :: v -> APIHeaders v
+addHeaders = addHeader "*" . addHeader "public"