[#114] Swagger API generator

Problem: we don't have documentation for our `coffer Web API`.

Solution: added executable `coffer-swagger-api` which generates
Swagger docs.

app/swagger-api/Main.hs

@@ -0,0 +1,21 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
+--
+-- 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)

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

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

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'] ++ "-_;"
 

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,22 +107,22 @@ 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
   | TREntryNotFound (QualifiedPath EntryPath)
   | 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:<direction>"
+        , "date:<direction>"
+        , "<direction>=[asc, desc]"
+        ]
+
+instance ToParamSchema Filter where
+  toParamSchema _ =
+    mempty
+      & format ?~ filterFormat
+    where
+      filterFormat = T.unlines
+        [ "name~<substring>"
+        , "date<op><date>"
+        , "<op>=[>=, <=, >, <, =]"
+        , "<date>=['YYYY', 'YYYY-MM', 'YYYY-MM-DD', 'YYYY-MM-DD HH:MM:SS']"
+        ]
+
 ----------------------------------------------------------------------------
 -- Utils
 ----------------------------------------------------------------------------

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
 

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
 ----------------------------------------------------------------------------