diff --git a/app/swagger-api/Main.hs b/app/swagger-api/Main.hs new file mode 100644 index 00000000..8583cb45 --- /dev/null +++ b/app/swagger-api/Main.hs @@ -0,0 +1,21 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Main where + +import Control.Lens +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy.Char8 qualified as BL +import Data.Data (Proxy(Proxy)) +import Data.OpenApi +import Servant.OpenApi (toOpenApi) +import Web.API (API) + +main :: IO () +main = do + let openApi = toOpenApi (Proxy :: Proxy API) + & info . title .~ "Coffer Web API" + & info . version .~ "1.0" + & servers .~ ["localhost:8081"] + BL.writeFile "swagger.json" (encodePretty openApi) diff --git a/coffer.cabal b/coffer.cabal index e3451d0a..9ddfb05e 100644 --- a/coffer.cabal +++ b/coffer.cabal @@ -3,8 +3,6 @@ cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: eef391a53881124afd5eff5d82574448d5138f54f006e5a613282c960bf8972c name: coffer version: 0.1.0.0 @@ -115,6 +113,7 @@ library , megaparsec , mtl , nyan-interpolation + , openapi3 , optparse-applicative , polysemy , servant @@ -264,6 +263,73 @@ executable coffer-server , warp default-language: Haskell2010 +executable coffer-swagger-api + main-is: Main.hs + other-modules: + Paths_coffer + hs-source-dirs: + app/swagger-api + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NegativeLiterals + NumDecimals + NumericUnderscores + OverloadedLabels + OverloadedStrings + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + UndecidableSuperClasses + ViewPatterns + ghc-options: -Weverything -Wno-implicit-prelude -Wno-name-shadowing -Wno-missing-import-lists -Wno-missing-export-lists -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations + build-depends: + aeson-pretty + , base >=4.14.3.0 && <5 + , bytestring + , coffer + , lens + , openapi3 + , servant-openapi3 + default-language: Haskell2010 + test-suite doctests type: exitcode-stdio-1.0 main-is: Doctests.hs diff --git a/lib/Backend/Vault/Kv/Internal.hs b/lib/Backend/Vault/Kv/Internal.hs index 1751a6ca..2587cc36 100644 --- a/lib/Backend/Vault/Kv/Internal.hs +++ b/lib/Backend/Vault/Kv/Internal.hs @@ -44,6 +44,7 @@ import Data.Aeson import Data.Aeson.Types qualified as AT import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HS +import Data.OpenApi import Data.Text (Text) import Servant.API import Servant.API.Generic @@ -231,9 +232,11 @@ instance ReflectMethod 'LIST where -- TODO - A place holder, for a perhaps more complicated type. One with pinned memory which is -- overwritten many times or something like that newtype VaultToken = VaultToken Text - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) deriving newtype (FromHttpApiData) +instance ToParamSchema VaultToken + -- Could this be somehow automated? newtypes are just meaningless wrapper anyways, at least to GHC. instance ToHttpApiData VaultToken where toUrlPiece (VaultToken t) = t diff --git a/lib/BackendName.hs b/lib/BackendName.hs index f76d5c8f..5f4f415c 100644 --- a/lib/BackendName.hs +++ b/lib/BackendName.hs @@ -13,6 +13,7 @@ module BackendName import Coffer.Util (didimatch) import Data.Aeson qualified as A import Data.Hashable (Hashable) +import Data.OpenApi import Data.Text (Text) import Data.Text qualified as T import Fmt (Buildable) @@ -22,6 +23,13 @@ newtype BackendName = UnsafeBackendName Text deriving stock (Show, Eq) deriving newtype (A.ToJSON, A.ToJSONKey, A.FromJSON, A.FromJSONKey, Hashable, Buildable) +-- | These instances are redundant due to https://github.com/serokell/coffer/issues/113 +instance ToSchema BackendName where + declareNamedSchema _ = pure $ NamedSchema Nothing mempty + +instance ToParamSchema BackendName where + toParamSchema _ = mempty + backendNameCharSet :: [Char] backendNameCharSet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_;" diff --git a/lib/CLI/Types.hs b/lib/CLI/Types.hs index 4cd5612d..2d4e6e22 100644 --- a/lib/CLI/Types.hs +++ b/lib/CLI/Types.hs @@ -8,12 +8,14 @@ import Coffer.Directory (Directory) import Coffer.Path (EntryPath, Path, QualifiedPath) import Coffer.Util (MParser) import Control.Applicative (Alternative(some), optional) +import Control.Lens hiding (noneOf) import Control.Monad (guard, void) import Data.Aeson hiding (()) import Data.Bifunctor (first) import Data.Char qualified as Char import Data.Fixed (Pico) import Data.Functor (($>)) +import Data.OpenApi import Data.Set (Set) import Data.Text (Text) import Data.Text qualified as T @@ -57,6 +59,8 @@ deriving stock instance Show SomeCommand -- Command results ---------------------------------------------------------------------------- +-- | All these @ToSchema@ instances for results are redundant due to https://github.com/serokell/coffer/issues/111 + data ViewResult = VRDirectory Directory | VREntry Entry @@ -65,34 +69,34 @@ data ViewResult | VRDirectoryNoFieldMatch (QualifiedPath Path) FieldName | VREntryNoFieldMatch (QualifiedPath EntryPath) FieldName deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) data CreateError = CEParentDirectoryIsEntry (QualifiedPath EntryPath, QualifiedPath EntryPath) | CEDestinationIsDirectory (QualifiedPath EntryPath) | CEEntryAlreadyExists (QualifiedPath EntryPath) deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) data CreateResult = CRSuccess Entry | CRCreateError CreateError deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) data SetFieldResult = SFRSuccess (QualifiedPath Entry) | SFREntryNotFound (QualifiedPath EntryPath) | SFRMissingFieldContents (QualifiedPath EntryPath) deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) data DeleteFieldResult = DFRSuccess Entry | DFREntryNotFound (QualifiedPath EntryPath) | DFRFieldNotFound FieldName deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) type RenameResult = CopyResult @@ -103,14 +107,14 @@ data CopyResult | CPRSamePath (QualifiedPath Path) | CPRCreateErrors [(QualifiedPath EntryPath, CreateError)] deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) data DeleteResult = DRSuccess [QualifiedPath EntryPath] | DRPathNotFound (QualifiedPath Path) | DRDirectoryFound (QualifiedPath Path) deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) data TagResult = TRSuccess Entry @@ -118,7 +122,7 @@ data TagResult | TRTagNotFound EntryTag | TRDuplicateTag EntryTag deriving stock (Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToSchema) ---------------------------------------------------------------------------- -- Options @@ -327,6 +331,29 @@ instance FromHttpApiData (FieldName, FilterField) where return (field, FilterFieldByDate op date) ] +instance ToParamSchema (Sort, Direction) where + toParamSchema _ = + mempty + & format ?~ sortDirectionFormat + where + sortDirectionFormat = T.unlines + [ "name:" + , "date:" + , "=[asc, desc]" + ] + +instance ToParamSchema Filter where + toParamSchema _ = + mempty + & format ?~ filterFormat + where + filterFormat = T.unlines + [ "name~" + , "date" + , "=[>=, <=, >, <, =]" + , "=['YYYY', 'YYYY-MM', 'YYYY-MM-DD', 'YYYY-MM-DD HH:MM:SS']" + ] + ---------------------------------------------------------------------------- -- Utils ---------------------------------------------------------------------------- diff --git a/lib/Coffer/Directory.hs b/lib/Coffer/Directory.hs index eb5c1d7a..835a7365 100644 --- a/lib/Coffer/Directory.hs +++ b/lib/Coffer/Directory.hs @@ -20,9 +20,11 @@ module Coffer.Directory import Coffer.Path (PathSegment, entryPathParentDir, pathSegments) import Control.Lens import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson.Casing import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.Maybe qualified as Maybe +import Data.OpenApi import Entry (Entry) import Entry qualified as E import GHC.Generics (Generic) @@ -40,6 +42,9 @@ data Directory = Directory makeLensesWith abbreviatedFields 'Directory +instance ToSchema Directory where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase) + emptyDir :: Directory emptyDir = Directory mempty mempty diff --git a/lib/Coffer/Path.hs b/lib/Coffer/Path.hs index 2c32a6ed..e2388c03 100644 --- a/lib/Coffer/Path.hs +++ b/lib/Coffer/Path.hs @@ -27,11 +27,13 @@ import Control.Lens import Control.Monad ((>=>)) import Data.Aeson (FromJSON, ToJSON) import Data.Aeson qualified as A +import Data.Data (Typeable) import Data.Hashable (Hashable) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) +import Data.OpenApi import Data.Text (Text) import Data.Text qualified as T import Fmt (Buildable, build, fmt, pretty) @@ -52,6 +54,13 @@ newtype PathSegment = UnsafeMkPathSegment { unPathSegment :: Text } deriving newtype (Buildable, ToHttpApiData, FromHttpApiData) deriving newtype (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey) +instance ToSchema PathSegment where + declareNamedSchema _ = pure $ NamedSchema (Just "PathSegment") + mempty { _schemaPattern = Just pathSegmentPattern } + & type_ ?~ OpenApiString + where + pathSegmentPattern = "[" <> T.pack pathSegmentAllowedCharacters <> "]*" + mkPathSegment :: Text -> Either Text PathSegment mkPathSegment segment | T.null segment = @@ -115,6 +124,13 @@ newtype EntryPath = EntryPath { unEntryPath :: NonEmpty PathSegment } deriving stock (Show, Eq, Generic) deriving anyclass (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey) +instance ToSchema EntryPath where + declareNamedSchema proxy = do + namedSchema <- genericDeclareNamedSchema defaultSchemaOptions proxy + pure + $ namedSchema + & schema %~ \s -> s { _schemaPattern = Just "(/${pathSegment})+" } + instance ToHttpApiData EntryPath where toUrlPiece = fmt . build @@ -220,6 +236,13 @@ instance (FromHttpApiData path) => FromHttpApiData (QualifiedPath path) where instance (ToHttpApiData path, Buildable path) => ToHttpApiData (QualifiedPath path) where toUrlPiece = pretty +-- | These instances are redundant due to https://github.com/serokell/coffer/issues/113 +instance (Typeable path) => ToSchema (QualifiedPath path) where + declareNamedSchema _ = pure $ NamedSchema Nothing mempty + +instance ToParamSchema (QualifiedPath path) where + toParamSchema = mempty + ---------------------------------------------------------------------------- -- Optics ---------------------------------------------------------------------------- diff --git a/lib/Entry.hs b/lib/Entry.hs index 8687b191..14cf76c1 100644 --- a/lib/Entry.hs +++ b/lib/Entry.hs @@ -33,9 +33,11 @@ where import Coffer.Path (EntryPath) import Control.Lens import Data.Aeson qualified as A +import Data.Aeson.Casing import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HS import Data.Hashable (Hashable) +import Data.OpenApi import Data.Set (Set) import Data.Set qualified as S import Data.Text (Text) @@ -51,6 +53,16 @@ newtype FieldName = UnsafeFieldName Text deriving stock (Show, Eq) deriving newtype (A.ToJSON, A.ToJSONKey, A.FromJSON, A.FromJSONKey, Hashable, Buildable, ToHttpApiData, FromHttpApiData) +instance ToSchema FieldName where + declareNamedSchema proxy = pure $ NamedSchema (Just "FieldName") (toParamSchema proxy) + +instance ToParamSchema FieldName where + toParamSchema _ = + mempty { _schemaPattern = Just fieldNamePattern } + & type_ ?~ OpenApiString + where + fieldNamePattern = "[" <> T.pack allowedCharSet <> "]*" + allowedCharSet :: [Char] allowedCharSet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_;" @@ -72,6 +84,16 @@ newtype EntryTag = UnsafeEntryTag Text deriving stock (Show, Eq, Ord) deriving newtype (A.ToJSON, A.FromJSON, Buildable, Hashable, ToHttpApiData, FromHttpApiData) +instance ToSchema EntryTag where + declareNamedSchema proxy = pure $ NamedSchema (Just "EntryTag") (toParamSchema proxy) + +instance ToParamSchema EntryTag where + toParamSchema _ = + mempty { _schemaPattern = Just entryTagPattern } + & type_ ?~ OpenApiString + where + entryTagPattern = "[" <> T.pack allowedCharSet <> "]*" + newtype BadEntryTag = BadEntryTag { unBadEntryTag :: Text } deriving newtype Buildable @@ -90,6 +112,11 @@ data FieldVisibility = Public | Private deriving stock (Show, Eq, Generic) deriving anyclass (Hashable) +instance ToSchema FieldVisibility where + declareNamedSchema _ = pure $ NamedSchema (Just "FieldVisibility") $ mempty + & type_ ?~ OpenApiString + & enum_ ?~ ["public", "private"] + instance Buildable FieldVisibility where build = \case Public -> "public" @@ -108,7 +135,7 @@ instance A.FromJSON FieldVisibility where newtype FieldContents = FieldContents { unFieldContents :: Text } deriving stock (Show, Eq, Ord) - deriving newtype (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey) + deriving newtype (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey, ToSchema) makeLensesFor [("unFieldContents", "fieldContents")] ''FieldContents -- | User can use ANSI control sequences in field contents. @@ -132,6 +159,9 @@ data Field = deriving anyclass (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey) makeLensesWith abbreviatedFields ''Field +instance ToSchema Field where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase) + newField :: UTCTime -> FieldContents -> Field newField time contents = Field @@ -152,6 +182,9 @@ data Entry = deriving anyclass (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey) makeLensesWith abbreviatedFields ''Entry +instance ToSchema Entry where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase) + newEntry :: EntryPath -> UTCTime -> Entry newEntry path time = Entry diff --git a/lib/Web/Types.hs b/lib/Web/Types.hs index 069b5a9b..1a051ec2 100644 --- a/lib/Web/Types.hs +++ b/lib/Web/Types.hs @@ -7,22 +7,26 @@ module Web.Types where import Data.Aeson.Casing (aesonPrefix, camelCase) import Data.Aeson.TH (deriveJSON) import Data.HashMap.Strict (HashMap) +import Data.OpenApi import Entry (EntryTag, FieldContents, FieldName, FieldVisibility) import GHC.Generics (Generic) - data NewField = NewField { nfContents :: FieldContents , nfVisibility :: FieldVisibility } deriving stock (Show, Eq, Generic) - deriveJSON (aesonPrefix camelCase) ''NewField +instance ToSchema NewField where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase) + data NewEntry = NewEntry { neFields :: HashMap FieldName NewField , neTags :: [EntryTag] } deriving stock (Show, Eq, Generic) - deriveJSON (aesonPrefix camelCase) ''NewEntry + +instance ToSchema NewEntry where + declareNamedSchema = genericDeclareNamedSchema $ fromAesonOptions (aesonPrefix camelCase) diff --git a/package.yaml b/package.yaml index 786db8f6..4f6d575b 100644 --- a/package.yaml +++ b/package.yaml @@ -104,6 +104,7 @@ library: - megaparsec - mtl - nyan-interpolation + - openapi3 - optparse-applicative - polysemy - servant @@ -141,6 +142,17 @@ executables: - tomland - warp + coffer-swagger-api: + source-dirs: app/swagger-api + main: Main.hs + dependencies: + - aeson-pretty + - bytestring + - coffer + - lens + - openapi3 + - servant-openapi3 + tests: test: source-dirs: tests/test