diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +1.1.2.1 +--- + +* Notes: + * `servant-0.10` compatible release + 1.1.2 --- diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,48 +1,178 @@ -#!/usr/bin/runhaskell \begin{code} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) + +#if MIN_VERSION_cabal_doctest(1,0,0) +import Distribution.Extra.Doctest ( generateBuildModule ) +#else + +-- Otherwise we provide a shim + +#ifndef MIN_VERSION_Cabal +#define MIN_VERSION_Cabal(x,y,z) 0 +#endif +#ifndef MIN_VERSION_directory +#define MIN_VERSION_directory(x,y,z) 0 +#endif +#if MIN_VERSION_Cabal(1,24,0) +#define InstalledPackageId UnitId +#endif + +import Control.Monad ( when ) +import Data.List ( nub ) +import Data.String ( fromString ) +import Distribution.Package ( InstalledPackageId ) +import Distribution.Package ( PackageId, Package (..), packageVersion ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..)) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) +import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag) +import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler ) +import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..)) +import Distribution.Text ( display , simpleParse ) import System.FilePath ( () ) -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } +#if MIN_VERSION_Cabal(1,25,0) +import Distribution.Simple.BuildPaths ( autogenComponentModulesDir ) +#endif -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" +#if MIN_VERSION_directory(1,2,2) +import System.Directory (makeAbsolute) +#else +import System.Directory (getCurrentDirectory) +import System.FilePath (isAbsolute) + +makeAbsolute :: FilePath -> IO FilePath +makeAbsolute p | isAbsolute p = return p + | otherwise = do + cwd <- getCurrentDirectory + return $ cwd p +#endif + +generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule testsuiteName flags pkg lbi = do + let verbosity = fromFlag (buildVerbosity flags) + let distPref = fromFlag (buildDistPref flags) + + -- Package DBs + let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref "package.conf.inplace" ] + let dbFlags = "-hide-all-packages" : packageDbArgs dbStack + + withLibLBI pkg lbi $ \lib libcfg -> do + let libBI = libBuildInfo lib + + -- modules + let modules = exposedModules lib ++ otherModules libBI + -- it seems that doctest is happy to take in module names, not actual files! + let module_sources = modules + + -- We need the directory with library's cabal_macros.h! +#if MIN_VERSION_Cabal(1,25,0) + let libAutogenDir = autogenComponentModulesDir lbi libcfg +#else + let libAutogenDir = autogenModulesDir lbi +#endif + + -- Lib sources and includes + iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI + includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI + + -- CPP includes, i.e. include cabal_macros.h + let cppFlags = map ("-optP"++) $ + [ "-include", libAutogenDir ++ "/cabal_macros.h" ] + ++ cppOptions libBI + + withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do + + -- get and create autogen dir +#if MIN_VERSION_Cabal(1,25,0) + let testAutogenDir = autogenComponentModulesDir lbi suitecfg +#else + let testAutogenDir = autogenModulesDir lbi +#endif + createDirectoryIfMissingVerbose verbosity True testAutogenDir + + -- write autogen'd file + rewriteFile (testAutogenDir "Build_doctests.hs") $ unlines + [ "module Build_doctests where" , "" - , "autogen_dir :: String" - , "autogen_dir = " ++ show dir + -- -package-id etc. flags + , "pkgs :: [String]" + , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg) , "" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + , "flags :: [String]" + , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags) + , "" + , "module_sources :: [String]" + , "module_sources = " ++ show (map display module_sources) ] where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + -- we do this check in Setup, as then doctests don't need to depend on Cabal + isOldCompiler = maybe False id $ do + a <- simpleParse $ showCompilerId $ compiler lbi + b <- simpleParse "7.5" + return $ packageVersion (a :: PackageId) < b + formatDeps = map formatOne + formatOne (installedPkgId, pkgId) + -- The problem is how different cabal executables handle package databases + -- when doctests depend on the library + | packageId pkg == pkgId = "-package=" ++ display pkgId + | otherwise = "-package-id=" ++ display installedPkgId + + -- From Distribution.Simple.Program.GHC + packageDbArgs :: [PackageDB] -> [String] + packageDbArgs | isOldCompiler = packageDbArgsConf + | otherwise = packageDbArgsDb + + -- GHC <7.6 uses '-package-conf' instead of '-package-db'. + packageDbArgsConf :: [PackageDB] -> [String] + packageDbArgsConf dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> ("-no-user-package-conf") + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ] + specific _ = ierror + ierror = error $ "internal error: unexpected package db stack: " + ++ show dbstack + + -- GHC >= 7.6 uses the '-package-db' flag. See + -- https://ghc.haskell.org/trac/ghc/ticket/5977. + packageDbArgsDb :: [PackageDB] -> [String] + -- special cases to make arguments prettier in common scenarios + packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB:dbs) + | all isSpecific dbs -> "-no-user-package-db" + : concatMap single dbs + dbs -> "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = [ "-package-db=" ++ db ] + single GlobalPackageDB = [ "-global-package-db" ] + single UserPackageDB = [ "-user-package-db" ] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False + testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys +#endif + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule "doctests" flags pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } \end{code} diff --git a/servant-swagger.cabal b/servant-swagger.cabal --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -1,5 +1,5 @@ name: servant-swagger -version: 1.1.2 +version: 1.1.2.1 synopsis: Generate Swagger specification for your servant API. description: Please see README.md homepage: https://github.com/haskell-servant/servant-swagger @@ -12,6 +12,10 @@ category: Web build-type: Custom cabal-version: >=1.10 +tested-with: + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2 extra-source-files: README.md , CHANGELOG.md @@ -29,6 +33,12 @@ type: git location: https://github.com/haskell-servant/servant-swagger.git +custom-setup + setup-depends: + base >=4.7 && <4.10, + Cabal >= 1.18 && <2.0, + cabal-doctest >=1 && <1.1 + library ghc-options: -Wall exposed-modules: @@ -44,13 +54,13 @@ Servant.Swagger.Internal.TypeLevel.Every Servant.Swagger.Internal.TypeLevel.TMap hs-source-dirs: src - build-depends: aeson >=0.11.2.0 && <1.1 + build-depends: aeson >=0.11.2.0 && <1.2 , base >=4.7.0.0 && <4.10 , bytestring >=0.10.4.0 && <0.11 , http-media >=0.6.3 && <0.7 , insert-ordered-containers >=0.1.0.0 && <0.3 - , lens >=4.7.0.1 && <4.15 - , servant >=0.5 && <0.9 + , lens >=4.7.0.1 && <4.16 + , servant >=0.5 && <0.11 , swagger2 >=2.1 && <2.2 , text >=1.2.0.6 && <1.3 , unordered-containers >=0.2.5.1 && <0.3 @@ -64,11 +74,13 @@ build-depends: base, directory >= 1.0, - doctest >= 0.11 && <0.12, + doctest >= 0.11.1 && <0.12, + servant >= 0.10, + QuickCheck, filepath default-language: Haskell2010 hs-source-dirs: test - main-is: DocTest.hs + main-is: doctests.hs type: exitcode-stdio-1.0 test-suite spec @@ -82,7 +94,7 @@ , hspec , QuickCheck , lens - , servant + , servant >= 0.10 , servant-swagger , swagger2 , text diff --git a/src/Servant/Swagger.hs b/src/Servant/Swagger.hs --- a/src/Servant/Swagger.hs +++ b/src/Servant/Swagger.hs @@ -98,7 +98,7 @@ -- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@: -- -- >>> BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI) --- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}} +-- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json;charset=utf-8"],"produces":["application/json;charset=utf-8"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json;charset=utf-8"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}} -- -- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas. -- @@ -119,7 +119,7 @@ -- & info.license ?~ "MIT" -- & host ?~ "example.com" -- :} --- {"swagger":"2.0","info":{"version":"1.0","title":"User API","license":{"name":"MIT"},"description":"This is an API for the Users service"},"host":"example.com","paths":{"/":{"get":{"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}} +-- {"swagger":"2.0","info":{"version":"1.0","title":"User API","license":{"name":"MIT"},"description":"This is an API for the Users service"},"host":"example.com","paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json;charset=utf-8"],"produces":["application/json;charset=utf-8"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json;charset=utf-8"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}} -- -- It is also useful to annotate or modify certain endpoints. -- @'subOperations'@ provides a convenient way to zoom into a part of an API. @@ -137,7 +137,7 @@ -- & applyTagsFor getOps ["get" & description ?~ "GET operations"] -- & applyTagsFor postOps ["post" & description ?~ "POST operations"] -- :} --- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"tags":["get"],"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"tags":["post"],"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"tags":["get"],"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}},"tags":[{"name":"get","description":"GET operations"},{"name":"post","description":"POST operations"}]} +-- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"tags":["get"],"produces":["application/json;charset=utf-8"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"tags":["post"],"consumes":["application/json;charset=utf-8"],"produces":["application/json;charset=utf-8"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"tags":["get"],"produces":["application/json;charset=utf-8"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}},"tags":[{"name":"get","description":"GET operations"},{"name":"post","description":"POST operations"}]} -- -- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API. diff --git a/test/DocTest.hs b/test/DocTest.hs deleted file mode 100644 --- a/test/DocTest.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main where - -import Build_doctests (autogen_dir, deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -main :: IO () -main = getSources >>= \sources -> doctest $ - "-isrc" - : ("-i" ++ autogen_dir) - : "-optP-include" - : ("-optP" ++ autogen_dir ++ "/cabal_macros.h") - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs --- a/test/Servant/SwaggerSpec.hs +++ b/test/Servant/SwaggerSpec.hs @@ -102,7 +102,7 @@ }, "404": { "description": "`id` not found" } }, - "produces": [ "application/json" ], + "produces": [ "application/json;charset=utf-8" ], "parameters": [ { @@ -259,7 +259,7 @@ } }, "produces":[ - "application/json" + "application/json;charset=utf-8" ], "tags":[ "users" @@ -280,7 +280,7 @@ } }, "produces":[ - "application/json" + "application/json;charset=utf-8" ], "tags":[ "packages" @@ -301,7 +301,7 @@ } }, "produces":[ - "application/json" + "application/json;charset=utf-8" ], "parameters":[ { @@ -363,7 +363,7 @@ "description":"" } }, - "produces":[ "application/json" ] + "produces":[ "application/json;charset=utf-8" ] }, "get":{ "responses":{ @@ -374,7 +374,7 @@ "description":"" } }, - "produces":[ "application/json" ], + "produces":[ "application/json;charset=utf-8" ], "tags":[ "get" ] } } diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2012-14 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module provides doctests for a project based on the actual versions +-- of the packages it was built with. It requires a corresponding Setup.lhs +-- to be added to the project +----------------------------------------------------------------------------- +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources