diff --git a/Data/HighJson/Swagger.hs b/Data/HighJson/Swagger.hs new file mode 100644 --- /dev/null +++ b/Data/HighJson/Swagger.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +module Data.HighJson.Swagger + ( makeDeclareNamedSchema, makeDeclareNamedSchema', DeclM + ) +where + +import Control.Lens +import Data.HVect (AllHave) +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import Data.HighJson +import Data.Monoid +import Data.Proxy +import Data.Swagger +import Data.Swagger.Declare +import qualified Data.HashMap.Strict.InsOrd as IOM +import qualified Data.Text as T + +type DeclM = Declare (Definitions Schema) + +-- | Automatically generate a 'NamedSchema' from a 'HighSpec' +makeDeclareNamedSchema :: + (AllHave ToSchema ts, AllHave ToJSON ts) + => HighSpec k ts + -> f k + -> DeclM NamedSchema +makeDeclareNamedSchema spec = makeDeclareNamedSchema' spec Nothing + +-- | Automatically generate a 'NamedSchema' from a 'HighSpec' while optionally +-- providing an example value +makeDeclareNamedSchema' :: + (AllHave ToSchema ts, AllHave ToJSON ts) + => HighSpec k ts + -> Maybe k + -- ^ example value + -> f k + -> DeclM NamedSchema +makeDeclareNamedSchema' spec exVal _ = + do (props, reqs) <- + case hs_bodySpec spec of + BodySpecRecord r -> computeRecProperties r + BodySpecSum r -> computeSumProperties r + let (minProps, maxProps) = + case hs_bodySpec spec of + BodySpecSum _ -> (Just 1, Just 1) + BodySpecRecord _ -> + (Just (fromIntegral $ length reqs), Just (fromIntegral $ length props)) + pure $ NamedSchema (Just $ hs_name spec) $ + mempty + & type_ .~ SwaggerObject + & description .~ hs_description spec + & properties .~ props + & required .~ reqs + & maxProperties .~ maxProps + & minProperties .~ minProps + & example .~ fmap (jsonSerializer spec) exVal + +computeSumProperties :: + forall k ts. AllHave ToSchema ts + => SumSpec k ts + -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName]) +computeSumProperties fs = + go (ss_options fs) (mempty, mempty) + where + go :: + forall qs. AllHave ToSchema qs + => SumOptions k qs + -> (InsOrdHashMap T.Text (Referenced Schema), [ParamName]) + -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName]) + go spec (props, reqs) = + case spec of + SOEmpty -> + pure (props, reqs) + (key :: SumOption k t) :|: rest -> + do fieldSchema <- declareSchemaRef (Proxy :: Proxy t) + let fld = + IOM.singleton (so_jsonKey key) fieldSchema + go rest (fld <> props, reqs) + +computeRecProperties :: + forall k ts. AllHave ToSchema ts + => RecordSpec k ts + -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName]) +computeRecProperties fs = + go (rs_fields fs) (mempty, mempty) + where + go :: + forall qs. AllHave ToSchema qs + => RecordFields k qs + -> (InsOrdHashMap T.Text (Referenced Schema), [ParamName]) + -> DeclM (InsOrdHashMap T.Text (Referenced Schema), [ParamName]) + go spec (props, reqs) = + case spec of + RFEmpty -> + pure (props, reqs) + (key :: RecordField k t) :+: rest -> + do fieldSchema <- declareSchemaRef (Proxy :: Proxy t) + let fld = + IOM.singleton (rf_jsonKey key) fieldSchema + reqs' = + if not (rf_optional key) + then (rf_jsonKey key : reqs) + else reqs + go rest (fld <> props, reqs') diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Alexander Thiemann + +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/highjson-swagger.cabal b/highjson-swagger.cabal new file mode 100644 --- /dev/null +++ b/highjson-swagger.cabal @@ -0,0 +1,54 @@ +name: highjson-swagger +version: 0.3.0.0 +synopsis: Derive swagger instances from highjson specs +description: Derive swagger instances from highjson specs +homepage: https://github.com/agrafix/highjson +bug-reports: https://github.com/agrafix/highjson/issues +license: MIT +license-file: LICENSE +author: Alexander Thiemann +maintainer: Alexander Thiemann +copyright: (c) 2017 Alexander Thiemann +category: Text, Web, JSON +build-type: Simple +stability: experimental +cabal-version: >=1.10 +tested-with: GHC==8.0.1 + +library + exposed-modules: + Data.HighJson.Swagger + build-depends: + base >=4.8 && <5, + highjson >= 0.3, + swagger2 >= 2.1.3, + text, + lens, + insert-ordered-containers >= 0.2, + hvect + hs-source-dirs: . + default-language: Haskell2010 + +test-suite highjson-swagger-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Data.HighJson.SwaggerSpec + build-depends: + QuickCheck >=2.8, + base, + highjson, + highjson-swagger, + aeson, + hspec >= 2.0, + text, + lens, + swagger2, + bytestring + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans + +source-repository head + type: git + location: git://github.com/agrafix/highjson.git diff --git a/test/Data/HighJson/SwaggerSpec.hs b/test/Data/HighJson/SwaggerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/HighJson/SwaggerSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.HighJson.SwaggerSpec + ( spec ) +where + +import Data.HighJson +import Data.HighJson.Swagger + +import Data.Swagger +import Test.Hspec +import Test.QuickCheck hiding (Success) +import qualified Data.Text as T + +data SomeDummy + = SomeDummy + { sd_int :: Int + , sd_bool :: Bool + , sd_text :: T.Text + , sd_either :: Either Bool T.Text + , sd_maybe :: Maybe Int + } deriving (Show, Eq) + +someDummySpec :: HighSpec SomeDummy '[Int, Bool, T.Text, Either Bool T.Text, Maybe Int] +someDummySpec = + recSpec "Some Dummy" Nothing SomeDummy $ + "int" .= sd_int + :+: "bool" .= sd_bool + :+: "text" .= sd_text + :+: "either" .= sd_either + :+: "maybe" .=? sd_maybe + :+: RFEmpty + +instance ToJSON SomeDummy where + toJSON = jsonSerializer someDummySpec + toEncoding = jsonEncoder someDummySpec + +newtype SomeText = SomeText { unSomeText :: T.Text } + +instance Arbitrary SomeText where + arbitrary = SomeText . T.pack <$> listOf1 (choose ('A', 'Z')) + +instance Arbitrary SomeDummy where + arbitrary = + SomeDummy + <$> arbitrary + <*> arbitrary + <*> (unSomeText <$> arbitrary) + <*> ebt + <*> arbitrary + where + ebt = + do v <- arbitrary + case v of + Left b -> pure (Left b) + Right (SomeText t) -> pure (Right t) + +instance ToSchema SomeDummy where + declareNamedSchema p = makeDeclareNamedSchema someDummySpec p + +spec :: Spec +spec = + it "schema and serializer match" $ property $ \(t :: SomeDummy) -> + validateToJSON t `shouldBe` [] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Data.HighJson.SwaggerSpec + +import Test.Hspec + +main :: IO () +main = hspec $ + do Data.HighJson.SwaggerSpec.spec