Skip to content

Commit fc403a0

Browse files
phadejphadej
committed
Support servant-0.10
1 parent 78716f4 commit fc403a0

File tree

6 files changed

+215
-67
lines changed

6 files changed

+215
-67
lines changed

‎Setup.lhs

Lines changed: 140 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -1,46 +1,162 @@
1-
#!/usr/bin/runhaskell
21
\begin{code}
3-
{-# OPTIONS_GHC -Wall #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
#ifndef MIN_VERSION_Cabal
5+
#define MIN_VERSION_Cabal(x,y,z) 0
6+
#endif
7+
#ifndef MIN_VERSION_directory
8+
#define MIN_VERSION_directory(x,y,z) 0
9+
#endif
10+
#if MIN_VERSION_Cabal(1,24,0)
11+
#define InstalledPackageId UnitId
12+
#endif
413
module Main (main) where
514
15+
import Control.Monad ( when )
616
import Data.List ( nub )
7-
import Data.Version ( showVersion )
8-
import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
9-
import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
17+
import Distribution.Package ( InstalledPackageId )
18+
import Distribution.Package ( PackageId, Package (..), packageVersion )
19+
import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))
1020
import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
1121
import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
1222
import Distribution.Simple.BuildPaths ( autogenModulesDir )
13-
import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )
14-
import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
15-
import Distribution.Verbosity ( Verbosity )
23+
import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)
24+
import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )
25+
import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))
26+
import Distribution.Text ( display , simpleParse )
1627
import System.FilePath ( (</>) )
1728
29+
#if MIN_VERSION_Cabal(1,25,0)
30+
import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )
31+
#endif
32+
33+
#if MIN_VERSION_directory(1,2,2)
34+
import System.Directory (makeAbsolute)
35+
#else
36+
import System.Directory (getCurrentDirectory)
37+
import System.FilePath (isAbsolute)
38+
39+
makeAbsolute :: FilePath -> IO FilePath
40+
makeAbsolute p | isAbsolute p = return p
41+
| otherwise = do
42+
cwd <- getCurrentDirectory
43+
return $ cwd </> p
44+
#endif
45+
1846
main :: IO ()
1947
main = defaultMainWithHooks simpleUserHooks
2048
{ buildHook = \pkg lbi hooks flags -> do
21-
generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
49+
generateBuildModule flags pkg lbi
2250
buildHook simpleUserHooks pkg lbi hooks flags
2351
}
2452
25-
generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
26-
generateBuildModule verbosity pkg lbi = do
27-
let dir = autogenModulesDir lbi
28-
createDirectoryIfMissingVerbose verbosity True dir
29-
withLibLBI pkg lbi $ \_ libcfg -> do
30-
withTestLBI pkg lbi $ \suite suitecfg -> do
31-
rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
32-
[ "module Build_" ++ testName suite ++ " where"
53+
generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
54+
generateBuildModule flags pkg lbi = do
55+
let verbosity = fromFlag (buildVerbosity flags)
56+
let distPref = fromFlag (buildDistPref flags)
57+
58+
-- Package DBs
59+
let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]
60+
let dbFlags = "-hide-all-packages" : packageDbArgs dbStack
61+
62+
withLibLBI pkg lbi $ \lib libcfg -> do
63+
let libBI = libBuildInfo lib
64+
65+
-- modules
66+
let modules = exposedModules lib ++ otherModules libBI
67+
-- it seems that doctest is happy to take in module names, not actual files!
68+
let module_sources = modules
69+
70+
-- We need the directory with library's cabal_macros.h!
71+
#if MIN_VERSION_Cabal(1,25,0)
72+
let libAutogenDir = autogenComponentModulesDir lbi libcfg
73+
#else
74+
let libAutogenDir = autogenModulesDir lbi
75+
#endif
76+
77+
-- Lib sources and includes
78+
iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI
79+
includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI
80+
81+
-- CPP includes, i.e. include cabal_macros.h
82+
let cppFlags = map ("-optP"++) $
83+
[ "-include", libAutogenDir ++ "/cabal_macros.h" ]
84+
++ cppOptions libBI
85+
86+
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == "doctests") $ do
87+
88+
-- get and create autogen dir
89+
#if MIN_VERSION_Cabal(1,25,0)
90+
let testAutogenDir = autogenComponentModulesDir lbi suitecfg
91+
#else
92+
let testAutogenDir = autogenModulesDir lbi
93+
#endif
94+
createDirectoryIfMissingVerbose verbosity True testAutogenDir
95+
96+
-- write autogen'd file
97+
rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines
98+
[ "module Build_doctests where"
99+
, ""
100+
-- -package-id etc. flags
101+
, "pkgs :: [String]"
102+
, "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)
33103
, ""
34-
, "autogen_dir :: String"
35-
, "autogen_dir = " ++ show dir
104+
, "flags :: [String]"
105+
, "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)
36106
, ""
37-
, "deps :: [String]"
38-
, "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
107+
, "module_sources :: [String]"
108+
, "module_sources = " ++ show (map display module_sources)
39109
]
40110
where
41-
formatdeps = map (formatone . snd)
42-
formatone p = case packageName p of
43-
PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
111+
-- we do this check in Setup, as then doctests don't need to depend on Cabal
112+
isOldCompiler = maybe False id $ do
113+
a <- simpleParse $ showCompilerId $ compiler lbi
114+
b <- simpleParse "7.5"
115+
return $ packageVersion (a :: PackageId) < b
116+
117+
formatDeps = map formatOne
118+
formatOne (installedPkgId, pkgId)
119+
-- The problem is how different cabal executables handle package databases
120+
-- when doctests depend on the library
121+
| packageId pkg == pkgId = "-package=" ++ display pkgId
122+
| otherwise = "-package-id=" ++ display installedPkgId
123+
124+
-- From Distribution.Simple.Program.GHC
125+
packageDbArgs :: [PackageDB] -> [String]
126+
packageDbArgs | isOldCompiler = packageDbArgsConf
127+
| otherwise = packageDbArgsDb
128+
129+
-- GHC <7.6 uses '-package-conf' instead of '-package-db'.
130+
packageDbArgsConf :: [PackageDB] -> [String]
131+
packageDbArgsConf dbstack = case dbstack of
132+
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
133+
(GlobalPackageDB:dbs) -> ("-no-user-package-conf")
134+
: concatMap specific dbs
135+
_ -> ierror
136+
where
137+
specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]
138+
specific _ = ierror
139+
ierror = error $ "internal error: unexpected package db stack: "
140+
++ show dbstack
141+
142+
-- GHC >= 7.6 uses the '-package-db' flag. See
143+
-- https://ghc.haskell.org/trac/ghc/ticket/5977.
144+
packageDbArgsDb :: [PackageDB] -> [String]
145+
-- special cases to make arguments prettier in common scenarios
146+
packageDbArgsDb dbstack = case dbstack of
147+
(GlobalPackageDB:UserPackageDB:dbs)
148+
| all isSpecific dbs -> concatMap single dbs
149+
(GlobalPackageDB:dbs)
150+
| all isSpecific dbs -> "-no-user-package-db"
151+
: concatMap single dbs
152+
dbs -> "-clear-package-db"
153+
: concatMap single dbs
154+
where
155+
single (SpecificPackageDB db) = [ "-package-db=" ++ db ]
156+
single GlobalPackageDB = [ "-global-package-db" ]
157+
single UserPackageDB = [ "-user-package-db" ]
158+
isSpecific (SpecificPackageDB _) = True
159+
isSpecific _ = False
44160
45161
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
46162
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

‎servant-swagger.cabal

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -44,13 +44,13 @@ library
4444
Servant.Swagger.Internal.TypeLevel.Every
4545
Servant.Swagger.Internal.TypeLevel.TMap
4646
hs-source-dirs: src
47-
build-depends: aeson >=0.11.2.0 && <1.1
47+
build-depends: aeson >=0.11.2.0 && <1.2
4848
, base >=4.7.0.0 && <4.10
4949
, bytestring >=0.10.4.0 && <0.11
5050
, http-media >=0.6.3 && <0.7
5151
, insert-ordered-containers >=0.1.0.0 && <0.3
5252
, lens >=4.7.0.1 && <4.16
53-
, servant >=0.5 && <0.10
53+
, servant >=0.5 && <0.11
5454
, swagger2 >=2.1 && <2.2
5555
, text >=1.2.0.6 && <1.3
5656
, unordered-containers >=0.2.5.1 && <0.3
@@ -65,10 +65,14 @@ test-suite doctests
6565
base,
6666
directory >= 1.0,
6767
doctest >= 0.11 && <0.12,
68+
servant >= 0.10,
69+
QuickCheck,
70+
lens-aeson,
6871
filepath
6972
default-language: Haskell2010
7073
hs-source-dirs: test
71-
main-is: DocTest.hs
74+
build-tools: hsc2hs
75+
main-is: doctests.hs
7276
type: exitcode-stdio-1.0
7377

7478
test-suite spec
@@ -82,7 +86,7 @@ test-suite spec
8286
, hspec
8387
, QuickCheck
8488
, lens
85-
, servant
89+
, servant >= 0.10
8690
, servant-swagger
8791
, swagger2
8892
, text

‎src/Servant/Swagger.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -98,7 +98,7 @@ import Servant.Swagger.Test
9898
-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:
9999
--
100100
-- >>> BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI)
101-
-- {"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"}}}
101+
-- {"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"}}}
102102
--
103103
-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.
104104
--
@@ -119,7 +119,7 @@ import Servant.Swagger.Test
119119
-- & info.license ?~ "MIT"
120120
-- & host ?~ "example.com"
121121
-- :}
122-
-- {"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"}}}
122+
-- {"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"}}}
123123
--
124124
-- It is also useful to annotate or modify certain endpoints.
125125
-- @'subOperations'@ provides a convenient way to zoom into a part of an API.
@@ -137,7 +137,7 @@ import Servant.Swagger.Test
137137
-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]
138138
-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]
139139
-- :}
140-
-- {"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"}]}
140+
-- {"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"}]}
141141
--
142142
-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.
143143

‎test/DocTest.hs

Lines changed: 0 additions & 30 deletions
This file was deleted.

‎test/Servant/SwaggerSpec.hs

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ todoAPI = [aesonQQ|
102102
},
103103
"404": { "description": "`id` not found" }
104104
},
105-
"produces": [ "application/json" ],
105+
"produces": [ "application/json;charset=utf-8" ],
106106
"parameters":
107107
[
108108
{
@@ -259,7 +259,7 @@ hackageAPI = [aesonQQ|
259259
}
260260
},
261261
"produces":[
262-
"application/json"
262+
"application/json;charset=utf-8"
263263
],
264264
"tags":[
265265
"users"
@@ -280,7 +280,7 @@ hackageAPI = [aesonQQ|
280280
}
281281
},
282282
"produces":[
283-
"application/json"
283+
"application/json;charset=utf-8"
284284
],
285285
"tags":[
286286
"packages"
@@ -301,7 +301,7 @@ hackageAPI = [aesonQQ|
301301
}
302302
},
303303
"produces":[
304-
"application/json"
304+
"application/json;charset=utf-8"
305305
],
306306
"parameters":[
307307
{
@@ -363,7 +363,7 @@ getPostAPI = [aesonQQ|
363363
"description":""
364364
}
365365
},
366-
"produces":[ "application/json" ]
366+
"produces":[ "application/json;charset=utf-8" ]
367367
},
368368
"get":{
369369
"responses":{
@@ -374,7 +374,7 @@ getPostAPI = [aesonQQ|
374374
"description":""
375375
}
376376
},
377-
"produces":[ "application/json" ],
377+
"produces":[ "application/json;charset=utf-8" ],
378378
"tags":[ "get" ]
379379
}
380380
}

0 commit comments

Comments
 (0)