unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-11-12 04:34:38 +03:00
Code Issues Projects Releases Wiki Activity

Adventures in OpenAPI 3

Browse Source
This commit is contained in:
runarorama 2020-10-08 11:54:02 -04:00
parent 8142502762
commit eb1de42185
8 changed files with 136 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
parser-typechecker/src/Unison/Server/CodebaseServer.hs
View File

@ -15,8 +15,9 @@ import GHC.Generics ()
import Network.HTTP.Types.Status (ok200)
import Network.Wai (responseLBS)
import Network.Wai.Handler.Warp (run)
import OpenAPI (InfoObject (..), LicenseObject (..), OpenAPI)
import Servant.API
( Raw,
((:>), Get, JSON, Raw,
type (:<|>) (..),
)
import Servant.Docs
@ -24,6 +25,7 @@ import Servant.Docs
docsWithIntros,
markdown,
)
import Servant.OpenAPI (blankInfo, toOpenAPI)
import Servant.Server
( Application,
Server,
@ -39,24 +41,43 @@ import Unison.Server.Endpoints.ListNamespace
import Unison.Server.Types (mungeString)
import Unison.Var (Var)
type UnisonAPI = NamespaceAPI :<|> Raw
type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenAPI
type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw
type UnisonAPI = NamespaceAPI
openAPI :: OpenAPI
openAPI = toOpenAPI api infoObject
infoObject :: InfoObject
infoObject =
blankInfo
{ title = "Unison Codebase API",
description = Just "Provides operations for querying and manipulating a Unison codebase.",
license = Just . LicenseObject "MIT" $ Just "https://github.com/unisonweb/unison/blob/trunk/LICENSE"
}
docsBS :: LZ.ByteString
docsBS = mungeString . markdown $ docsWithIntros [intro] api
where
intro = DocIntro "Unison Codebase Manager API Server" []
docAPI :: Proxy DocAPI
docAPI = Proxy
api :: Proxy UnisonAPI
api = Proxy
app :: Var v => Codebase IO v Ann -> Application
app codebase = serve api $ server codebase
app codebase = serve docAPI $ server codebase
start :: Var v => Codebase IO v Ann -> Int -> IO ()
start codebase port = run port $ app codebase
server :: Var v => Codebase IO v Ann -> Server UnisonAPI
server codebase = serveNamespace codebase :<|> Tagged serveDocs
server :: Var v => Codebase IO v Ann -> Server DocAPI
server codebase = serveNamespace codebase :<|> serveOpenAPI :<|> Tagged serveDocs
where
serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS
serveOpenAPI = pure openAPI
plain = ("Content-Type", "text/plain")

16
parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
@ -15,6 +17,8 @@ import Data.Text (Text)
import GHC.Generics (Generic)
import Servant (Get, JSON, QueryParam, ServerError (errBody), err400, throwError, (:>))
import Servant.Docs (DocQueryParam (..), ParamKind (Normal), ToParam (..), ToSample (..))
import OpenAPI ( ToOpenAPISchema )
import Servant.OpenAPI ()
import Servant.Server (Handler)
import Unison.Codebase (Codebase)
import qualified Unison.Codebase as Codebase
@ -79,6 +83,7 @@ data NamespaceListing = NamespaceListing
deriving (Generic, Show)
instance ToJSON NamespaceListing
deriving instance ToOpenAPISchema NamespaceListing
data NamespaceObject
= Subnamespace NamedNamespace
@ -88,6 +93,7 @@ data NamespaceObject
deriving (Generic, Show)
instance ToJSON NamespaceObject
deriving instance ToOpenAPISchema NamespaceObject
data NamedNamespace = NamedNamespace
{ namespaceName :: UnisonName,
@ -96,6 +102,7 @@ data NamedNamespace = NamedNamespace
deriving (Generic, Show)
instance ToJSON NamedNamespace
deriving instance ToOpenAPISchema NamedNamespace
data NamedTerm = NamedTerm
{ termName :: HashQualifiedName,
@ -105,6 +112,7 @@ data NamedTerm = NamedTerm
deriving (Generic, Show)
instance ToJSON NamedTerm
deriving instance ToOpenAPISchema NamedTerm
data NamedType = NamedType
{ typeName :: HashQualifiedName,
@ -113,6 +121,7 @@ data NamedType = NamedType
deriving (Generic, Show)
instance ToJSON NamedType
deriving instance ToOpenAPISchema NamedType
data NamedPatch = NamedPatch
{ patchName :: HashQualifiedName
@ -120,11 +129,13 @@ data NamedPatch = NamedPatch
deriving (Generic, Show)
instance ToJSON NamedPatch
deriving instance ToOpenAPISchema NamedPatch
newtype KindExpression = KindExpression {kindExpressionText :: Text}
deriving (Generic, Show)
instance ToJSON KindExpression
deriving instance ToOpenAPISchema KindExpression
formatType ::
Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText' ShortHash
@ -136,14 +147,19 @@ formatType ppe w =
(-1)
instance ToJSON ConstructorType
deriving instance ToOpenAPISchema ConstructorType
instance ToJSON SeqOp
deriving instance ToOpenAPISchema SeqOp
instance ToJSON r => ToJSON (Referent.Referent' r)
deriving instance ToOpenAPISchema r => ToOpenAPISchema (Referent.Referent' r)
instance ToJSON r => ToJSON (SyntaxText.Element r)
deriving instance ToOpenAPISchema r => ToOpenAPISchema (SyntaxText.Element r)
instance ToJSON r => ToJSON (SyntaxText' r)
deriving instance ToOpenAPISchema r => ToOpenAPISchema (SyntaxText' r)
backendListEntryToNamespaceObject ::
Var v =>

15
parser-typechecker/src/Unison/Server/Types.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Unison.Server.Types where
@ -7,13 +9,17 @@ module Unison.Server.Types where
import Control.Error (fromMaybe)
import Data.Aeson (ToJSON)
import qualified Data.ByteString.Lazy as LZ
import Data.Proxy (Proxy(..))
import Data.Sequence (Seq(..))
import Data.Text (Text)
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import OpenAPI ( ToOpenAPISchema(..) )
import qualified Unison.HashQualified as HQ
import Unison.Name (Name)
import Unison.ShortHash (ShortHash)
import Unison.Util.Pretty (Width)
import Unison.Util.AnnotatedText ( AnnotatedString )
type HashQualifiedName = Text
@ -24,10 +30,19 @@ type UnisonName = Text
type UnisonHash = Text
instance ToJSON Name
deriving instance ToOpenAPISchema Name
instance ToJSON ShortHash
deriving instance ToOpenAPISchema ShortHash
instance ToJSON HQ.HashQualified
deriving instance ToOpenAPISchema HQ.HashQualified
instance ToJSON a => ToJSON (AnnotatedString a)
instance ToOpenAPISchema a => ToOpenAPISchema (AnnotatedString a)
instance ToOpenAPISchema r => ToOpenAPISchema (Seq r) where
toSchema _ = toSchema (Proxy @[r])
munge :: Text -> LZ.ByteString
munge = Text.encodeUtf8 . Text.fromStrict

80
parser-typechecker/src/Unison/Util/AnnotatedText.hs
View File

@ -1,14 +1,15 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternSynonyms #-}
module Unison.Util.AnnotatedText where
import Unison.Prelude
import qualified Data.List as L
import qualified Data.Foldable as Foldable
import qualified Data.Map as Map
@ -20,14 +21,40 @@ import Unison.Util.Monoid (intercalateMap)
import Unison.Util.Range (Range (..), inRange)
import qualified Data.ListLike as LL
-- type AnnotatedText a = AnnotatedText (Maybe a)
pattern (:|) :: String -> Maybe a -> AnnotatedString a
pattern s :| a <- (toPair -> (s, a))
where s :| Nothing = Unannotated s
s :| Just a = Annotated s a
newtype AnnotatedText a = AnnotatedText (Seq (String, Maybe a))
{-# COMPLETE (:|) #-}
data AnnotatedString a = Unannotated String
| Annotated String a
deriving (Eq, Show, Functor, Foldable, Generic)
theString :: AnnotatedString a -> String
theString (Unannotated s) = s
theString (Annotated s _) = s
theAnnotation :: AnnotatedString a -> Maybe a
theAnnotation (Annotated _ a) = Just a
theAnnotation _ = Nothing
toPair :: AnnotatedString a -> (String, Maybe a)
toPair (Unannotated s) = (s, Nothing)
toPair (Annotated s a) = (s, Just a)
maybeAnnotate :: String -> Maybe a -> AnnotatedString a
maybeAnnotate s a = case a of
Nothing -> Unannotated s
Just a -> Annotated s a
newtype AnnotatedText a = AnnotatedText (Seq (AnnotatedString a))
deriving (Eq, Functor, Foldable, Show, Generic)
instance Semigroup (AnnotatedText a) where
AnnotatedText (as :|> ("", _)) <> bs = AnnotatedText as <> bs
as <> AnnotatedText (("", _) :<| bs) = as <> AnnotatedText bs
AnnotatedText (as :|> "" :| _) <> bs = AnnotatedText as <> bs
as <> AnnotatedText ("" :| _ :<| bs) = as <> AnnotatedText bs
AnnotatedText as <> AnnotatedText bs = AnnotatedText (as <> bs)
instance Monoid (AnnotatedText a) where
@ -35,43 +62,43 @@ instance Monoid (AnnotatedText a) where
instance LL.FoldableLL (AnnotatedText a) Char where
foldl' f z (AnnotatedText at) = Foldable.foldl' f' z at where
f' z (str, _) = L.foldl' f z str
f' z (str :| _) = L.foldl' f z str
foldl = LL.foldl
foldr f z (AnnotatedText at) = Foldable.foldr f' z at where
f' (str, _) z = L.foldr f z str
f' (str :| _) z = L.foldr f z str
instance LL.ListLike (AnnotatedText a) Char where
singleton ch = fromString [ch]
uncons (AnnotatedText at) = case at of
(s,a) :<| tl -> case L.uncons s of
s :| a :<| tl -> case L.uncons s of
Nothing -> LL.uncons (AnnotatedText tl)
Just (hd,s) -> Just (hd, AnnotatedText $ (s,a) :<| tl)
Just (hd,s) -> Just (hd, AnnotatedText $ s :| a :<| tl)
Seq.Empty -> Nothing
break f at = (LL.takeWhile (not . f) at, LL.dropWhile (not . f) at)
takeWhile f (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl -> let s' = L.takeWhile f s in
s :| a :<| tl -> let s' = L.takeWhile f s in
if length s' == length s then
AnnotatedText (pure (s,a)) <> LL.takeWhile f (AnnotatedText tl)
AnnotatedText (pure $ s :| a) <> LL.takeWhile f (AnnotatedText tl)
else
AnnotatedText (pure (s',a))
AnnotatedText (pure $ s' :| a)
dropWhile f (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl -> case L.dropWhile f s of
s :| a :<| tl -> case L.dropWhile f s of
[] -> LL.dropWhile f (AnnotatedText tl)
s -> AnnotatedText $ (s,a) :<| tl
s -> AnnotatedText $ (s :| a) :<| tl
take n (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl ->
if n <= length s then AnnotatedText $ pure (take n s, a)
else AnnotatedText (pure (s,a)) <>
s :| a :<| tl ->
if n <= length s then AnnotatedText $ pure (take n s :| a)
else AnnotatedText (pure (s :| a)) <>
LL.take (n - length s) (AnnotatedText tl)
drop n (AnnotatedText at) = case at of
Seq.Empty -> AnnotatedText Seq.Empty
(s,a) :<| tl ->
if n <= length s then AnnotatedText $ (drop n s, a) :<| tl
s :| a :<| tl ->
if n <= length s then AnnotatedText $ (drop n s :| a) :<| tl
else LL.drop (n - length s) (AnnotatedText tl)
null (AnnotatedText at) = all (null . fst) at
null (AnnotatedText at) = all (null . theString) at
-- Quoted text (indented, with source line numbers) with annotated portions.
data AnnotatedExcerpt a = AnnotatedExcerpt
@ -82,7 +109,7 @@ data AnnotatedExcerpt a = AnnotatedExcerpt
annotate' :: Maybe b -> AnnotatedText a -> AnnotatedText b
annotate' a (AnnotatedText at) =
AnnotatedText $ (\(s,_) -> (s, a)) <$> at
AnnotatedText $ (\(theString -> s) -> maybeAnnotate s a) <$> at
deannotate :: AnnotatedText a -> AnnotatedText b
deannotate = annotate' Nothing
@ -90,13 +117,14 @@ deannotate = annotate' Nothing
-- Replace the annotation (whether existing or no) with the given annotation
annotate :: a -> AnnotatedText a -> AnnotatedText a
annotate a (AnnotatedText at) =
AnnotatedText $ (\(s,_) -> (s,Just a)) <$> at
AnnotatedText $ (\(theString -> s) -> Annotated s a) <$> at
annotateMaybe :: AnnotatedText (Maybe a) -> AnnotatedText a
annotateMaybe (AnnotatedText s) = AnnotatedText (fmap (second join) s)
annotateMaybe (AnnotatedText s) =
AnnotatedText (fmap (uncurry maybeAnnotate . second join . toPair) s)
trailingNewLine :: AnnotatedText a -> Bool
trailingNewLine (AnnotatedText (init :|> (s,_))) =
trailingNewLine (AnnotatedText (init :|> (s :| _))) =
case lastMay s of
Just '\n' -> True
Just _ -> False
@ -112,7 +140,7 @@ markup a r = a { annotations = r `Map.union` annotations a }
textLength :: AnnotatedText a -> Int
textLength (AnnotatedText chunks) = foldl' go 0 chunks
where go len (text, _a) = len + length text
where go len (toPair -> (text, _a)) = len + length text
textEmpty :: AnnotatedText a -> Bool
textEmpty = (==0) . textLength
@ -194,7 +222,7 @@ snipWithContext margin source =
else (Just r0, taken, Map.insert r1 a1 rest)
instance IsString (AnnotatedText a) where
fromString s = AnnotatedText . pure $ (s, Nothing)
fromString s = AnnotatedText . pure $ Unannotated s
instance IsString (AnnotatedExcerpt a) where
fromString s = AnnotatedExcerpt 1 s mempty

20
parser-typechecker/src/Unison/Util/ColorText.hs
View File

@ -1,3 +1,6 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
module Unison.Util.ColorText (
ColorText, Color(..), style, toANSI, toPlain, toHTML, defaultColors,
black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold, underline,
@ -7,7 +10,14 @@ where
import Unison.Prelude
import qualified System.Console.ANSI as ANSI
import Unison.Util.AnnotatedText (AnnotatedText(..), annotate)
import Unison.Util.AnnotatedText ( AnnotatedText(..)
, annotate
, pattern (:|)
, theString
, theAnnotation
, toPair
, AnnotatedString
)
import qualified Unison.Util.SyntaxText as ST hiding (toPlain)
type ColorText = AnnotatedText Color
@ -43,7 +53,7 @@ style = annotate
toHTML :: String -> ColorText -> String
toHTML cssPrefix (AnnotatedText at) = toList at >>= \case
(s, color) -> wrap color (s >>= newlineToBreak)
s :| color -> wrap color (s >>= newlineToBreak)
where
newlineToBreak '\n' = "<br/>\n"
newlineToBreak ch = [ch]
@ -54,7 +64,7 @@ toHTML cssPrefix (AnnotatedText at) = toList at >>= \case
-- Convert a `ColorText` to a `String`, ignoring colors
toPlain :: ColorText -> String
toPlain (AnnotatedText at) = join (toList $ fst <$> at)
toPlain (AnnotatedText at) = join (toList $ theString <$> at)
-- Convert a `ColorText` to a `String`, using ANSI codes to produce colors
toANSI :: ColorText -> String
@ -63,9 +73,9 @@ toANSI (AnnotatedText chunks) =
where
go
:: (Maybe Color, Seq String)
-> (String, Maybe Color)
-> AnnotatedString Color
-> (Maybe Color, Seq String)
go (prev, r) (text, new) = if prev == new
go (prev, r) (toPair -> (text, new)) = if prev == new
then (prev, r <> pure text)
else
( new

4
parser-typechecker/src/Unison/Util/SyntaxText.hs
View File

@ -8,7 +8,7 @@ import Unison.Referent (Referent')
import Unison.HashQualified (HashQualified)
import Unison.Pattern (SeqOp)
import Unison.Util.AnnotatedText ( AnnotatedText(..), annotate )
import Unison.Util.AnnotatedText ( AnnotatedText(..), annotate, theString )
type SyntaxText = SyntaxText' Reference
type SyntaxText' r = AnnotatedText (Element r)
@ -62,4 +62,4 @@ syntax = annotate
-- Convert a `SyntaxText` to a `String`, ignoring syntax markup
toPlain :: SyntaxText' r -> String
toPlain (AnnotatedText at) = join (toList $ fst <$> at)
toPlain (AnnotatedText at) = join (toList $ theString <$> at)

2
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -225,6 +225,7 @@ library
network,
network-simple,
nonempty-containers,
openapi,
process,
primitive,
random,
@ -234,6 +235,7 @@ library
safe,
servant,
servant-docs,
servant-openapi,
servant-server,
shellmet,
split,

7
stack.yaml
View File

@ -19,13 +19,18 @@ extra-deps:
commit: 2944b11d19ee034c48276edc991736105c9d6143
- github: unisonweb/megaparsec
commit: c4463124c578e8d1074c04518779b5ce5957af6b
- github: felixmulder/servant-openapi
commit: af53ca0a88974729de55db7bc4502cb5565035cd
subdirs:
- openapi
- servant-openapi
- base16-0.2.1.0@sha256:62e9abde29287913a775ec658b62ecba20270b9e1ac0a008e6acb4616b79a22d,2183
- concurrent-supply-0.1.8@sha256:9373f4868ad28936a7b93781b214ef4afdeacf377ef4ac729583073491c9f9fb,1627
- guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078
- prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163
- sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010
- strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617
- aeson-deriving-0.1.1.1@sha256:0b2b6dfdfdf57bb6b3db5978a9e60ba6345b7d48fa254cddb2c76da7d96f8c26,2714
ghc-options:
# All packages
"$locals": -Werror -Wno-type-defaults #-freverse-errors