diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 Tomas Carnecky + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/avers-api-docs.cabal b/avers-api-docs.cabal new file mode 100644 --- /dev/null +++ b/avers-api-docs.cabal @@ -0,0 +1,38 @@ +name: avers-api-docs +version: 0.0.17.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: 2016 Tomas Carnecky +maintainer: tomas.carnecky@gmail.com +homepage: http://github.com/wereHamster/avers-api-docs +synopsis: Swagger documentation for the Avers API +description: + See README.md +category: Avers +author: Tomas Carnecky + +source-repository head + type: git + location: https://github.com/wereHamster/avers-api-docs + +library + exposed-modules: + Avers.API.Documentation + build-depends: + base >=4.7 && <5, + aeson >=1.0.2.0 && <1.1, + avers -any, + avers-api -any, + cookie >=0.4.2.1 && <0.5, + lens ==4.14.*, + servant >=0.9.0.1 && <0.10, + servant-swagger >=1.1.2 && <1.2, + swagger2 >=2.1.3 && <2.2, + text >=1.2.2.1 && <1.3, + unordered-containers >=0.2.7.1 && <0.3 + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + diff --git a/src/Avers/API/Documentation.hs b/src/Avers/API/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Avers/API/Documentation.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Avers.API.Documentation + ( swaggerAversAPI + ) where + + +import Control.Lens + +import Data.Proxy +import Data.Swagger hiding (Operation, Header) +import Data.Aeson +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Char + +import Servant.API hiding (Patch) +import Servant.Swagger + +import Web.Cookie + +import Avers.Types +import Avers.API + + + +-- | Add parameter to every operation in the spec. +addParam :: Param -> Swagger -> Swagger +addParam param = allOperations.parameters %~ (Inline param :) + +addDefaultResponse400 :: ParamName -> Swagger -> Swagger +addDefaultResponse400 n = setResponseWith (\old _new -> alter400 old) 400 (pure response400) + where + description400 = "Invalid " <> n + alter400 = description %~ (<> (" or " <> n)) + response400 = mempty & description .~ description400 + + + +-------------------------------------------------------------------------------- +schemaOptions :: String -> SchemaOptions +schemaOptions p = defaultSchemaOptions + { fieldLabelModifier = dropPrefix p + , constructorTagModifier = map toLower + } + +dropPrefix :: String -> String -> String +dropPrefix p x = toLower (head rest) : tail rest + where rest = drop (length p) x + + + +-------------------------------------------------------------------------------- +instance (HasSwagger sub) => HasSwagger (Credentials :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 (Text.pack paramName) + where + paramName = "Cookie" + param = mempty + & name .~ (Text.pack paramName) + & schema .~ ParamOther (mempty + & in_ .~ ParamHeader + & paramSchema .~ toParamSchema (Proxy :: Proxy Text)) + + +-------------------------------------------------------------------------------- +instance (HasSwagger sub) => HasSwagger (SessionId :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 (Text.pack paramName) + where + paramName = "Cookie" + param = mempty + & name .~ (Text.pack paramName) + & schema .~ ParamOther (mempty + & in_ .~ ParamHeader + & paramSchema .~ toParamSchema (Proxy :: Proxy Text)) + + + +-------------------------------------------------------------------------------- +instance ToSchema Value where + declareNamedSchema _ = pure (NamedSchema (Just "Value") (mempty & type_ .~ SwaggerObject)) + + +-------------------------------------------------------------------------------- +instance ToParamSchema ObjectId where + toParamSchema _ = toParamSchema (Proxy :: Proxy Text) + +instance ToSchema ObjectId where + declareNamedSchema a = pure (NamedSchema (Just "ObjectId") (paramSchemaToSchema a)) + + +instance ToParamSchema ObjId +instance ToSchema ObjId +instance ToParamSchema RevId +instance ToSchema RevId +instance ToSchema SecretId +instance ToSchema SessionId +instance ToSchema BlobId +instance ToParamSchema BlobId +instance ToSchema Path + + +instance ToParamSchema SetCookie where + toParamSchema _ = toParamSchema (Proxy :: Proxy Text) + +instance ToSchema BlobContent where + declareNamedSchema _ = pure (NamedSchema (Just "BlobContent") binarySchema) + + +-------------------------------------------------------------------------------- +-- FIXME: This doesn't generate a correct representation of an 'Operation' +-- object. May need to declare it manually :( +instance ToSchema Operation where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "op") + + +-------------------------------------------------------------------------------- +instance ToSchema Patch where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "patch") + + + +instance ToSchema CreateObjectBody where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "cob") +instance ToSchema CreateObjectResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "cor") + + +instance ToSchema LookupObjectResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "lor") + + +instance ToSchema PatchObjectBody where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "pob") +instance ToSchema PatchObjectResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "por") + + +instance ToSchema ObjectChangeNotification where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "cob") + + +-- LookupPatchResponse is a type synonym for Patch +-- instance ToSchema LookupPatchResponse + + +instance ToSchema CreateReleaseBody where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "crb") +instance ToSchema CreateReleaseResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "crr") + + +instance ToSchema LookupReleaseResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "lrr") + +instance ToSchema LookupLatestReleaseResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "llrr") + + +instance ToSchema CreateSessionBody where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "csb") +instance ToSchema CreateSessionResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "csr") + + +instance ToSchema LookupSessionResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "lsr") + + +instance ToSchema ChangeSecretBody where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "csb") + + +instance ToSchema UploadBlobResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "") + + +instance ToSchema LookupBlobResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "") + + +instance ToSchema SignupBody where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "") + +instance ToSchema SignupResponse where + declareNamedSchema = genericDeclareNamedSchema (schemaOptions "") + + + +-------------------------------------------------------------------------------- + +swaggerAversAPI :: Swagger +swaggerAversAPI = toSwagger (Proxy :: Proxy AversAPI) + & info.title .~ "Avers API" + & info.version .~ "0.0.1" -- FIXME: Get the version from the avers-api package + & info.description ?~ "TODO" + & info.license ?~ License "MIT" (Just (URL "http://mit.com"))