August 2017 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-servant-purescript for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-purescript for openSUSE:Factory checked in at 2017-08-31 20:59:22 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-purescript (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-purescript.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-purescript" Thu Aug 31 20:59:22 2017 rev:2 rq:513489 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-purescript/ghc-servant-purescript.changes 2017-05-10 20:47:36.711448027 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-purescript.new/ghc-servant-purescript.changes 2017-08-31 20:59:24.886536711 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:34 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- servant-purescript-0.6.0.0.tar.gz New: ---- servant-purescript-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-purescript.spec ++++++ --- /var/tmp/diff_new_pack.ht4LqB/_old 2017-08-31 20:59:25.966384989 +0200 +++ /var/tmp/diff_new_pack.ht4LqB/_new 2017-08-31 20:59:25.970384427 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-purescript %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.6.0.0 +Version: 0.8.0.0 Release: 0 Summary: Generate PureScript accessor functions for you servant API License: BSD-3-Clause ++++++ servant-purescript-0.6.0.0.tar.gz -> servant-purescript-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-purescript-0.6.0.0/servant-purescript.cabal new/servant-purescript-0.8.0.0/servant-purescript.cabal --- old/servant-purescript-0.6.0.0/servant-purescript.cabal 2016-09-28 11:42:13.000000000 +0200 +++ new/servant-purescript-0.8.0.0/servant-purescript.cabal 2017-05-03 09:09:21.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-purescript -version: 0.6.0.0 +version: 0.8.0.0 synopsis: Generate PureScript accessor functions for you servant API description: Please see README.md homepage: https://github.com/eskimor/servant-purescript#readme diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-purescript-0.6.0.0/src/Servant/PureScript/CodeGen.hs new/servant-purescript-0.8.0.0/src/Servant/PureScript/CodeGen.hs --- old/servant-purescript-0.6.0.0/src/Servant/PureScript/CodeGen.hs 2016-09-28 10:16:14.000000000 +0200 +++ new/servant-purescript-0.8.0.0/src/Servant/PureScript/CodeGen.hs 2017-05-03 09:09:21.000000000 +0200 @@ -88,7 +88,7 @@ genSignature :: Text -> [PSType] -> Maybe PSType -> Doc -genSignature = genSignatureBuilder $ "forall eff m." <+/> "(MonadReader (SPSettings_ SPParams_) m, MonadError AjaxError m, MonadAff ( ajax :: AJAX | eff) m)" <+/> "=>" +genSignature = genSignatureBuilder $ "forall eff m." <+/> "MonadAsk (SPSettings_ SPParams_) m => MonadError AjaxError m => MonadAff ( ajax :: AJAX | eff) m" <+/> "=>" genSignatureBuilder :: Doc -> Text -> [PSType] -> Maybe PSType -> Doc genSignatureBuilder constraint fnName params mRet = fName <+> "::" <+> align (constraint <+/> parameterString) @@ -121,7 +121,7 @@ </> ", headers =" <+> "defaultRequest.headers <> reqHeaders" </> case req ^. reqBody of Nothing -> "}" - Just _ -> ", content =" <+> "toNullable <<< Just <<< printJson <<< encodeJson $ reqBody" </> "}" + Just _ -> ", content =" <+> "toNullable <<< Just <<< stringify <<< encodeJson $ reqBody" </> "}" ) </> "affResp <- affjax affReq" </> "getResult affReq decodeJson affResp" <> line diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-purescript-0.6.0.0/src/Servant/PureScript/Internal.hs new/servant-purescript-0.8.0.0/src/Servant/PureScript/Internal.hs --- old/servant-purescript-0.6.0.0/src/Servant/PureScript/Internal.hs 2016-09-21 14:34:12.000000000 +0200 +++ new/servant-purescript-0.8.0.0/src/Servant/PureScript/Internal.hs 2017-05-03 09:09:21.000000000 +0200 @@ -17,10 +17,10 @@ import Data.Char import Data.Monoid import Data.Proxy -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T import Data.Typeable import Language.PureScript.Bridge @@ -73,7 +73,7 @@ data Settings = Settings { - _apiModuleName :: Text + _apiModuleName :: Text -- | This function parameters should instead be put in a Reader monad. -- -- 'baseUrl' will be put there by default, you can add additional parameters. @@ -81,8 +81,8 @@ -- If your API uses a given parameter name multiple times with different types, -- only the ones matching the type of the first occurrence -- will be put in the Reader monad, all others will still be passed as function parameter. -, _readerParams :: Set ParamName -, _standardImports :: ImportLines +, _readerParams :: Set ParamName +, _standardImports :: ImportLines -- | If you want codegen for servant-subscriber, set this to True. See the central-counter example -- for a simple usage case. , _generateSubscriberAPI :: Bool @@ -94,19 +94,18 @@ _apiModuleName = "ServerAPI" , _readerParams = Set.singleton baseURLId , _standardImports = importsFromList - [ ImportLine "Control.Monad.Reader.Class" (Set.fromList [ "class MonadReader", "ask" ]) + [ ImportLine "Control.Monad.Reader.Class" (Set.fromList [ "class MonadAsk", "ask" ]) , ImportLine "Control.Monad.Error.Class" (Set.fromList [ "class MonadError" ]) - , ImportLine "Control.Monad.Aff.Class" (Set.fromList [ "class MonadAff", "liftAff" ]) + , ImportLine "Control.Monad.Aff.Class" (Set.fromList [ "class MonadAff" ]) , ImportLine "Network.HTTP.Affjax" (Set.fromList [ "AJAX" ]) - , ImportLine "Global" (Set.fromList [ "encodeURIComponent" ]) -- from package globals - , ImportLine "Data.Nullable" (Set.fromList [ "Nullable()", "toNullable" ]) - , ImportLine "Servant.PureScript.Affjax" (Set.fromList [ "defaultRequest", "affjax", "AjaxError(..)" ]) + , ImportLine "Data.Nullable" (Set.fromList [ "toNullable" ]) + , ImportLine "Servant.PureScript.Affjax" (Set.fromList [ "AjaxError", "defaultRequest", "affjax" ]) , ImportLine "Servant.PureScript.Settings" (Set.fromList [ "SPSettings_(..)", "gDefaultToURLPiece" ]) , ImportLine "Servant.PureScript.Util" (Set.fromList [ "encodeListQuery", "encodeURLPiece", "encodeQueryItem", "getResult", "encodeHeader" ]) , ImportLine "Prim" (Set.fromList [ "String" ]) -- For baseURL! , ImportLine "Data.Argonaut.Generic.Aeson" (Set.fromList [ "encodeJson", "decodeJson" ]) -- Should not be necessary - compiler bug! , ImportLine "Data.Maybe" (Set.fromList [ "Maybe(..)"]) - , ImportLine "Data.Argonaut.Printer" (Set.fromList [ "printJson" ]) + , ImportLine "Data.Argonaut.Core" (Set.fromList [ "stringify" ]) ] , _generateSubscriberAPI = False } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-purescript-0.6.0.0/src/Servant/PureScript/MakeRequests.hs new/servant-purescript-0.8.0.0/src/Servant/PureScript/MakeRequests.hs --- old/servant-purescript-0.6.0.0/src/Servant/PureScript/MakeRequests.hs 2016-08-30 12:38:12.000000000 +0200 +++ new/servant-purescript-0.8.0.0/src/Servant/PureScript/MakeRequests.hs 2017-05-03 09:09:21.000000000 +0200 @@ -11,16 +11,18 @@ import Control.Lens hiding (List) import Data.Map (Map) -import Data.Maybe (mapMaybe, maybeToList) import Data.Proxy (Proxy (Proxy)) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Language.PureScript.Bridge -import Language.PureScript.Bridge (buildBridge, defaultBridge) -import Language.PureScript.Bridge.PSTypes (psString, psUnit) -import Network.HTTP.Types.URI (urlEncode) +import Language.PureScript.Bridge (ImportLine (..), + PSType, + buildBridge, + defaultBridge, + importsFromList, + mergeImportLines, + mkTypeInfo) import Servant.Foreign import Servant.PureScript.CodeGen hiding (genBuildHeader, genBuildHeaders, @@ -86,7 +88,7 @@ genSignature :: Text -> [PSType] -> Maybe PSType -> Doc -genSignature = genSignatureBuilder $ "forall m." <+/> "MonadReader (SPSettings_ SPParams_) m" <+/> "=>" +genSignature = genSignatureBuilder $ "forall m." <+/> "MonadAsk (SPSettings_ SPParams_) m" <+/> "=>" genFnBody :: [PSParam] -> Req PSType -> Doc genFnBody rParams req = "do" @@ -106,7 +108,7 @@ </> ", httpQuery:" <+> "reqQuery" </> ", httpBody:" <+> case req ^. reqBody of Nothing -> "\"\"" - Just _ -> "printJson <<< encodeJson $ reqBody" + Just _ -> "stringify <<< encodeJson $ reqBody" </> "}") </> "pure spReq" ) <> "\n" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-purescript-0.6.0.0/src/Servant/PureScript/Subscriber.hs new/servant-purescript-0.8.0.0/src/Servant/PureScript/Subscriber.hs --- old/servant-purescript-0.6.0.0/src/Servant/PureScript/Subscriber.hs 2016-08-30 12:37:52.000000000 +0200 +++ new/servant-purescript-0.8.0.0/src/Servant/PureScript/Subscriber.hs 2017-05-03 09:09:21.000000000 +0200 @@ -22,10 +22,10 @@ import Servant.Foreign import Servant.PureScript.CodeGen (docIntercalate, genFnHead, genModuleHeader, + genSignatureBuilder, getReaderParams, psVar, reqToParams, - reqsToImportLines, - genSignatureBuilder) + reqsToImportLines) import Servant.PureScript.Internal import Servant.PureScript.MakeRequests hiding (genFnBody, genFunction, genModule, @@ -60,7 +60,7 @@ fnName = req ^. reqFuncName ^. camelCaseL responseType = case req ^. reqReturnType of Nothing -> psUnit - Just t -> t + Just t -> t allParamsList = makeTypedToUserParam responseType : baseURLParam : reqToParams req fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters @@ -73,7 +73,7 @@ genSignature :: Text -> [PSType] -> Maybe PSType -> Doc -genSignature = genSignatureBuilder $ "forall m a." <+/> "MonadReader (SPSettings_ SPParams_) m" <+/> "=>" +genSignature = genSignatureBuilder $ "forall m a." <+/> "MonadAsk (SPSettings_ SPParams_) m" <+/> "=>" genFnBody :: Text -> [Text] -> Doc genFnBody fName params = "do"

1 0

commit ghc-servant-mock for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-mock for openSUSE:Factory checked in at 2017-08-31 20:59:21 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-mock (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-mock.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-mock" Thu Aug 31 20:59:21 2017 rev:2 rq:513488 version:0.8.2 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-mock/ghc-servant-mock.changes 2017-05-10 20:51:55.646910124 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-mock.new/ghc-servant-mock.changes 2017-08-31 20:59:22.718841277 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:00 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.2 revision 1. + +------------------------------------------------------------------- Old: ---- servant-mock-0.8.1.1.tar.gz New: ---- servant-mock-0.8.2.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-mock.spec ++++++ --- /var/tmp/diff_new_pack.NxgmX5/_old 2017-08-31 20:59:23.734698547 +0200 +++ /var/tmp/diff_new_pack.NxgmX5/_new 2017-08-31 20:59:23.750696299 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-mock %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.8.1.1 +Version: 0.8.2 Release: 0 Summary: Derive a mock server for free from your servant API types License: BSD-3-Clause ++++++ servant-mock-0.8.1.1.tar.gz -> servant-mock-0.8.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-mock-0.8.1.1/CHANGELOG.md new/servant-mock-0.8.2/CHANGELOG.md --- old/servant-mock-0.8.1.1/CHANGELOG.md 2016-10-08 14:58:08.000000000 +0200 +++ new/servant-mock-0.8.2/CHANGELOG.md 2017-05-24 12:18:55.000000000 +0200 @@ -1,3 +1,15 @@ +0.8.2 +----- + +- Support for servant-0.11 + Add `HasMock EmptyAPI` instance + +0.8.1.2 +------- + +- Support for servant-0.10 +- Fix test with hspec-wai-0.8 + 0.8.1.1 ------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-mock-0.8.1.1/servant-mock.cabal new/servant-mock-0.8.2/servant-mock.cabal --- old/servant-mock-0.8.1.1/servant-mock.cabal 2016-10-08 15:01:55.000000000 +0200 +++ new/servant-mock-0.8.2/servant-mock.cabal 2017-05-24 12:18:55.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-mock -version: 0.8.1.1 +version: 0.8.2 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types @@ -11,7 +11,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2015-2016 Servant Contributors -category: Web +category: Servant, Web build-type: Simple extra-source-files: README.md CHANGELOG.md include/*.h cabal-version: >=1.10 @@ -33,8 +33,8 @@ base >=4.7 && <5, bytestring >=0.10.4 && <0.11, http-types >=0.8 && <0.10, - servant >=0.8 && <0.10, - servant-server >=0.8 && <0.10, + servant >=0.8 && <0.12, + servant-server >=0.8 && <0.12, transformers >=0.3 && <0.6, QuickCheck >=2.7 && <2.10, wai >=3.0 && <3.3 @@ -51,7 +51,7 @@ aeson, base, servant-mock, - servant-server, + servant-server >= 0.10, QuickCheck, warp if flag(example) @@ -72,7 +72,7 @@ bytestring-conversion, base, hspec, - hspec-wai, + hspec-wai >=0.8 && <0.9, QuickCheck, servant, servant-server, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-mock-0.8.1.1/src/Servant/Mock.hs new/servant-mock-0.8.2/src/Servant/Mock.hs --- old/servant-mock-0.8.1.1/src/Servant/Mock.hs 2016-10-08 14:58:08.000000000 +0200 +++ new/servant-mock-0.8.2/src/Servant/Mock.hs 2017-05-24 12:18:55.000000000 +0200 @@ -160,12 +160,21 @@ mock _ _ = mockArbitrary instance HasMock Raw context where +#if MIN_VERSION_servant(0,11,0) + mock _ _ = Tagged $ \_req respond -> do +#else mock _ _ = \_req respond -> do +#endif bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) +#if MIN_VERSION_servant(0,11,0) +instance HasMock EmptyAPI context where + mock _ _ = emptyServer +#endif + instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => HasMock (WithNamedContext name subContext rest) context where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-mock-0.8.1.1/test/Servant/MockSpec.hs new/servant-mock-0.8.2/test/Servant/MockSpec.hs --- old/servant-mock-0.8.1.1/test/Servant/MockSpec.hs 2016-10-08 14:58:08.000000000 +0200 +++ new/servant-mock-0.8.2/test/Servant/MockSpec.hs 2017-05-24 12:18:55.000000000 +0200 @@ -13,7 +13,7 @@ import Network.Wai import Servant.API import Test.Hspec hiding (pending) -import Test.Hspec.Wai +import Test.Hspec.Wai hiding (Body) import Test.QuickCheck import Servant @@ -64,7 +64,10 @@ with (return app) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ - matchBody = Just $ Aeson.encode ArbitraryBody + matchBody = MatchBody $ \ _ b -> + if b == Aeson.encode ArbitraryBody + then Nothing + else Just ("body not correct\n") } context "response headers" $ do @@ -77,8 +80,8 @@ with (toApp withHeader) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ - matchHeaders = return $ MatchHeader $ \ h -> - if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")] + matchHeaders = return $ MatchHeader $ \ h _ -> + if h == [("Content-Type", "application/json;charset=utf-8"), ("foo", "ArbitraryHeader")] then Nothing else Just ("headers not correct\n") } @@ -86,8 +89,8 @@ with (toApp withoutHeader) $ do it "works for no additional headers" $ do get "/" `shouldRespondWith` 200{ - matchHeaders = return $ MatchHeader $ \ h -> - if h == [("Content-Type", "application/json")] + matchHeaders = return $ MatchHeader $ \ h _ -> + if h == [("Content-Type", "application/json;charset=utf-8")] then Nothing else Just ("headers not correct\n") } ++++++ servant-mock.cabal ++++++ --- /var/tmp/diff_new_pack.NxgmX5/_old 2017-08-31 20:59:24.550583913 +0200 +++ /var/tmp/diff_new_pack.NxgmX5/_new 2017-08-31 20:59:24.570581103 +0200 @@ -1,82 +1,82 @@ -name: servant-mock -version: 0.8.1.1 -x-revision: 1 -synopsis: Derive a mock server for free from your servant API types -description: - Derive a mock server for free from your servant API types - . - See the @Servant.Mock@ module for the documentation and an example. -homepage: http://haskell-servant.readthedocs.org/ -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers(a)googlegroups.com -copyright: 2015-2016 Servant Contributors -category: Web -build-type: Simple -extra-source-files: README.md CHANGELOG.md include/*.h -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant-mock/issues - -source-repository head - type: git - location: http://github.com/haskell-servant/servant-mock.git - -flag example - description: Build the example too - default: True - manual: True - -library - exposed-modules: - Servant.Mock - build-depends: - base >=4.7 && <5, - bytestring >=0.10.4 && <0.11, - http-types >=0.8 && <0.10, - servant >=0.8 && <0.10, - servant-server >=0.8 && <0.10, - transformers >=0.3 && <0.6, - QuickCheck >=2.7 && <2.10, - wai >=3.0 && <3.3 - hs-source-dirs: src - default-language: Haskell2010 - include-dirs: include - ghc-options: -Wall - -executable mock-app - main-is: main.hs - hs-source-dirs: example - default-language: Haskell2010 - build-depends: - aeson, - base, - servant-mock, - servant-server, - QuickCheck, - warp - if flag(example) - buildable: True - else - buildable: False - ghc-options: -Wall - -test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs - other-modules: - Servant.MockSpec - build-depends: - bytestring-conversion, - base, - hspec, - hspec-wai <0.8, - QuickCheck, - servant, - servant-server, - servant-mock, - aeson, - wai +name: servant-mock +version: 0.8.2 +x-revision: 1 +synopsis: Derive a mock server for free from your servant API types +description: + Derive a mock server for free from your servant API types + . + See the @Servant.Mock@ module for the documentation and an example. +homepage: http://haskell-servant.readthedocs.org/ +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers(a)googlegroups.com +copyright: 2015-2016 Servant Contributors +category: Servant, Web +build-type: Simple +extra-source-files: README.md CHANGELOG.md include/*.h +cabal-version: >=1.10 +bug-reports: http://github.com/haskell-servant/servant-mock/issues + +source-repository head + type: git + location: http://github.com/haskell-servant/servant-mock.git + +flag example + description: Build the example too + default: True + manual: True + +library + exposed-modules: + Servant.Mock + build-depends: + base >=4.7 && <5, + bytestring >=0.10.4 && <0.11, + http-types >=0.8 && <0.10, + servant >=0.8 && <0.12, + servant-server >=0.8 && <0.12, + transformers >=0.3 && <0.6, + QuickCheck >=2.7 && <2.11, + wai >=3.0 && <3.3 + hs-source-dirs: src + default-language: Haskell2010 + include-dirs: include + ghc-options: -Wall + +executable mock-app + main-is: main.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: + aeson, + base, + servant-mock, + servant-server >= 0.10, + QuickCheck, + warp + if flag(example) + buildable: True + else + buildable: False + ghc-options: -Wall + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Servant.MockSpec + build-depends: + bytestring-conversion, + base, + hspec, + hspec-wai >=0.8 && <0.9, + QuickCheck, + servant, + servant-server, + servant-mock, + aeson, + wai

1 0

commit ghc-servant-foreign for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-foreign for openSUSE:Factory checked in at 2017-08-31 20:59:18 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-foreign (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-foreign.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-foreign" Thu Aug 31 20:59:18 2017 rev:2 rq:513487 version:0.10.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-foreign/ghc-servant-foreign.changes 2017-05-09 18:08:58.151553090 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-foreign.new/ghc-servant-foreign.changes 2017-08-31 20:59:20.879099766 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons(a)suse.com + +- Update to version 0.10.1. + +------------------------------------------------------------------- Old: ---- servant-foreign-0.9.1.1.tar.gz New: ---- servant-foreign-0.10.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-foreign.spec ++++++ --- /var/tmp/diff_new_pack.FocNTO/_old 2017-08-31 20:59:22.022939054 +0200 +++ /var/tmp/diff_new_pack.FocNTO/_new 2017-08-31 20:59:22.046935682 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-foreign %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.1.1 +Version: 0.10.1 Release: 0 Summary: Helpers for generating clients for servant APIs in any programming language License: BSD-3-Clause ++++++ servant-foreign-0.9.1.1.tar.gz -> servant-foreign-0.10.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-foreign-0.9.1.1/CHANGELOG.md new/servant-foreign-0.10.1/CHANGELOG.md --- old/servant-foreign-0.9.1.1/CHANGELOG.md 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-foreign-0.10.1/CHANGELOG.md 2017-05-24 09:22:43.000000000 +0200 @@ -1,3 +1,20 @@ +0.10.1 +------ + +### Changes + +* Don't drop samples in `HasDocs ReqBody` instance + ([#755](https://github.com/haskell-servant/servant/pull/755/files)). + *Breaking change in an `Internal` module*. + +0.10 +---- + +### Breaking changes + +* Do not apply JavaScript specific mangling to the names. + ([#191](https://github.com/haskell-servant/servant/issues/191)) + 0.7.1 ----- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-foreign-0.9.1.1/servant-foreign.cabal new/servant-foreign-0.10.1/servant-foreign.cabal --- old/servant-foreign-0.9.1.1/servant-foreign.cabal 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-foreign-0.10.1/servant-foreign.cabal 2017-05-24 09:22:43.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-foreign -version: 0.9.1.1 +version: 0.10.1 synopsis: Helpers for generating clients for servant APIs in any programming language description: Helper types and functions for generating client functions for servant APIs in any programming language @@ -14,7 +14,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2015-2016 Servant Contributors -category: Web +category: Servant Web build-type: Simple cabal-version: >=1.10 extra-source-files: @@ -32,7 +32,7 @@ , Servant.Foreign.Inflections build-depends: base == 4.* , lens == 4.* - , servant == 0.9.* + , servant == 0.11.* , text >= 1.2 && < 1.3 , http-types hs-source-dirs: src @@ -67,6 +67,7 @@ other-modules: Servant.ForeignSpec build-depends: base , hspec >= 2.1.8 + , servant , servant-foreign default-language: Haskell2010 default-extensions: ConstraintKinds diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-foreign-0.9.1.1/src/Servant/Foreign/Inflections.hs new/servant-foreign-0.10.1/src/Servant/Foreign/Inflections.hs --- old/servant-foreign-0.9.1.1/src/Servant/Foreign/Inflections.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-foreign-0.10.1/src/Servant/Foreign/Inflections.hs 2017-05-24 09:22:43.000000000 +0200 @@ -32,7 +32,7 @@ snakeCase = view snakeCaseL camelCaseL :: Getter FunctionName Text -camelCaseL = _FunctionName . to (convert . map (replace "-" "")) +camelCaseL = _FunctionName . to convert where convert [] = "" convert (p:ps) = mconcat $ p : map capitalize ps diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-foreign-0.9.1.1/src/Servant/Foreign/Internal.hs new/servant-foreign-0.10.1/src/Servant/Foreign/Internal.hs --- old/servant-foreign-0.9.1.1/src/Servant/Foreign/Internal.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-foreign-0.10.1/src/Servant/Foreign/Internal.hs 2017-05-24 09:22:43.000000000 +0200 @@ -16,11 +16,11 @@ import Data.String import Data.Text import Data.Text.Encoding (decodeUtf8) -import GHC.Exts (Constraint) import GHC.TypeLits import qualified Network.HTTP.Types as HTTP import Prelude hiding (concat) import Servant.API +import Servant.API.TypeLevel newtype FunctionName = FunctionName { unFunctionName :: [Text] } @@ -135,15 +135,6 @@ defReq :: Req ftype defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) --- | To be used exclusively as a "negative" return type/constraint --- by @'Elem`@ type family. -class NotFound - -type family Elem (a :: *) (ls::[*]) :: Constraint where - Elem a '[] = NotFound - Elem a (a ': list) = () - Elem a (b ': list) = Elem a list - -- | 'HasForeignType' maps Haskell types with types in the target -- language of your backend. For example, let's say you're -- implementing a backend to some language __X__, and you want @@ -196,9 +187,16 @@ foreignFor lang ftype (Proxy :: Proxy a) req :<|> foreignFor lang ftype (Proxy :: Proxy b) req +data EmptyForeignAPI = EmptyForeignAPI + +instance HasForeign lang ftype EmptyAPI where + type Foreign ftype EmptyAPI = EmptyForeignAPI + + foreignFor Proxy Proxy Proxy _ = EmptyForeignAPI + instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api) => HasForeign lang ftype (Capture sym t :> api) where - type Foreign ftype (Capture sym a :> api) = Foreign ftype api + type Foreign ftype (Capture sym t :> api) = Foreign ftype api foreignFor lang Proxy Proxy req = foreignFor lang Proxy (Proxy :: Proxy api) $ @@ -316,9 +314,7 @@ req & reqUrl . path <>~ [Segment (Static (PathSegment str))] & reqFuncName . _FunctionName %~ (++ [str]) where - str = - Data.Text.map (\c -> if c == '.' then '_' else c) - . pack . symbolVal $ (Proxy :: Proxy path) + str = pack . symbolVal $ (Proxy :: Proxy path) instance HasForeign lang ftype api => HasForeign lang ftype (RemoteHost :> api) where @@ -360,6 +356,9 @@ class GenerateList ftype reqs where generateList :: reqs -> [Req ftype] +instance GenerateList ftype EmptyForeignAPI where + generateList _ = [] + instance GenerateList ftype (Req ftype) where generateList r = [r] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-foreign-0.9.1.1/test/Servant/ForeignSpec.hs new/servant-foreign-0.10.1/test/Servant/ForeignSpec.hs --- old/servant-foreign-0.9.1.1/test/Servant/ForeignSpec.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-foreign-0.10.1/test/Servant/ForeignSpec.hs 2017-05-24 09:22:43.000000000 +0200 @@ -6,9 +6,11 @@ import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign +import Servant.API.Internal.Test.ComprehensiveAPI import Test.Hspec + spec :: Spec spec = describe "Servant.Foreign" $ do camelCaseSpec @@ -20,7 +22,12 @@ camelCase (FunctionName ["post", "counter", "inc"]) `shouldBe` "postCounterInc" camelCase (FunctionName ["get", "hyphen-ated", "counter"]) - `shouldBe` "getHyphenatedCounter" + `shouldBe` "getHyphen-atedCounter" + +---------------------------------------------------------------------- + +-- This declaration simply checks that all instances are in place. +_ = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) comprehensiveAPIWithoutRaw ---------------------------------------------------------------------- @@ -29,6 +36,9 @@ instance HasForeignType LangX String NoContent where typeFor _ _ _ = "voidX" +instance HasForeignType LangX String (Headers ctyps NoContent) where + typeFor _ _ _ = "voidX" + instance HasForeignType LangX String Int where typeFor _ _ _ = "intX" @@ -47,13 +57,14 @@ :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int] + :<|> "test" :> EmptyAPI testApi :: [Req String] testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do - it "generates 4 endpoints for TestApi" $ do + it "generates 5 endpoints for TestApi" $ do length testApi `shouldBe` 5 let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi

1 0

commit ghc-servant-docs for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-docs for openSUSE:Factory checked in at 2017-08-31 20:59:16 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-docs (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-docs.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-docs" Thu Aug 31 20:59:16 2017 rev:2 rq:513486 version:0.10.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-docs/ghc-servant-docs.changes 2017-05-10 20:51:43.656602084 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-docs.new/ghc-servant-docs.changes 2017-08-31 20:59:19.287323415 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:41 UTC 2017 - psimons(a)suse.com + +- Update to version 0.10.0.1. + +------------------------------------------------------------------- Old: ---- servant-docs-0.9.1.1.tar.gz New: ---- servant-docs-0.10.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-docs.spec ++++++ --- /var/tmp/diff_new_pack.kvv5fn/_old 2017-08-31 20:59:20.363172255 +0200 +++ /var/tmp/diff_new_pack.kvv5fn/_new 2017-08-31 20:59:20.363172255 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-docs %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.1.1 +Version: 0.10.0.1 Release: 0 Summary: Generate API docs for your servant webservice License: BSD-3-Clause @@ -30,6 +30,7 @@ BuildRequires: ghc-Cabal-devel BuildRequires: ghc-aeson-devel BuildRequires: ghc-aeson-pretty-devel +BuildRequires: ghc-base-compat-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-case-insensitive-devel BuildRequires: ghc-control-monad-omega-devel ++++++ servant-docs-0.9.1.1.tar.gz -> servant-docs-0.10.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-docs-0.9.1.1/CHANGELOG.md new/servant-docs-0.10.0.1/CHANGELOG.md --- old/servant-docs-0.9.1.1/CHANGELOG.md 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-docs-0.10.0.1/CHANGELOG.md 2017-05-24 09:22:49.000000000 +0200 @@ -1,3 +1,8 @@ +0.10 +---- + +There are no changes. Released as a part of `servant` suite. + 0.7.1 ----- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-docs-0.9.1.1/README.md new/servant-docs-0.10.0.1/README.md --- old/servant-docs-0.9.1.1/README.md 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-docs-0.10.0.1/README.md 2017-05-24 09:22:49.000000000 +0200 @@ -19,7 +19,7 @@ import Data.Proxy import Data.Text -import Servant +import Servant.Docs -- our type for a Greeting message data Greet = Greet { _msg :: Text } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-docs-0.9.1.1/servant-docs.cabal new/servant-docs-0.10.0.1/servant-docs.cabal --- old/servant-docs-0.9.1.1/servant-docs.cabal 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-docs-0.10.0.1/servant-docs.cabal 2017-05-24 09:22:49.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-docs -version: 0.9.1.1 +version: 0.10.0.1 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. @@ -12,7 +12,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web +category: Servant Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 @@ -33,6 +33,7 @@ , Servant.Docs.Internal.Pretty build-depends: base >=4.7 && <5 + , base-compat >= 0.9.1 && <0.10 , aeson , aeson-pretty , bytestring @@ -41,11 +42,14 @@ , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.9.* + , servant == 0.11.* , string-conversions , text , unordered-containers , control-monad-omega == 0.3.* + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-docs-0.9.1.1/src/Servant/Docs/Internal.hs new/servant-docs-0.10.0.1/src/Servant/Docs/Internal.hs --- old/servant-docs-0.9.1.1/src/Servant/Docs/Internal.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-docs-0.10.0.1/src/Servant/Docs/Internal.hs 2017-05-24 09:22:49.000000000 +0200 @@ -20,6 +20,8 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where +import Prelude () +import Prelude.Compat import Control.Applicative import Control.Arrow (second) import Control.Lens (makeLenses, mapped, over, traversed, view, (%~), @@ -30,19 +32,19 @@ import qualified Data.CaseInsensitive as CI import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) -import Data.List +import Data.List.Compat (intercalate, intersperse, sort) import Data.Maybe -import Data.Monoid +import Data.Monoid (All (..), Any (..), Sum (..), Product (..), First (..), Last (..), Dual (..)) +import Data.Semigroup (Semigroup (..)) import Data.Ord (comparing) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions (cs) import Data.Text (Text, unpack) -import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits import Servant.API import Servant.API.ContentTypes -import Servant.Utils.Links +import Servant.API.TypeLevel import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -103,8 +105,11 @@ , _apiEndpoints :: HashMap Endpoint Action } deriving (Eq, Show) +instance Semigroup API where + (<>) = mappend + instance Monoid API where - API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2) + API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2) mempty = API mempty mempty -- | An empty 'API' @@ -163,6 +168,8 @@ -- These are intended to be built using extraInfo. -- Multiple ExtraInfo may be combined with the monoid instance. newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action) +instance Semigroup (ExtraInfo a) where + (<>) = mappend instance Monoid (ExtraInfo a) where mempty = ExtraInfo mempty ExtraInfo a `mappend` ExtraInfo b = @@ -242,7 +249,7 @@ , _notes :: [DocNote] -- user supplied , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info , _rqtypes :: [M.MediaType] -- type collected - , _rqbody :: [(M.MediaType, ByteString)] -- user supplied + , _rqbody :: [(Text, M.MediaType, ByteString)] -- user supplied , _response :: Response -- user supplied } deriving (Eq, Ord, Show) @@ -306,15 +313,6 @@ docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API docsWithOptions p = docsFor p (defEndpoint, defAction) --- | Closed type family, check if endpoint is exactly within API. - --- We aren't sure what affects how an Endpoint is built up, so we require an --- exact match. -type family IsIn (endpoint :: *) (api :: *) :: Constraint where - IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb) - IsIn (e :> sa) (e :> sb) = IsIn sa sb - IsIn e e = () - -- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout. -- -- The safety here is to ensure that you only add custom documentation to an @@ -620,7 +618,7 @@ where values = param ^. paramValues - rqbodyStr :: [M.MediaType] -> [(M.MediaType, ByteString)]-> [String] + rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String] rqbodyStr [] [] = [] rqbodyStr types s = ["#### Request:", ""] @@ -632,8 +630,8 @@ <> map (\t -> " - `" <> show t <> "`") ts <> [""] - formatBody (m, b) = - "- Example: `" <> cs (show m) <> "`" : + formatBody (t, m, b) = + "- Example (" <> cs t <> "): `" <> cs (show m) <> "`" : contentStr m b markdownForType mime_type = @@ -685,6 +683,10 @@ p2 :: Proxy b p2 = Proxy +-- | The generated docs for @'EmptyAPI'@ are empty. +instance HasDocs EmptyAPI where + docsFor Proxy _ _ = emptyAPI + -- | @"books" :> 'Capture' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs. instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) @@ -803,11 +805,12 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) => HasDocs (ReqBody (ct ': cts) a :> api) where - docsFor Proxy (endpoint, action) = - docsFor subApiP (endpoint, action') + docsFor Proxy (endpoint, action) opts@DocOptions{..} = + docsFor subApiP (endpoint, action') opts where subApiP = Proxy :: Proxy api - action' = action & rqbody .~ sampleByteString t p + action' :: Action + action' = action & rqbody .~ take _maxSamples (sampleByteStrings t p) & rqtypes .~ allMime t t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-docs-0.9.1.1/test/Servant/DocsSpec.hs new/servant-docs-0.10.0.1/test/Servant/DocsSpec.hs --- old/servant-docs-0.9.1.1/test/Servant/DocsSpec.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-docs-0.10.0.1/test/Servant/DocsSpec.hs 2017-05-24 09:22:49.000000000 +0200 @@ -104,6 +104,9 @@ it "contains request body samples" $ md `shouldContain` "17" + it "does not generate any docs mentioning the 'empty-api' path" $ + md `shouldNotContain` "empty-api" + -- * APIs @@ -128,6 +131,7 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 :<|> Header "X-Test" Int :> Put '[JSON] Int + :<|> "empty-api" :> EmptyAPI data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq)

1 0

commit ghc-servant-client for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-client for openSUSE:Factory checked in at 2017-08-31 20:59:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-client (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-client.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-client" Thu Aug 31 20:59:13 2017 rev:2 rq:513485 version:0.11 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-client/ghc-servant-client.changes 2017-05-10 20:51:09.541416086 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-client.new/ghc-servant-client.changes 2017-08-31 20:59:15.803812858 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:06 UTC 2017 - psimons(a)suse.com + +- Update to version 0.11 revision 1. + +------------------------------------------------------------------- Old: ---- servant-client-0.9.1.1.tar.gz New: ---- servant-client-0.11.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-client.spec ++++++ --- /var/tmp/diff_new_pack.ZDkX7K/_old 2017-08-31 20:59:17.203616182 +0200 +++ /var/tmp/diff_new_pack.ZDkX7K/_new 2017-08-31 20:59:17.231612248 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-client %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.1.1 +Version: 0.11 Release: 0 Summary: Automatical derivation of querying functions for servant webservices License: BSD-3-Clause @@ -34,18 +34,22 @@ BuildRequires: ghc-base64-bytestring-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-exceptions-devel +BuildRequires: ghc-generics-sop-devel BuildRequires: ghc-http-api-data-devel BuildRequires: ghc-http-client-devel BuildRequires: ghc-http-client-tls-devel BuildRequires: ghc-http-media-devel BuildRequires: ghc-http-types-devel +BuildRequires: ghc-monad-control-devel BuildRequires: ghc-mtl-devel BuildRequires: ghc-network-uri-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-safe-devel +BuildRequires: ghc-semigroupoids-devel BuildRequires: ghc-servant-devel BuildRequires: ghc-string-conversions-devel BuildRequires: ghc-text-devel +BuildRequires: ghc-transformers-base-devel BuildRequires: ghc-transformers-compat-devel BuildRequires: ghc-transformers-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ servant-client-0.9.1.1.tar.gz -> servant-client-0.11.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/CHANGELOG.md new/servant-client-0.11/CHANGELOG.md --- old/servant-client-0.9.1.1/CHANGELOG.md 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-client-0.11/CHANGELOG.md 2017-05-24 09:22:37.000000000 +0200 @@ -1,3 +1,37 @@ +0.11 +---- + +### Other changes + +- Path components are escaped + ([#696](https://github.com/haskell-servant/servant/pull/696)) +- `Req` `reqPath` field changed from `String` to `BS.Builder` + ([#696](https://github.com/haskell-servant/servant/pull/696)) +- Include `Req` in failure errors + ([#740](https://github.com/haskell-servant/servant/pull/740)) + +0.10 +----- + +### Breaking changes + +There shouldn't be breaking changes. Released as a part of `servant` suite. + +### Other changes + +* Add MonadBase and MonadBaseControl instances for ClientM + ([#663](https://github.com/haskell-servant/servant/issues/663)) + +* client asks for any content-type in Accept contentTypes non-empty list + ([#615](https://github.com/haskell-servant/servant/pull/615)) + +* Add `ClientLike` class that matches client functions generated using `client` + with client data structure. + ([#640](https://github.com/haskell-servant/servant/pull/640)) + +* Allow direct use of 'RequestBody' + ([#661](https://github.com/haskell-servant/servant/pull/661)) + 0.9.1.1 ------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/servant-client.cabal new/servant-client-0.11/servant-client.cabal --- old/servant-client-0.9.1.1/servant-client.cabal 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-client-0.11/servant-client.cabal 2017-05-24 09:22:37.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-client -version: 0.9.1.1 +version: 0.11 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -13,7 +13,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web +category: Servant Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 @@ -30,6 +30,7 @@ library exposed-modules: Servant.Client + Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth @@ -37,24 +38,31 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9.1 && < 0.10 - , aeson >= 0.7 && < 1.1 + , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.1 , bytestring >= 0.10 && < 0.11 , exceptions >= 0.8 && < 0.9 - , http-api-data >= 0.3 && < 0.4 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 , http-media >= 0.6.2 && < 0.7 , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 - , servant == 0.9.* + , semigroupoids >= 4.3 && < 5.3 + , servant == 0.11.* , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 , mtl + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -73,10 +81,8 @@ , Servant.Common.BaseUrlSpec build-depends: base == 4.* - , base-compat - , transformers - , transformers-compat , aeson + , base-compat , bytestring , deepseq , hspec == 2.* @@ -85,11 +91,15 @@ , http-media , http-types , HUnit + , mtl , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.9.* + , servant , servant-client - , servant-server == 0.9.* + , servant-server == 0.11.* , text + , transformers + , transformers-compat , wai , warp + , generics-sop diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/src/Servant/Client/Generic.hs new/servant-client-0.11/src/Servant/Client/Generic.hs --- old/servant-client-0.9.1.1/src/Servant/Client/Generic.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-client-0.11/src/Servant/Client/Generic.hs 2017-05-24 09:22:37.000000000 +0200 @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#include "overlapping-compat.h" + +module Servant.Client.Generic + ( ClientLike(..) + , genericMkClientL + , genericMkClientP + ) where + +import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) +import Servant.API ((:<|>)(..)) +import Servant.Client (ClientM) + +-- | This class allows us to match client structure with client functions +-- produced with 'client' without explicit pattern-matching. +-- +-- The client structure needs a 'Generics.SOP.Generic' instance. +-- +-- Example: +-- +-- > type API +-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int +-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int] +-- > :<|> Capture "nested" Int :> NestedAPI +-- > +-- > type NestedAPI +-- > = Get '[JSON] String +-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] () +-- > +-- > data APIClient = APIClient +-- > { getFoo :: Int -> ClientM Int +-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int] +-- > , mkNestedClient :: Int -> NestedClient +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient +-- > instance (Client API ~ client) => ClientLike client APIClient +-- > +-- > data NestedClient = NestedClient +-- > { getString :: ClientM String +-- > , postBaz :: Maybe Char -> ClientM () +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic NestedClient +-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient +-- > +-- > mkAPIClient :: APIClient +-- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) +-- +-- By default, left-nested alternatives are expanded: +-- +-- > type API1 +-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int +-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String +-- > +-- > type API2 +-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] () +-- > +-- > type API = API1 :<|> API2 +-- > +-- > data APIClient = APIClient +-- > { getFoo :: Int -> ClientM Int +-- > , postBar :: Maybe Char -> ClientM String +-- > , postBaz :: Maybe Char -> ClientM () +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient +-- > instance (Client API ~ client) => ClientLike client APIClient +-- > +-- > mkAPIClient :: APIClient +-- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) +-- +-- If you want to define client for @API1@ as a separate data structure, +-- you can use 'genericMkClientP': +-- +-- > data APIClient1 = APIClient1 +-- > { getFoo :: Int -> ClientM Int +-- > , postBar :: Maybe Char -> ClientM String +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient1 +-- > instance (Client API1 ~ client) => ClientLike client APIClient1 +-- > +-- > data APIClient = APIClient +-- > { mkAPIClient1 :: APIClient1 +-- > , postBaz :: Maybe Char -> ClientM () +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient +-- > instance (Client API ~ client) => ClientLike client APIClient where +-- > mkClient = genericMkClientP +-- > +-- > mkAPIClient :: APIClient +-- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) +class ClientLike client custom where + mkClient :: client -> custom + default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) + => client -> custom + mkClient = genericMkClientL + +instance ClientLike client custom + => ClientLike (a -> client) (a -> custom) where + mkClient c = mkClient . c + +instance ClientLike (ClientM a) (ClientM a) where + mkClient = id + +-- | Match client structure with client functions, regarding left-nested API clients +-- as separate data structures. +class GClientLikeP client xs where + gMkClientP :: client -> NP I xs + +instance (GClientLikeP b (y ': xs), ClientLike a x) + => GClientLikeP (a :<|> b) (x ': y ': xs) where + gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b + +instance ClientLike a x => GClientLikeP a '[x] where + gMkClientP a = I (mkClient a) :* Nil + +-- | Match client structure with client functions, expanding left-nested API clients +-- in the same structure. +class GClientLikeL (xs :: [*]) (ys :: [*]) where + gMkClientL :: NP I xs -> NP I ys + +instance GClientLikeL '[] '[] where + gMkClientL Nil = Nil + +instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where + gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs + +type family ClientList (client :: *) (acc :: [*]) :: [*] where + ClientList (a :<|> b) acc = ClientList a (ClientList b acc) + ClientList a acc = a ': acc + +class GClientList client (acc :: [*]) where + gClientList :: client -> NP I acc -> NP I (ClientList client acc) + +instance (GClientList b acc, GClientList a (ClientList b acc)) + => GClientList (a :<|> b) acc where + gClientList (a :<|> b) acc = gClientList a (gClientList b acc) + +instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc)) + => GClientList client acc where + gClientList c acc = I c :* acc + +-- | Generate client structure from client type, expanding left-nested API (done by default). +genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) + => client -> custom +genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil + +-- | Generate client structure from client type, regarding left-nested API clients as separate data structures. +genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs) + => client -> custom +genericMkClientP = to . SOP . Z . gMkClientP + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/src/Servant/Client.hs new/servant-client-0.11/src/Servant/Client.hs --- old/servant-client-0.9.1.1/src/Servant/Client.hs 2016-10-24 18:27:44.000000000 +0200 +++ new/servant-client-0.11/src/Servant/Client.hs 2017-05-24 09:22:37.000000000 +0200 @@ -24,6 +24,7 @@ , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) + , EmptyClient(..) , module Servant.Common.BaseUrl ) where @@ -88,6 +89,23 @@ clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy b) req +-- | Singleton type representing a client for an empty API. +data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) + +-- | The client for 'EmptyAPI' is simply 'EmptyClient'. +-- +-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "nothing" :> EmptyAPI +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > (getAllBooks :<|> EmptyClient) = client myApi +instance HasClient EmptyAPI where + type Client EmptyAPI = EmptyClient + clientWithRoute Proxy _ = EmptyClient + -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Capture'. @@ -406,7 +424,8 @@ clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy api) (let ctProxy = Proxy :: Proxy ct - in setRQBody (mimeRender ctProxy body) + in setReqBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list (contentType ctProxy) req ) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/src/Servant/Common/Req.hs new/servant-client-0.11/src/Servant/Common/Req.hs --- old/servant-client-0.9.1.1/src/Servant/Common/Req.hs 2016-10-27 13:25:54.000000000 +0200 +++ new/servant-client-0.11/src/Servant/Common/Req.hs 2017-05-24 09:22:37.000000000 +0200 @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.Common.Req where @@ -13,21 +15,22 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch) +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) +import Data.Semigroup ((<>)) -#if MIN_VERSION_mtl(2,2,0) -import Control.Monad.Except (MonadError(..)) -#else import Control.Monad.Error.Class (MonadError(..)) -#endif import Control.Monad.Trans.Except - import GHC.Generics +import Control.Monad.Base (MonadBase (..)) import Control.Monad.IO.Class () import Control.Monad.Reader -import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import qualified Data.ByteString.Builder as BS +import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) import Data.String -import Data.String.Conversions +import Data.String.Conversions (cs) import Data.Proxy import Data.Text (Text) import Data.Text.Encoding @@ -46,7 +49,8 @@ data ServantError = FailureResponse - { responseStatus :: Status + { failingRequest :: UrlReq + , responseStatus :: Status , responseContentType :: MediaType , responseBody :: ByteString } @@ -69,7 +73,7 @@ deriving (Show, Typeable) instance Eq ServantError where - FailureResponse a b c == FailureResponse x y z = + FailureResponse _ a b c == FailureResponse _ x y z = (a, b, c) == (x, y, z) DecodeFailure a b c == DecodeFailure x y z = (a, b, c) == (x, y, z) @@ -83,10 +87,17 @@ instance Exception ServantError +data UrlReq = UrlReq BaseUrl Req + +instance Show UrlReq where + show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req) + where + path = cs (BS.toLazyByteString (reqPath req)) + data Req = Req - { reqPath :: String + { reqPath :: BS.Builder , qs :: QueryText - , reqBody :: Maybe (ByteString, MediaType) + , reqBody :: Maybe (RequestBody, MediaType) , reqAccept :: [MediaType] , headers :: [(String, Text)] } @@ -96,7 +107,7 @@ appendToPath :: String -> Req -> Req appendToPath p req = - req { reqPath = reqPath req ++ "/" ++ p } + req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p } appendToQueryString :: Text -- ^ param name -> Maybe Text -- ^ param value @@ -111,8 +122,31 @@ ++ [(name, decodeUtf8 (toHeader val))] } +-- | Set body and media type of the request being constructed. +-- +-- The body is set to the given bytestring using the 'RequestBodyLBS' +-- constructor. +-- +{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-} setRQBody :: ByteString -> MediaType -> Req -> Req -setRQBody b t req = req { reqBody = Just (b, t) } +setRQBody = setReqBodyLBS + +-- | Set body and media type of the request being constructed. +-- +-- The body is set to the given bytestring using the 'RequestBodyLBS' +-- constructor. +-- +-- @since 0.9.2.0 +-- +setReqBodyLBS :: ByteString -> MediaType -> Req -> Req +setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) } + +-- | Set body and media type of the request being constructed. +-- +-- @since 0.9.2.0 +-- +setReqBody :: RequestBody -> MediaType -> Req -> Req +setReqBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = @@ -126,12 +160,13 @@ , uriRegName = reqHost , uriPort = ":" ++ show reqPort } - , uriPath = path ++ reqPath req + , uriPath = fullPath } + fullPath = path ++ cs (BS.toLazyByteString (reqPath req)) setrqb r = case reqBody req of Nothing -> r - Just (b,t) -> r { requestBody = RequestBodyLBS b + Just (b,t) -> r { requestBody = b , requestHeaders = requestHeaders r ++ [(hContentType, cs . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req) @@ -179,11 +214,27 @@ , MonadThrow, MonadCatch ) +instance MonadBase IO ClientM where + liftBase = ClientM . liftBase + +instance MonadBaseControl IO ClientM where + type StM ClientM a = Either ServantError a + + -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a + liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM'))) + + -- restoreM :: StM ClientM a -> ClientM a + restoreM st = ClientM (restoreM st) + +-- | Try clients in order, last error is preserved. +instance Alt ClientM where + a <!> b = a `catchError` \_ -> b + runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm -performRequest :: Method -> Req +performRequest :: Method -> Req -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) performRequest reqMethod req = do @@ -209,16 +260,16 @@ Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse status ct body + throwError $ FailureResponse (UrlReq reqHost req) status ct body return (status_code, body, ct, hdrs, response) -performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req +performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req -> ClientM ([HTTP.Header], result) performRequestCT ct reqMethod req = do - let acceptCT = contentType ct + let acceptCTS = contentTypes ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) - unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody + performRequest reqMethod (req { reqAccept = toList acceptCTS }) + unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwError $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/test/Servant/ClientSpec.hs new/servant-client-0.11/test/Servant/ClientSpec.hs --- old/servant-client-0.9.1.1/test/Servant/ClientSpec.hs 2016-10-24 18:27:44.000000000 +0200 +++ new/servant-client-0.11/test/Servant/ClientSpec.hs 2017-05-24 09:22:37.000000000 +0200 @@ -29,13 +29,14 @@ import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (throwE ) +import Control.Monad.Error.Class (throwError ) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) import Data.Foldable (forM_) import Data.Monoid hiding (getLast) import Data.Proxy +import qualified Generics.SOP as SOP import GHC.Generics (Generic) import qualified Network.HTTP.Client as C import Network.HTTP.Media @@ -55,6 +56,7 @@ import Servant.API import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client +import Servant.Client.Generic import qualified Servant.Common.Req as SCR import Servant.Server import Servant.Server.Experimental.Auth @@ -69,6 +71,7 @@ wrappedApiSpec basicAuthSpec genAuthSpec + genericClientSpec -- * test data types @@ -108,6 +111,8 @@ Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent + :<|> "empty" :> EmptyAPI + api :: Proxy Api api = Proxy @@ -119,14 +124,15 @@ getQueryParam :: Maybe String -> SCR.ClientM Person getQueryParams :: [String] -> SCR.ClientM [Person] getQueryFlag :: Bool -> SCR.ClientM Bool -getRawSuccess :: HTTP.Method +getRawSuccess :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -getRawFailure :: HTTP.Method +getRawFailure :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) getDeleteContentType :: SCR.ClientM NoContent + getGet :<|> getDeleteEmpty :<|> getCapture @@ -139,7 +145,8 @@ :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders - :<|> getDeleteContentType = client api + :<|> getDeleteContentType + :<|> EmptyClient = client api server :: Application server = serve api ( @@ -150,16 +157,16 @@ :<|> return :<|> (\ name -> case name of Just "alice" -> return alice - Just n -> throwE $ ServantErr 400 (n ++ " not found") "" [] - Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) + Just n -> throwError $ ServantErr 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent - ) + :<|> emptyServer) type FailApi = @@ -171,9 +178,9 @@ failServer :: Application failServer = serve failApi ( - (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") + :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff @@ -212,7 +219,7 @@ genAuthHandler :: AuthHandler Request () genAuthHandler = let handler req = case lookup "AuthHeader" (requestHeaders req) of - Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler @@ -222,6 +229,53 @@ genAuthServer :: Application genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) +-- * generic client stuff + +type GenericClientAPI + = QueryParam "sqr" Int :> Get '[JSON] Int + :<|> Capture "foo" String :> NestedAPI1 + +data GenericClient = GenericClient + { getSqr :: Maybe Int -> SCR.ClientM Int + , mkNestedClient1 :: String -> NestedClient1 + } deriving Generic +instance SOP.Generic GenericClient +instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient + +type NestedAPI1 + = QueryParam "int" Int :> NestedAPI2 + :<|> QueryParam "id" Char :> Get '[JSON] Char + +data NestedClient1 = NestedClient1 + { mkNestedClient2 :: Maybe Int -> NestedClient2 + , idChar :: Maybe Char -> SCR.ClientM Char + } deriving Generic +instance SOP.Generic NestedClient1 +instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1 + +type NestedAPI2 + = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int + :<|> "void" :> Post '[JSON] () + +data NestedClient2 = NestedClient2 + { getSum :: Int -> Int -> SCR.ClientM Int + , doNothing :: SCR.ClientM () + } deriving Generic +instance SOP.Generic NestedClient2 +instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2 + +genericClientServer :: Application +genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( + (\ mx -> case mx of + Just x -> return (x*x) + Nothing -> throwError $ ServantErr 400 "missing parameter" "" [] + ) + :<|> nestedServer1 + ) + where + nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) + nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () + {-# NOINLINE manager #-} manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings @@ -298,7 +352,7 @@ wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] + let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = @@ -322,7 +376,7 @@ let (_ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) case res of - FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () + FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do @@ -392,6 +446,22 @@ Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") +genericClientSpec :: Spec +genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do + describe "Servant.Client.Generic" $ do + + let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) + NestedClient1{..} = mkNestedClient1 "example" + NestedClient2{..} = mkNestedClient2 (Just 42) + + it "works for top-level client function" $ \(_, baseUrl) -> do + (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 + + it "works for nested clients" $ \(_, baseUrl) -> do + (left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c' + (left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7 + (left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right () + -- * utils startWaiApp :: Application -> IO (ThreadId, BaseUrl) ++++++ servant-client.cabal ++++++ --- /var/tmp/diff_new_pack.ZDkX7K/_old 2017-08-31 20:59:17.775535825 +0200 +++ /var/tmp/diff_new_pack.ZDkX7K/_new 2017-08-31 20:59:17.779535264 +0200 @@ -1,5 +1,5 @@ name: servant-client -version: 0.9.1.1 +version: 0.11 x-revision: 1 synopsis: automatical derivation of querying functions for servant webservices description: @@ -14,7 +14,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web +category: Servant Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 @@ -31,31 +31,39 @@ library exposed-modules: Servant.Client + Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth Servant.Common.Req build-depends: - base >= 4.7 && < 4.10 + base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 - , aeson >= 0.7 && < 1.2 + , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.1 , bytestring >= 0.10 && < 0.11 , exceptions >= 0.8 && < 0.9 - , http-api-data >= 0.3 && < 0.4 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 - , http-media >= 0.6.2 && < 0.7 + , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 - , servant == 0.9.* + , semigroupoids >= 4.3 && < 5.3 + , servant == 0.11.* , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 , mtl + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -74,10 +82,8 @@ , Servant.Common.BaseUrlSpec build-depends: base == 4.* - , base-compat - , transformers - , transformers-compat , aeson + , base-compat , bytestring , deepseq , hspec == 2.* @@ -86,11 +92,15 @@ , http-media , http-types , HUnit + , mtl , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.9.* + , servant , servant-client - , servant-server == 0.9.* + , servant-server == 0.11.* , text + , transformers + , transformers-compat , wai , warp + , generics-sop

1 0

commit ghc-servant-cassava for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-cassava for openSUSE:Factory checked in at 2017-08-31 20:59:11 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-cassava (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-cassava.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-cassava" Thu Aug 31 20:59:11 2017 rev:2 rq:513484 version:0.9 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-cassava/ghc-servant-cassava.changes 2017-05-16 14:41:23.306884692 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-cassava.new/ghc-servant-cassava.changes 2017-08-31 20:59:12.960212391 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:36 UTC 2017 - psimons(a)suse.com + +- Update to version 0.9 revision 1. + +------------------------------------------------------------------- Old: ---- servant-cassava-0.8.tar.gz New: ---- servant-cassava-0.9.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-cassava.spec ++++++ --- /var/tmp/diff_new_pack.50XUrI/_old 2017-08-31 20:59:14.328020211 +0200 +++ /var/tmp/diff_new_pack.50XUrI/_new 2017-08-31 20:59:14.332019649 +0200 @@ -18,15 +18,17 @@ %global pkg_name servant-cassava Name: ghc-%{pkg_name} -Version: 0.8 +Version: 0.9 Release: 0 Summary: Servant CSV content-type for cassava License: BSD-3-Clause Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… -Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/2.cabal… +Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal… BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-base-compat-devel +BuildRequires: ghc-bytestring-devel BuildRequires: ghc-cassava-devel BuildRequires: ghc-http-media-devel BuildRequires: ghc-rpm-macros ++++++ servant-cassava-0.8.tar.gz -> servant-cassava-0.9.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-cassava-0.8/include/overlapping-compat.h new/servant-cassava-0.9/include/overlapping-compat.h --- old/servant-cassava-0.8/include/overlapping-compat.h 2016-09-07 23:45:10.000000000 +0200 +++ new/servant-cassava-0.9/include/overlapping-compat.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-cassava-0.8/servant-cassava.cabal new/servant-cassava-0.9/servant-cassava.cabal --- old/servant-cassava-0.8/servant-cassava.cabal 2016-09-08 00:29:32.000000000 +0200 +++ new/servant-cassava-0.9/servant-cassava.cabal 2017-05-24 10:32:07.000000000 +0200 @@ -1,10 +1,7 @@ --- Initial servant-cassava.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: servant-cassava -version: 0.8 +version: 0.9 synopsis: Servant CSV content-type for cassava --- description: +description: Servant CSV content-type for cassava. homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE @@ -13,7 +10,6 @@ copyright: 2015-2016 Servant Contributors category: Web build-type: Simple -extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant-cassava/issues @@ -23,14 +19,13 @@ library exposed-modules: Servant.CSV.Cassava - -- other-modules: - -- other-extensions: build-depends: base >=4.6 && <5 + , base-compat >=0.9.1 && <0.10 + , bytestring , cassava >0.4 && <0.5 - , servant >=0.7 && <0.9 + , servant >=0.7 && <0.12 , http-media , vector hs-source-dirs: src default-language: Haskell2010 - include-dirs: include ghc-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-cassava-0.8/src/Servant/CSV/Cassava.hs new/servant-cassava-0.9/src/Servant/CSV/Cassava.hs --- old/servant-cassava-0.8/src/Servant/CSV/Cassava.hs 2016-09-08 00:29:32.000000000 +0200 +++ new/servant-cassava-0.9/src/Servant/CSV/Cassava.hs 2017-05-24 10:32:07.000000000 +0200 @@ -1,7 +1,9 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,34 +11,56 @@ -- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for -- @cassava@'s encoding and decoding classes. -- --- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)] +-- >>> type Eg = Get '[CSV' 'HasHeader MyEncodeOptions] [(Int, String)] -- -- Default encoding and decoding options are also provided, along with the -- @CSV@ type synonym that uses them. -- -- >>> type EgDefault = Get '[CSV] [(Int, String)] -module Servant.CSV.Cassava where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Data.Csv -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) -import Data.Vector (Vector, toList) -import GHC.Generics (Generic) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..), - MimeUnrender (..)) +-- +module Servant.CSV.Cassava ( module Servant.CSV.Cassava + , HasHeader(..) + ) where -data CSV' deriving (Typeable, Generic) +import Prelude () +import Prelude.Compat -type CSV = (CSV', DefaultOpts) +import Data.Csv +import Data.ByteString.Lazy (ByteString) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Data.Vector (Vector, toList) +import GHC.Generics (Generic) +import qualified Network.HTTP.Media as M +import Servant.API (Accept (..), MimeRender (..), + MimeUnrender (..)) + +data CSV' (hasHeader :: HasHeader) opt deriving (Typeable) +type CSV = CSV' 'HasHeader DefaultOpts + +-- | 'HasHeader singleton. +data SHasHeader (hasHeader :: HasHeader) where + SHasHeader :: SHasHeader 'HasHeader + SNoHeader :: SHasHeader 'NoHeader + +-- | Class to provide 'SHasHeader' implicitly. +class SHasHeaderI (hasHeader :: HasHeader) where shasheader :: SHasHeader hasHeader +instance SHasHeaderI 'HasHeader where shasheader = SHasHeader +instance SHasHeaderI 'NoHeader where shasheader = SNoHeader + +shasheaderToBool :: SHasHeader hasHeader -> Bool +shasheaderToBool SHasHeader = True +shasheaderToBool SNoHeader = False + +lowerSHasHeader :: SHasHeader hasHeader -> HasHeader +lowerSHasHeader SHasHeader = HasHeader +lowerSHasHeader SNoHeader = NoHeader +-- | Default options, instances providing 'defaultDecodeOptions' and 'defaultEncodeOptions'. data DefaultOpts deriving (Typeable, Generic) -- | @text/csv;charset=utf-8@ -instance Accept (CSV', a) where +instance Accept (CSV' hasHeader opt) where contentType _ = "text" M.// "csv" M./: ("charset", "utf-8") -- * Encoding @@ -45,35 +69,62 @@ -- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining -- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, [a]) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals - where p = Proxy :: Proxy opt +instance ( ToNamedRecord a, EncodeOpts opt, SHasHeaderI hasHeader + ) => MimeRender (CSV' hasHeader opt) (Header, [a]) where + mimeRender _ (hdr, vals) = encodeByNameWith opts hdr vals + where + opts = encodeOpts' (Proxy :: Proxy opt) (Proxy :: Proxy hasHeader) --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) [a] where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) - where p = Proxy :: Proxy opt +-- | A class to determine how to encode a list of elements +-- +-- * 'HasHeader' encode with 'encodeDefaultOrderedByNameWith' +-- +-- * 'NoHeader' encode with 'encodeWith' +-- +-- Currently, it's not possible to encode without headers using 'encodeDefaultOrderedByNameWith'. +-- +class EncodeList (hasHeader :: HasHeader) a where + encodeList :: Proxy hasHeader -> EncodeOptions -> [a] -> ByteString + +-- | 'encodeDefaultOrderedByNameWith' +instance (DefaultOrdered a, ToNamedRecord a) => EncodeList 'HasHeader a where + encodeList _ opts vals = encodeDefaultOrderedByNameWith opts { encIncludeHeader = True } vals + +-- | 'encodeWith' +instance (ToRecord a) => EncodeList 'NoHeader a where + encodeList _ opts vals = encodeWith opts { encIncludeHeader = False } vals + +instance ( EncodeOpts opt, EncodeList hasHeader a + ) => MimeRender (CSV' hasHeader opt) [a] where + mimeRender _ = encodeList (Proxy :: Proxy hasHeader) opts + where + opts = encodeOpts (Proxy :: Proxy opt) -- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining -- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, Vector a) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals) - where p = Proxy :: Proxy opt - --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Vector a) where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList - where p = Proxy :: Proxy opt +instance ( ToNamedRecord a, EncodeOpts opt, SHasHeaderI hasHeader + ) => MimeRender (CSV' hasHeader opt) (Header, Vector a) where + mimeRender _ (hdr, vals) = encodeByNameWith opts hdr (toList vals) + where + opts = encodeOpts' (Proxy :: Proxy opt) (Proxy :: Proxy hasHeader) + +instance ( EncodeOpts opt, EncodeList hasHeader a + ) => MimeRender (CSV' hasHeader opt) (Vector a) where + mimeRender _ = encodeList (Proxy :: Proxy hasHeader) opts . toList + where + opts = encodeOpts (Proxy :: Proxy opt) -- ** Encode Options -class EncodeOpts a where - encodeOpts :: Proxy a -> EncodeOptions +class EncodeOpts opt where + encodeOpts :: Proxy opt -> EncodeOptions +encodeOpts' + :: forall opt hasHeader. (EncodeOpts opt, SHasHeaderI hasHeader) + => Proxy opt -> Proxy hasHeader -> EncodeOptions +encodeOpts' p _ = (encodeOpts p) + { encIncludeHeader = shasheaderToBool (shasheader :: SHasHeader hasHeader) + } instance EncodeOpts DefaultOpts where encodeOpts _ = defaultEncodeOptions @@ -82,28 +133,33 @@ -- ** Instances --- | Decode with 'decodeByNameWith' +-- | Decode with 'decodeByNameWith'. instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, [a]) where + ) => MimeUnrender (CSV' 'HasHeader opt) (Header, [a]) where mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs where p = Proxy :: Proxy opt --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) [a] where - mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs - where p = Proxy :: Proxy opt +-- | Decode with 'decodeWith'. +instance ( FromRecord a, DecodeOpts opt, SHasHeaderI hasHeader + ) => MimeUnrender (CSV' hasHeader opt) [a] where + mimeUnrender _ = fmap toList . decodeWith (decodeOpts p) (lowerSHasHeader sh) + where + p = Proxy :: Proxy opt + sh = shasheader :: SHasHeader hasHeader instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, Vector a) where + ) => MimeUnrender (CSV' 'HasHeader opt) (Header, Vector a) where mimeUnrender _ = decodeByNameWith (decodeOpts p) where p = Proxy :: Proxy opt --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Vector a) where - mimeUnrender _ = decodeWith (decodeOpts p) HasHeader - where p = Proxy :: Proxy opt +-- | Decode with 'decodeWith'. +instance ( FromRecord a, DecodeOpts opt, SHasHeaderI hasHeader + ) => MimeUnrender (CSV' hasHeader opt) (Vector a) where + mimeUnrender _ = decodeWith (decodeOpts p) (lowerSHasHeader sh) + where + p = Proxy :: Proxy opt + sh = shasheader :: SHasHeader hasHeader + -- ** Decode Options ++++++ servant-cassava.cabal ++++++ --- /var/tmp/diff_new_pack.50XUrI/_old 2017-08-31 20:59:14.775957274 +0200 +++ /var/tmp/diff_new_pack.50XUrI/_new 2017-08-31 20:59:14.775957274 +0200 @@ -1,22 +1,23 @@ --- Initial servant-cassava.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: servant-cassava -version: 0.8 -x-revision: 2 +version: 0.9 +x-revision: 1 synopsis: Servant CSV content-type for cassava --- description: +description: Servant CSV content-type for cassava. homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2015-2016 Servant Contributors -category: Web +category: Web, Servant, CSV build-type: Simple -extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant-cassava/issues +tested-with: + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.1 source-repository head type: git @@ -24,14 +25,13 @@ library exposed-modules: Servant.CSV.Cassava - -- other-modules: - -- other-extensions: build-depends: base >=4.6 && <5 - , cassava >0.4 && <0.5 - , servant >=0.7 && <0.11 + , base-compat >=0.9.1 && <0.10 + , bytestring + , cassava >0.4 && <0.6 + , servant >=0.7 && <0.12 , http-media , vector hs-source-dirs: src default-language: Haskell2010 - include-dirs: include ghc-options: -Wall

1 0

commit ghc-servant-auth-cookie for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant-auth-cookie for openSUSE:Factory checked in at 2017-08-31 20:59:08 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-auth-cookie (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-auth-cookie.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-auth-cookie" Thu Aug 31 20:59:08 2017 rev:3 rq:513483 version:0.5.0.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-auth-cookie/ghc-servant-auth-cookie.changes 2017-05-18 20:51:03.384090972 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-auth-cookie.new/ghc-servant-auth-cookie.changes 2017-08-31 20:59:11.188461327 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.0.5. + +------------------------------------------------------------------- Old: ---- servant-auth-cookie-0.4.4.tar.gz New: ---- servant-auth-cookie-0.5.0.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-auth-cookie.spec ++++++ --- /var/tmp/diff_new_pack.ZmsgKF/_old 2017-08-31 20:59:12.300305110 +0200 +++ /var/tmp/diff_new_pack.ZmsgKF/_new 2017-08-31 20:59:12.316302863 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-auth-cookie %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.4 +Version: 0.5.0.5 Release: 0 Summary: Authentication via encrypted cookies License: BSD-3-Clause ++++++ servant-auth-cookie-0.4.4.tar.gz -> servant-auth-cookie-0.5.0.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/CHANGELOG.md new/servant-auth-cookie-0.5.0.5/CHANGELOG.md --- old/servant-auth-cookie-0.4.4/CHANGELOG.md 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/CHANGELOG.md 2017-07-13 10:40:23.000000000 +0200 @@ -1,6 +1,40 @@ # Change Log -## [0.4.4] +## [HEAD] + +## [0.5.0.5] - 2017-07-13 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.4] - 2017-05-27 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.3] - 2017-05-24 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.2] - 2017-04-26 +### Changed +- Fixed dependencies' bounds. + +## [0.5.0.1] - 2017-04-16 +### Changed +- Fixed incompatibility with older versions of GHC. + +## [0.5.0] - 2017-04-15 +### Changed +- Server keys management: + - `ServerKey` becomes `ServerKeySet`. + - `mkServerKeyFromBytes` becomes `mkPersistentServerKey`. + +### Deleted +- `mkServerKey` (instead use custom instance of `ServerKeySet`. + +### Added +- class `Cookied` and function `cookied` to faciliate usage of mutable server keys. + +## [0.4.4] - 2017-04-15 ### Added - Tests for the example. - `parseSessionRequest` and `parseSessionResponse` functions. @@ -87,7 +121,13 @@ - Initial version of the package. -[HEAD]: ../../compare/v0.4.4...HEAD +[HEAD]: ../../compare/v0.5.0.5...HEAD +[0.5.0.5]: ../../compare/v0.5.0.4...v0.5.0.5 +[0.5.0.4]: ../../compare/v0.5.0.3...v0.5.0.4 +[0.5.0.3]: ../../compare/v0.5.0.2...v0.5.0.3 +[0.5.0.2]: ../../compare/v0.5.0.1...v0.5.0.2 +[0.5.0.1]: ../../compare/v0.5.0...v0.5.0.1 +[0.5.0]: ../../compare/v0.4.4...v0.5.0 [0.4.4]: ../../compare/v0.4.3.3...v0.4.4 [0.4.3.3]: ../../compare/v0.4.3.2...v0.4.3.3 [0.4.3.2]: ../../compare/v0.4.3.1...v0.4.3.2 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/example/Main.hs new/servant-auth-cookie-0.5.0.5/example/Main.hs --- old/servant-auth-cookie-0.4.4/example/Main.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/example/Main.hs 2017-07-13 10:40:23.000000000 +0200 @@ -1,11 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where import AuthAPI (app, authSettings) @@ -15,13 +10,30 @@ import Network.Wai.Handler.Warp (run) import Servant.Server.Experimental.Auth.Cookie +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) +import FileKeySet (mkFileKeySet, FileKSParams(..), mkFileKey) +#endif + +-- To use mutable server keys we need servant-9.1 and +-- directory-1.2.5 (or higher). Otherwise the only (sane) choice is a +-- persistent key. + main :: IO () main = do rs <- mkRandomSource drgNew 1000 - -- NOTE: - -- Every time the application is executed, a new server key is - -- created. This means, once you restart the app, already existing - -- cookies will be invalidated. - sk <- mkServerKey 16 Nothing - run 8080 (app authSettings rs sk) +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) + let fksp = FileKSParams + { fkspKeySize = 16 + , fkspMaxKeys = 3 + , fkspPath = "./test-key-set" + } + + k <- mkFileKeySet fksp + let generateKey = mkFileKey fksp +#else + let k = mkPersistentServerKey "0123456789abcdef" + let generateKey = return () +#endif + + run 8080 (app authSettings generateKey rs k) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/example/Test.hs new/servant-auth-cookie-0.5.0.5/example/Test.hs --- old/servant-auth-cookie-0.4.4/example/Test.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/example/Test.hs 2017-07-13 10:40:23.000000000 +0200 @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} import Prelude () import Prelude.Compat @@ -9,18 +11,20 @@ import Data.Time.Clock (UTCTime(..)) import Control.Monad.IO.Class (liftIO) import AuthAPI (app, authSettings, LoginForm(..), homePage, loginPage, Account(..)) -import Test.Hspec (Spec, hspec, describe, it) +import Test.Hspec (Spec, hspec, describe, context, it) import Test.Hspec.Wai (WaiSession, WaiExpectation, shouldRespondWith, with, request, get) import Text.Blaze.Renderer.Utf8 (renderMarkup) +import Text.Blaze (Markup) import Servant (Proxy(..)) import Crypto.Random (drgNew) import Servant (FormUrlEncoded, contentType) import Servant.Server.Experimental.Auth.Cookie -import Network.HTTP.Types (methodGet, methodPost, hContentType, hCookie) +import Network.HTTP.Types (Header, methodGet, methodPost, hContentType, hCookie) import Network.HTTP.Media.RenderHeader (renderHeader) import Network.Wai.Test (SResponse(..)) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSC8 +import qualified Data.ByteString.Lazy.Char8 as BSLC8 #if MIN_VERSION_hspec_wai (0,7,0) import Test.Hspec.Wai.Matcher (bodyEquals, ResponseMatcher(..), MatchBody(..)) @@ -34,142 +38,173 @@ import Servant (ToFormUrlEncoded, mimeRender) #endif +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) +import FileKeySet (mkFileKeySet, FileKSParams(..), mkFileKey) +import Control.Arrow ((***)) +import Control.Monad (void, when) +import Data.Monoid ((<>)) +import Control.Exception.Base (bracket) +import Network.HTTP.Types (urlEncode) +import Test.Hspec (shouldBe, shouldSatisfy) +import System.Directory (removeDirectoryRecursive, doesDirectoryExist) +import qualified Data.ByteString.Char8 as BSC8 +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +#endif + + +data SpecState where + SpecState :: (ServerKeySet k) => + { ssRandomSource :: RandomSource + , ssAuthSettings :: AuthCookieSettings + , ssServerKeySet :: k + , ssGenerateKey :: IO () + } -> SpecState -data SpecState = SpecState { - ssRandomSource :: RandomSource - , ssServerKey :: ServerKey - , ssAuthSettings :: AuthCookieSettings - } main :: IO () -main = withState (hspec . spec) where - withState f = do - let ssAuthSettings = authSettings - ssRandomSource <- mkRandomSource drgNew 1000 - ssServerKey <- mkServerKey 16 Nothing - f $ SpecState {..} - - -spec :: SpecState -> Spec -spec SpecState {..} = with (return $ app ssAuthSettings ssRandomSource ssServerKey) $ do - - let formContentType = ( - hContentType - , renderHeader $ contentType (Proxy :: Proxy FormUrlEncoded)) +main = do + rs <- mkRandomSource drgNew 1000 + + return SpecState + { ssRandomSource = rs + , ssAuthSettings = authSettings + , ssServerKeySet = mkPersistentServerKey "0123456789abcdef" + , ssGenerateKey = return () + } >>= hspec . basicSpec + +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) + let rmDir name = doesDirectoryExist name + >>= \exists -> when exists $ removeDirectoryRecursive name + + bracket + (do + let keySetDir = "./test-key-set" + rmDir keySetDir + return FileKSParams + { fkspMaxKeys = 3 + , fkspKeySize = 16 + , fkspPath = keySetDir + } >>= \fksp -> (fksp,) <$> mkFileKeySet fksp) + + (rmDir . fkspPath . fst) + + (\(fksp, ks) -> hspec . renewalSpec $ SpecState + { ssRandomSource = rs + , ssAuthSettings = authSettings + , ssServerKeySet = ks + , ssGenerateKey = mkFileKey fksp + }) +#endif - describe "home page" $ do +basicSpec :: SpecState -> Spec +basicSpec ss@(SpecState {..}) = describe "basic functionality" $ with + (return $ app ssAuthSettings ssGenerateKey ssRandomSource ssServerKeySet) $ do + + context "home page" $ do it "responds successfully" $ do - get "/" `shouldRespondWith` 200 { - matchBody = matchBody' $ renderMarkup homePage - } + get "/" `shouldRespondWithMarkup` homePage - describe "login page" $ do + context "login page" $ do it "responds successfully" $ do - get "/login" `shouldRespondWith` 200 { - matchBody = matchBody' $ renderMarkup (loginPage True) - } + get "/login" `shouldRespondWithMarkup` (loginPage True) it "shows message on incorrect login" $ do - let loginForm = encode $ LoginForm { - lfUsername = "noname" - , lfPassword = "noname" - } - let r = request methodPost "/login" [formContentType] loginForm - r `shouldRespondWith` 200 { - matchBody = matchBody' $ renderMarkup (loginPage False) - } - - describe "private page" $ do - let loginForm = encode $ LoginForm { - lfUsername = "mr_foo" - , lfPassword = "password1" - } - let loginRequest = request methodPost "/login" [formContentType] loginForm + login "noname" "noname" `shouldRespondWithMarkup` (loginPage False) + + context "private page" $ do + let loginRequest = login "mr_foo" "password1" it "rejects requests without cookies" $ do - let r = get "/private" - r `shouldRespondWith` 403 { matchBody = matchBody' "No cookies" } + get "/private" `shouldRespondWith` 403 { matchBody = matchBody' "No cookies" } it "accepts requests with proper cookies" $ do (SResponse {..}) <- loginRequest let cookieValue = fromMaybe (error "cookies aren't available") (lookup "set-cookie" simpleHeaders) - - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - r `shouldRespondWith` 200 + getPrivate cookieValue `shouldRespondWith` 200 it "accepts requests with proper cookies (sanity check)" $ do - (SResponse {..}) <- loginRequest - - cookieValue <- liftIO $ do - session <- maybe - (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account - - renderSession ssAuthSettings ssRandomSource ssServerKey session - - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - r `shouldRespondWith` 200 - + cookieValue <- loginRequest + >>= liftIO . forgeCookies ss authSettings ssServerKeySet + getPrivate cookieValue `shouldRespondWith` 200 it "rejects requests with incorrect MAC" $ do - (SResponse {..}) <- loginRequest - - cookieValue <- liftIO $ do - session <- maybe - (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account - - sk <- mkServerKey 16 Nothing - renderSession ssAuthSettings ssRandomSource sk session + let newServerKeySet = mkPersistentServerKey "0000000000000000" + cookieValue <- loginRequest + >>= liftIO . forgeCookies ss authSettings newServerKeySet + getPrivate cookieValue `shouldRespondWithException` (IncorrectMAC "") - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - - r `shouldRespondWithException` (IncorrectMAC "") + it "rejects requests with malformed expiration time" $ do + let newAuthSettings = authSettings { acsExpirationFormat = "%0Y%m%d" } + cookieValue <- loginRequest + >>= liftIO . forgeCookies ss newAuthSettings ssServerKeySet + getPrivate cookieValue `shouldRespondWithException` (CannotParseExpirationTime "") + it "rejects requests with expired cookies" $ do + let newAuthSettings = authSettings { acsMaxAge = 0 } + cookieValue <- loginRequest + >>= liftIO . forgeCookies ss newAuthSettings ssServerKeySet + let t = UTCTime (toEnum 0) 0 + getPrivate cookieValue `shouldRespondWithException` (CookieExpired t t) + + +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) +renewalSpec :: SpecState -> Spec +renewalSpec (SpecState {..}) = describe "renewal functionality" $ with + (return $ app ssAuthSettings ssGenerateKey ssRandomSource ssServerKeySet) $ do + + context "keys" $ do + it "automatically creates a key" $ do + keys <- extractKeys + liftIO $ keys `shouldSatisfy` ((== 1) . length) + + it "adds new key" $ do + keys <- extractKeys + addKey + keys' <- extractKeys + liftIO $ keys `shouldBe` (tail keys') + + it "removes a key" $ do + keys <- extractKeys + remKey $ last keys + keys' <- extractKeys + liftIO $ keys' `shouldBe` (init keys) - it "rejects requests with malformed expiration time" $ do - (SResponse {..}) <- loginRequest + context "cookies" $ do + let loginRequest = login "mr_foo" "password1" - cookieValue <- liftIO $ do - session <- maybe + let getCookieValue req = req >>= \resp -> return $ fromMaybe (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account + (lookup "set-cookie" $ simpleHeaders resp) - renderSession - ssAuthSettings { acsExpirationFormat = "%0Y%m%d" } - ssRandomSource - ssServerKey - session + it "rejects requests with deleted keys" $ do + cookieValue <- getCookieValue loginRequest + getPrivate cookieValue `shouldRespondWith` 200 - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - r `shouldRespondWithException` (CannotParseExpirationTime "") + key <- head <$> extractKeys + addKey >> remKey key + getPrivate cookieValue `shouldRespondWith` 403 - it "rejects requests with expired cookies" $ do - (SResponse {..}) <- loginRequest - - cookieValue <- liftIO $ do - session <- maybe - (error "cookies aren't available") - (decryptSession ssAuthSettings ssServerKey) - (parseSessionResponse ssAuthSettings simpleHeaders) :: IO Account + it "accepts requests with old key and renews cookie" $ do + cookieValue <- getCookieValue loginRequest + getPrivate cookieValue `shouldRespondWith` 200 - renderSession - ssAuthSettings { acsMaxAge = 0 } - ssRandomSource - ssServerKey - session + key <- head <$> extractKeys + addKey + newCookieValue <- getCookieValue (getPrivate cookieValue) - let r = request methodGet "/private" [(hCookie, cookieValue)] "" - let dummyTime = UTCTime (toEnum 0) 0 - - r `shouldRespondWithException` (CookieExpired dummyTime dummyTime) + remKey key + getPrivate newCookieValue `shouldRespondWith` 200 + it "does not renew cookies for the newest key" $ do + cookieValue <- getCookieValue loginRequest + _ <- getPrivate cookieValue `shouldRespondWith` 200 + r <- getPrivate cookieValue + liftIO $ (lookup "set-cookie" $ simpleHeaders r) `shouldBe` Nothing +#endif #if MIN_VERSION_hspec_wai (0,7,0) matchBody' :: BSL.ByteString -> MatchBody @@ -192,8 +227,69 @@ shouldRespondWithException :: WaiSession SResponse -> AuthCookieException -> WaiExpectation shouldRespondWithException req ex = do - let exception = BSC8.pack . head . words . show $ ex - (shrinkBody (BSC8.length exception) <$> req) `shouldRespondWith` 403 { - matchBody = matchBody' exception + let exception = BSLC8.pack . head . words . show $ ex + (shrinkBody (BSLC8.length exception) <$> req) `shouldRespondWith` 403 { + matchBody = matchBody' exception + } + +shouldRespondWithMarkup :: WaiSession SResponse -> Markup -> WaiExpectation +shouldRespondWithMarkup req markup = do + req `shouldRespondWith` 200 { + matchBody = matchBody' $ renderMarkup markup } +formContentType :: Header +formContentType = ( + hContentType + , renderHeader $ contentType (Proxy :: Proxy FormUrlEncoded)) + +login :: String -> String -> WaiSession SResponse +login lfUsername lfPassword = request + methodPost "/login" [formContentType] (encode LoginForm {..}) + +getPrivate :: BS.ByteString -> WaiSession SResponse +getPrivate cookieValue = request + methodGet "/private" [(hCookie, cookieValue)] "" + +extractSession :: SpecState -> SResponse -> IO (WithMetadata Account) +extractSession SpecState {..} SResponse {..} = maybe + (error "cookies aren't available") + (decryptSession ssAuthSettings ssServerKeySet) + (parseSessionResponse ssAuthSettings simpleHeaders) + +forgeCookies :: (ServerKeySet k) + => SpecState + -> AuthCookieSettings + -> k + -> SResponse + -> IO BS.ByteString +forgeCookies ss newAuthSettings newServerKeySet r = extractSession ss r + >>= renderSession newAuthSettings (ssRandomSource ss) newServerKeySet . wmData + + +#if MIN_VERSION_servant (0,9,1) && MIN_VERSION_directory (1,2,5) +extractKeys :: WaiSession [BS.ByteString] +extractKeys = (extractKeys' . BSL.toStrict . simpleBody) <$> get "/keys" where + del = '#' + + (openTag, closeTag) = (id *** BS.drop 1) $ BSC8.span (/= del) $ + BSL.toStrict . renderMarkup $ + H.span H.! A.class_ "key" $ H.toHtml [del] + + shrinkBy prefix = BS.drop . BS.length $ prefix + + extractKeys' body = let + body' = snd $ BS.breakSubstring openTag body + (key, rest) = shrinkBy openTag *** shrinkBy closeTag $ + BS.breakSubstring closeTag body' + in if BS.null body' + then [] + else key:(extractKeys' rest) + +addKey :: WaiSession () +addKey = void $ get "/keys/add" + +remKey :: BS.ByteString -> WaiSession () +remKey key = void $ get $ "/keys/rem/" <> (urlEncode True $ key) +#endif + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/servant-auth-cookie.cabal new/servant-auth-cookie-0.5.0.5/servant-auth-cookie.cabal --- old/servant-auth-cookie-0.4.4/servant-auth-cookie.cabal 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/servant-auth-cookie.cabal 2017-07-13 10:40:23.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-auth-cookie -version: 0.4.4 +version: 0.5.0.5 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on @@ -26,12 +26,18 @@ default: False flag servant9 - description: Use servant-0.9 + description: Use servant-0.9 (or higher) + manual: False + default: True + +flag servant91 + description: Use servant-0.9.1 (or higher) manual: False default: True flag build-examples description: Build example executables. + manual: True default: False @@ -45,14 +51,14 @@ , bytestring , cereal >= 0.5 && < 0.6 , cookie >= 0.4.1 && < 0.5 - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , data-default , exceptions >= 0.8 && < 0.9 , http-types >= 0.9 && < 0.10 , memory >= 0.11 && < 0.15 , mtl >= 2.0 && < 3.0 - , servant >= 0.5 && < 0.11 - , servant-server >= 0.5 && < 0.11 + , servant >= 0.5 && < 0.12 + , servant-server >= 0.5 && < 0.12 , tagged == 0.8.* , time >= 1.5 && < 1.8.1 , transformers >= 0.4 && < 0.6 @@ -70,9 +76,14 @@ servant >= 0.9, http-api-data == 0.3.* else - build-depends: - servant < 0.9, - bytestring-conversion >= 0.3.1 && <0.4 + if flag(servant91) + build-depends: + servant >= 0.9, + http-api-data == 0.3.* + else + build-depends: + servant < 0.9, + bytestring-conversion >= 0.3.1 && <0.4 test-suite tests type: exitcode-stdio-1.0 @@ -87,12 +98,13 @@ , QuickCheck >= 2.4 && < 3.0 , bytestring , cereal >= 0.5 && < 0.6 - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , data-default , deepseq >= 1.3 && < 1.5 , hspec >= 2.0 && < 3.0 , servant-auth-cookie - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 + , transformers >= 0.4 && < 0.6 , time >= 1.5 && < 1.8.1 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* @@ -106,21 +118,26 @@ if flag(build-examples) build-depends: base >= 4.7 && < 5.0 , base-compat >= 0.9.1 && <0.10 + , base64-bytestring , blaze-html >= 0.8 && < 0.10 , blaze-markup >= 0.7 && < 0.9 , bytestring , cereal >= 0.5 && < 0.6 - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , data-default + , directory , exceptions + , filepath , http-media + , http-types , mtl >= 2.0 && < 3.0 - , servant >= 0.5 && < 0.11 + , servant >= 0.5 && < 0.12 , servant-auth-cookie , servant-blaze >= 0.5 && < 0.10 - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 , text - , transformers >= 0.4 && < 0.6 + , time + , transformers >= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 , warp >= 3.0 && < 3.3 if flag(servant9) @@ -153,25 +170,29 @@ if flag(build-examples) build-depends: base >= 4.7 && < 5.0 , base-compat >= 0.9.1 && <0.10 + , base64-bytestring , blaze-markup , blaze-html >= 0.8 && < 0.10 , bytestring , cereal >= 0.5 && < 0.6 , exceptions - , cryptonite >= 0.14 && < 0.23 + , cryptonite >= 0.14 && < 0.25 , data-default , deepseq >= 1.3 && < 1.5 + , directory + , filepath , http-media , http-types , hspec >= 2.0 && < 3.0 , hspec-wai + , mtl >= 2.0 && < 3.0 , QuickCheck >= 2.4 && < 3.0 , servant-auth-cookie , servant-blaze >= 0.5 && < 0.10 - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 , text , time >= 1.5 && < 1.8.1 - , transformers >= 0.4 && < 0.6 + , transformers >= 0.4 && < 0.6 , wai , wai-extra if flag(servant9) @@ -179,9 +200,14 @@ servant >= 0.9, http-api-data == 0.3.* else - build-depends: - servant < 0.9, - bytestring-conversion >= 0.3.1 && <0.4 + if flag(servant91) + build-depends: + servant >= 0.9.1, + http-api-data == 0.3.* + else + build-depends: + servant < 0.9, + bytestring-conversion >= 0.3.1 && <0.4 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* @@ -201,10 +227,10 @@ build-depends: base >= 4.7 && < 5.0 , bytestring - , criterion >= 0.6.2.1 && < 1.2 - , cryptonite >= 0.14 && < 0.23 + , criterion >= 0.6.2.1 && < 1.3 + , cryptonite >= 0.14 && < 0.25 , servant-auth-cookie - , servant-server >= 0.5 && < 0.11 + , servant-server >= 0.5 && < 0.12 if flag(dev) ghc-options: -Wall -Werror else diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/src/Servant/Server/Experimental/Auth/Cookie.hs new/servant-auth-cookie-0.5.0.5/src/Servant/Server/Experimental/Auth/Cookie.hs --- old/servant-auth-cookie-0.4.4/src/Servant/Server/Experimental/Auth/Cookie.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/src/Servant/Server/Experimental/Auth/Cookie.hs 2017-07-13 10:40:23.000000000 +0200 @@ -23,6 +23,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} module Servant.Server.Experimental.Auth.Cookie ( CipherAlgorithm @@ -30,14 +31,26 @@ , Cookie (..) , AuthCookieException (..) + , WithMetadata (..) +#if MIN_VERSION_servant(0,9,1) + , Cookied + , cookied +#endif + , RandomSource , mkRandomSource , getRandomBytes + , generateRandomBytes , ServerKey - , mkServerKey - , mkServerKeyFromBytes - , getServerKey + , ServerKeySet (..) + + , PersistentServerKey + , mkPersistentServerKey + + , RenewableKeySet + , RenewableKeySetHooks (..) + , mkRenewableKeySet , AuthCookieSettings (..) @@ -56,16 +69,16 @@ , removeSessionFromErr , getSession + , defaultAuthHandler + -- exposed for testing purpose , renderSession , parseSessionRequest , parseSessionResponse - - , defaultAuthHandler ) where import Blaze.ByteString.Builder (toByteString) -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&), first) import Control.Monad import Control.Monad.Catch (MonadThrow (..), Exception) import Control.Monad.Except @@ -75,11 +88,12 @@ import Crypto.Hash (HashAlgorithm(..)) import Crypto.Hash.Algorithms (SHA256) import Crypto.MAC.HMAC (HMAC) -import Crypto.Random (drgNew, DRG(..)) +import Crypto.Random (DRG(..), drgNew) import Data.ByteString (ByteString) import Data.Default import Data.IORef -import Data.Maybe (fromMaybe) +import Data.List (partition) +import Data.Maybe (listToMaybe) import Data.Monoid ((<>)) import Data.Proxy import Data.Serialize @@ -112,14 +126,22 @@ import Data.ByteString.Conversion (ToByteString (..)) #endif +#if MIN_VERSION_servant(0,9,1) +import Servant (noHeader, Handler) +import Servant.API.ResponseHeaders (Headers) +import qualified Servant.API.Header as S(Header) +#endif + #if MIN_VERSION_http_types(0,9,2) import Network.HTTP.Types (hSetCookie) +#endif + +#if MIN_VERSION_http_types(0,9,2) #else hSetCookie :: HeaderName hSetCookie = "Set-Cookie" #endif - ---------------------------------------------------------------------------- -- General types @@ -128,7 +150,14 @@ -- | A type family that maps user-defined data to 'AuthServerData'. type family AuthCookieData -type instance AuthServerData (AuthProtect "cookie-auth") = AuthCookieData + +-- | Wrapper for cookies and sessions to keep some related metadata. +data WithMetadata a = WithMetadata + { wmData :: a -- ^ Value itself + , wmRenew :: Bool -- ^ Whether we should renew cookies/session + } + +type instance AuthServerData (AuthProtect "cookie-auth") = WithMetadata AuthCookieData -- | Cookie representation. data Cookie = Cookie @@ -154,8 +183,12 @@ builder (EncryptedSession s) = builder s #endif --- | The exception is thrown when something goes wrong with this package. +#if MIN_VERSION_servant(0,9,1) +-- | Helper type to wrap endpoints. +type Cookied a = Headers '[S.Header "Set-Cookie" EncryptedSession] a +#endif +-- | The exception is thrown when something goes wrong with this package. data AuthCookieException = CannotMakeIV ByteString -- ^ Could not make 'IV' for block cipher. @@ -203,8 +236,8 @@ -- | Constructor for 'RandomSource' value. mkRandomSource :: (MonadIO m, DRG d) - => IO d -- ^ How to get deterministic random generator - -> Int -- ^ Threshold (number of bytes to be generated before resetting) + => IO d -- ^ How to get deterministic random generator + -> Int -- ^ Threshold (number of bytes to be generated before resetting) -> m RandomSource -- ^ New 'RandomSource' value mkRandomSource mkDRG threshold = RandomSource mkDRG threshold `liftM` liftIO ((,0) <$> mkDRG >>= newIORef) @@ -226,74 +259,103 @@ ---------------------------------------------------------------------------- -- Server key --- | A mutable state of ServerKey. -data ServerKeyState = ServerKeyState - { sksBytes :: ByteString - -- ^ Current value of the key - , sksExpirationTime :: UTCTime - -- ^ When the key is expires +-- | Internal representation of a server key. +type ServerKey = ByteString + +-- | Interface for a set of server keys. +class ServerKeySet k where + getKeys :: (MonadThrow m, MonadIO m) => k -> m (ServerKey, [ServerKey]) + -- ^ Retrieve current and rotated keys respectively. + + removeKey :: (MonadThrow m, MonadIO m) => k -> ServerKey -> m () + -- ^ Non-graciously remove the key from a keyset. + + +-- | A keyset containing only one key, that doesn't change. +data PersistentServerKey = PersistentServerKey + { pskBytes :: ServerKey } + +instance ServerKeySet PersistentServerKey where + getKeys = return . (,[]) . pskBytes + removeKey _ = error "removeKey @PersistentServerKey: not implemented" + +-- | Create instance of 'PersistentServerKey'. +mkPersistentServerKey :: ByteString -> PersistentServerKey +mkPersistentServerKey bytes = PersistentServerKey { pskBytes = bytes } + + +-- | Customizable actions for 'RenewableKeySet'. +data RenewableKeySetHooks s p = RenewableKeySetHooks + { rkshNewState :: forall m. (MonadIO m, MonadThrow m) + => p -- KeySet parameters + -> ([ServerKey], s) -- Current state + -> m ([ServerKey], s) -- New state + -- ^ Called when a keyset needs to refresh it's state. It's result might be + -- discarded occasionally in favour of result yielded in another thread. + + , rkshNeedUpdate :: forall m. (MonadIO m, MonadThrow m) + => p -- KeySet parameters + -> ([ServerKey], s) -- Current state + -> m Bool -- Whether to update the state + -- ^ Called before retrieving the keys and refreshing the state. + + , rkshRemoveKey :: forall m. (MonadIO m, MonadThrow m) + => p -- KeySet parameters + -> ServerKey -- Key to remove + -> m () -- Action to perform + -- ^ Called after removing the key. This hook is called only if the key + -- belongs to a keyset and called once per key. The only purpose of it is + -- to clear the garbage after removing the key. The state might differs + -- after removing the key and before calling the hook, therefore the hook + -- doesn't rely on the state. } --- | A wrapper of self-resetting 'ByteString' of random symbols suitable for --- concurrent usage. -data ServerKey = ServerKey - { skSize :: Int - -- ^ Size of the key (in bytes) - , skMaxAge :: Maybe NominalDiffTime - -- ^ Expiration time ('Nothing' is enternity) - , skState :: IORef ServerKeyState - -- ^ Mutable state of the key + +-- | Customizable key set, that provides partial implementation of +-- 'ServerKeySet'. +data RenewableKeySet s p = RenewableKeySet + { rksState :: IORef ([ServerKey], s) + -- ^ Key set state (keys and user-defined state). + + , rksParameters :: p + -- ^ User-defined parameters of the key set. + + , rksHooks :: RenewableKeySetHooks s p + -- ^ USer-defined hooks of the key set. } --- | Constructor for 'ServerKey' value. -mkServerKey :: MonadIO m - => Int -- ^ Size of the server key - -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity) - -> m ServerKey -- ^ New 'ServerKey' -mkServerKey skSize skMaxAge = liftIO $ do - skState <- mkServerKeyState skSize skMaxAge >>= newIORef - return ServerKey {..} - --- | Constructor for 'ServerKey' value using predefined key. -mkServerKeyFromBytes :: MonadIO m - => ByteString -- ^ Predefined key - -> m ServerKey -- ^ New 'ServerKey' -mkServerKeyFromBytes bytes = liftIO $ do - let skSize = BS.length bytes - let skMaxAge = Nothing - skState <- newIORef ServerKeyState - { sksBytes = bytes - , sksExpirationTime = UTCTime (toEnum 0) 0 - -- we don't care about the time as the key never expires - } - return ServerKey {..} +instance (Eq s) => ServerKeySet (RenewableKeySet s p) where + getKeys RenewableKeySet {..} = getKeys' rksHooks where + getKeys' RenewableKeySetHooks {..} = do + state <- liftIO $ readIORef rksState + rkshNeedUpdate rksParameters state + >>= \needUpdate -> if not needUpdate + then return $ toResult state + else do + state' <- rkshNewState rksParameters state + liftIO $ atomicModifyIORef' rksState $ \state'' -> id &&& toResult $ + if (userState state /= userState state'') + then state'' + else state' + toResult = (head &&& tail) . fst + userState = snd + + removeKey RenewableKeySet {..} key = do + found <- liftIO $ atomicModifyIORef' rksState $ \(keys, s) -> let + (found, keys') = first (not . null) . partition (== key) $ keys + in ((keys', s), found) + when found $ (rkshRemoveKey rksHooks) rksParameters key + +-- | Create instance of 'RenewableKeySet'. +mkRenewableKeySet :: (MonadIO m) + => RenewableKeySetHooks s p -- ^ Hooks + -> p -- ^ Parameters + -> s -- ^ Initial state + -> m (RenewableKeySet s p) +mkRenewableKeySet rksHooks rksParameters userState = liftIO $ do + rksState <- newIORef ([], userState) + return RenewableKeySet {..} --- | Extract value from 'ServerKey'. -getServerKey :: MonadIO m - => ServerKey -- ^ The 'ServerKey' - -> m ByteString -- ^ Its random symbol -getServerKey ServerKey {..} = liftIO $ maybe - (sksBytes <$> readIORef skState) - (\_ -> do - currentTime <- getCurrentTime - state <- readIORef skState - case (currentTime > sksExpirationTime state) of - False -> return $ sksBytes state - True -> do - state' <- mkServerKeyState skSize skMaxAge - atomicModifyIORef' skState $ \state'' -> id &&& sksBytes $ - if (sksBytes state == sksBytes state'') then state' else state'') - skMaxAge - --- | An initializer of 'ServerKey' state. -mkServerKeyState - :: Int -- ^ Size of the server key - -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity) - -> IO ServerKeyState -mkServerKeyState skSize skMaxAge = do - sksBytes <- fst . randomBytesGenerate skSize <$> drgNew - sksExpirationTime <- addUTCTime (fromMaybe 0 skMaxAge) <$> getCurrentTime - return ServerKeyState {..} ---------------------------------------------------------------------------- -- Settings @@ -347,18 +409,18 @@ -- * 'TooShortProperKey' -- * 'CannotMakeIV' -- * 'BadProperKey' -encryptCookie :: (MonadIO m, MonadThrow m) +encryptCookie :: (MonadIO m, MonadThrow m, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> ServerKey -- ^ 'ServerKey' to use - -> Cookie -- ^ The 'Cookie' to encrypt + -> k -- ^ Instance of 'ServerKeySet' to use + -> Cookie -- ^ The 'Cookie' to encrypt -> m (Tagged EncryptedCookie ByteString) -- ^ Encrypted 'Cookie' is form of 'ByteString' -encryptCookie AuthCookieSettings {..} sk cookie = do +encryptCookie AuthCookieSettings {..} sks cookie = do let iv = cookieIV cookie expiration = BSC8.pack $ formatTime defaultTimeLocale acsExpirationFormat (cookieExpirationTime cookie) - serverKey <- getServerKey sk + (serverKey, _) <- getKeys sks key <- mkProperKey (cipherKeySize $ unProxy acsCipher) (sign acsHashAlgorithm serverKey $ iv <> expiration) @@ -383,12 +445,12 @@ -- * 'IncorrectMAC' -- * 'CannotParseExpirationTime' -- * 'CookieExpired' -decryptCookie :: (MonadIO m, MonadThrow m) +decryptCookie :: (MonadIO m, MonadThrow m, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> ServerKey -- ^ 'ServerKey' to use + -> k -- ^ Instance of 'ServerKeySet' to use -> Tagged EncryptedCookie ByteString -- ^ The 'ByteString' to decrypt - -> m Cookie -- ^ The decrypted 'Cookie' -decryptCookie AuthCookieSettings {..} sk (Tagged s) = do + -> m (WithMetadata Cookie) -- ^ The decrypted 'Cookie' +decryptCookie AuthCookieSettings {..} sks (Tagged s) = do currentTime <- liftIO getCurrentTime let ivSize = blockSize (unProxy acsCipher) expSize = @@ -399,9 +461,16 @@ (iv, s0) = BS.splitAt ivSize s (expirationRaw, s1) = BS.splitAt expSize s0 (payloadRaw, mac) = BS.splitAt payloadSize s1 - serverKey <- getServerKey sk - when (mac /= sign acsHashAlgorithm serverKey (BS.take butMacSize s)) $ - throwM (IncorrectMAC mac) + checkMac sk = mac == sign acsHashAlgorithm sk (BS.take butMacSize s) + + (currentKey, rotatedKeys) <- getKeys sks + (serverKey, renew) <- if checkMac currentKey + then return (currentKey, False) + else liftM (,True) $ maybe + (throwM $ IncorrectMAC mac) + (return) + (listToMaybe . map fst . filter snd . map (id &&& checkMac) $ rotatedKeys) + expirationTime <- maybe (throwM $ CannotParseExpirationTime expirationRaw) return $ parseTimeM False defaultTimeLocale acsExpirationFormat @@ -412,21 +481,25 @@ (cipherKeySize (unProxy acsCipher)) (sign acsHashAlgorithm serverKey $ BS.take (ivSize + expSize) s) payload <- applyCipherAlgorithm acsDecryptAlgorithm iv key payloadRaw - return Cookie - { cookieIV = iv - , cookieExpirationTime = expirationTime - , cookiePayload = payload } + let cookie = Cookie + { cookieIV = iv + , cookieExpirationTime = expirationTime + , cookiePayload = payload } + return WithMetadata + { wmData = cookie + , wmRenew = renew + } ---------------------------------------------------------------------------- -- Encrypt/decrypt session -- | Pack session object into a cookie. The function can throw the same -- exceptions as 'encryptCookie'. -encryptSession :: (MonadIO m, MonadThrow m, Serialize a) +encryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> RandomSource -- ^ Random source to use - -> ServerKey -- ^ 'ServerKey' to use - -> a -- ^ Session value + -> RandomSource -- ^ Random source to use + -> k -- ^ Instance of 'ServerKeySet' to use + -> a -- ^ Session value -> m (Tagged SerializedEncryptedCookie ByteString) -- ^ Serialized and encrypted session encryptSession acs@AuthCookieSettings {..} randomSource sk session = do iv <- getRandomBytes randomSource (blockSize $ unProxy acsCipher) @@ -444,16 +517,18 @@ -- | Unpack session value from a cookie. The function can throw the same -- exceptions as 'decryptCookie'. -decryptSession :: (MonadIO m, MonadThrow m, Serialize a) +decryptSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> ServerKey -- ^ 'ServerKey' to use + -> k -- ^ Instance of 'ServerKeySet' to use -> Tagged SerializedEncryptedCookie ByteString -- ^ Cookie in binary form - -> m a -- ^ Unpacked session value -decryptSession acs@AuthCookieSettings {..} sk s = + -> m (WithMetadata a) -- ^ Unpacked session value +decryptSession acs@AuthCookieSettings {..} sks s = let fromRight = either (throwM . SessionDeserializationFailed) return in fromRight (base64Decode s) >>= - decryptCookie acs sk >>= - fromRight . runGet get . cookiePayload + decryptCookie acs sks >>= + \w -> do + session <- fromRight . runGet get . cookiePayload $ wmData w + return w { wmData = session } ---------------------------------------------------------------------------- -- Add/remove session @@ -464,13 +539,14 @@ :: ( MonadIO m , MonadThrow m , Serialize a - , AddHeader (e :: Symbol) EncryptedSession s r ) + , AddHeader (e :: Symbol) EncryptedSession s r + , ServerKeySet k ) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> RandomSource -- ^ Random source to use - -> ServerKey -- ^ 'ServerKey' to use - -> a -- ^ The session value - -> s -- ^ Response to add session to - -> m r -- ^ Response with the session added + -> RandomSource -- ^ Random source to use + -> k -- ^ Instance of 'ServerKeySet' to use + -> a -- ^ The session value + -> s -- ^ Response to add session to + -> m r -- ^ Response with the session added addSession acs rs sk sessionData response = do header <- renderSession acs rs sk sessionData return (addHeader (EncryptedSession header) response) @@ -490,12 +566,13 @@ addSessionToErr :: ( MonadIO m , MonadThrow m - , Serialize a ) + , Serialize a + , ServerKeySet k ) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> RandomSource -- ^ Random source to use - -> ServerKey -- ^ 'ServerKey' to use - -> a -- ^ The session value - -> ServantErr -- ^ Servant error to add the cookie to + -> RandomSource -- ^ Random source to use + -> k -- ^ Instance of 'ServerKeySet' to use + -> a -- ^ The session value + -> ServantErr -- ^ Servant error to add the cookie to -> m ServantErr addSessionToErr acs rs sk sessionData err = do header <- renderSession acs rs sk sessionData @@ -528,11 +605,11 @@ -- | Request handler that checks cookies. If 'Cookie' is just missing, you -- get 'Nothing', but if something is wrong with its format, 'getSession' -- can throw the same exceptions as 'decryptSession'. -getSession :: (MonadIO m, MonadThrow m, Serialize a) - => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> ServerKey -- ^ 'ServerKey' to use - -> Request -- ^ The request - -> m (Maybe a) -- ^ The result +getSession :: (MonadIO m, MonadThrow m, Serialize a, ServerKeySet k) + => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' + -> k -- ^ 'ServerKeySet' to use + -> Request -- ^ The request + -> m (Maybe (WithMetadata a)) -- ^ The result getSession acs@AuthCookieSettings {..} sk request = maybe (return Nothing) (liftM Just . decryptSession acs sk) @@ -565,10 +642,11 @@ renderSession :: ( MonadIO m , MonadThrow m - , Serialize a ) + , Serialize a + , ServerKeySet k ) => AuthCookieSettings -> RandomSource - -> ServerKey + -> k -> a -> m ByteString renderSession acs@AuthCookieSettings {..} rs sk sessionData = do @@ -581,14 +659,28 @@ n = floor :: NominalDiffTime -> Int (return . toByteString . renderCookies) cookies + +#if MIN_VERSION_servant(0,9,1) +-- | Wrapper for an implementation of an endpoint to make it automatically +-- renew the cookies. +cookied :: (Serialize a, ServerKeySet k) + => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' + -> RandomSource -- ^ Random source to use + -> k -- ^ Instance of 'ServerKeySet' to use + -> (a -> r) -- ^ Implementation of an endpoint + -> ((WithMetadata a) -> Handler (Cookied r)) -- ^ "Cookied" endpoint +cookied acs rs k f = \(WithMetadata {..}) -> + (if wmRenew then addSession acs rs k wmData else (return . noHeader)) $ f wmData +#endif + ---------------------------------------------------------------------------- -- Default auth handler -- | Cookie authentication handler. -defaultAuthHandler :: Serialize a - => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' - -> ServerKey -- ^ 'ServerKey' to use - -> AuthHandler Request a -- ^ +defaultAuthHandler :: (Serialize a, ServerKeySet k) + => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' + -> k -- ^ Instance of 'ServerKeySet' to use + -> AuthHandler Request (WithMetadata a) -- ^ The result defaultAuthHandler acs sk = mkAuthHandler $ \request -> do msession <- liftIO (getSession acs sk request) maybe (throwError err403) return msession @@ -599,9 +691,9 @@ -- | Applies 'H.hmac' algorithm to given data. sign :: forall h. HashAlgorithm h => Proxy h -- ^ The hash algorithm to use - -> ByteString -- ^ - -> ByteString - -> ByteString + -> ByteString -- ^ The key + -> ByteString -- ^ The message + -> ByteString -- ^ The result sign Proxy key msg = BA.convert (H.hmac key msg :: HMAC h) {-# INLINE sign #-} @@ -649,3 +741,8 @@ unProxy :: Proxy a -> a unProxy Proxy = undefined + +-- | Generates random sequence of bytes from new DRG +generateRandomBytes :: Int -> IO ByteString +generateRandomBytes size = (fst . randomBytesGenerate size <$> drgNew) + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-auth-cookie-0.4.4/tests/Main.hs new/servant-auth-cookie-0.5.0.5/tests/Main.hs --- old/servant-auth-cookie-0.4.4/tests/Main.hs 2017-04-15 11:57:55.000000000 +0200 +++ new/servant-auth-cookie-0.5.0.5/tests/Main.hs 2017-07-13 10:40:23.000000000 +0200 @@ -8,6 +8,7 @@ module Main (main) where import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (MonadIO, liftIO) import Crypto.Cipher.AES (AES128, AES192, AES256) import Crypto.Cipher.Types @@ -34,10 +35,11 @@ spec :: Spec spec = do - describe "RandomSource" randomSourceSpec - describe "ServerKey" serverKeySpec - describe "Cookie" cookieSpec - describe "Session" sessionSpec + describe "RandomSource" randomSourceSpec + describe "PersistentServerKey" persistentServerKeySpec + describe "RenewalKeySet" renewalKeySetSpec + describe "Cookie" cookieSpec + describe "Session" sessionSpec randomSourceSpec :: Spec randomSourceSpec = do @@ -61,33 +63,81 @@ s2 <- getRandomBytes rs 10 s1 `shouldNotBe` s2 -serverKeySpec :: Spec -serverKeySpec = do - context "when creating a new server key" $ +persistentServerKeySpec :: Spec +persistentServerKeySpec = do + context "when creating a new persistent server key" $ do + let keySize = 64 + let getSK = mkPersistentServerKey <$> generateRandomBytes keySize + >>= getKeys + it "has correct size" $ do - let keySize = 64 - sk <- mkServerKey keySize Nothing - k <- getServerKey sk + (k, _) <- getSK BS.length k `shouldNotBe` (keySize `div` 8) - context "when creating a new server key from data" $ - it "has data as server key" $ do - let bytes = "0123456789" - sk <- mkServerKeyFromBytes bytes - k <- getServerKey sk - k `shouldBe` bytes - context "until expiration" $ - it "returns the same key" $ do - sk <- mkServerKey 16 Nothing - k0 <- getServerKey sk - k1 <- getServerKey sk - k0 `shouldBe` k1 - context "when a key expires" $ - it "is reset" $ do - sk <- mkServerKey 16 (Just $ fromIntegral (1 :: Integer)) - k1 <- getServerKey sk - threadDelay 2000000 - k2 <- getServerKey sk - k1 `shouldNotBe` k2 + + it "has no rotated keys" $ do + (_, ks) <- getSK + length ks `shouldBe` 0 + + +renewalKeySetSpec :: Spec +renewalKeySetSpec = spec' where + + keySize :: Int + keySize = 16 + + rkshNewState :: (MonadIO m) + => NominalDiffTime + -> ([ServerKey], UTCTime) + -> m ([ServerKey], UTCTime) + rkshNewState _ (keys, _) = liftIO $ (,) + <$> (fmap (:keys) $ generateRandomBytes keySize) + <*> getCurrentTime + + rkshNeedUpdate :: (MonadIO m) + => NominalDiffTime + -> ([ServerKey], UTCTime) + -> m Bool + rkshNeedUpdate dt (_, t) = liftIO $ getCurrentTime >>= return . ((dt `addUTCTime` t) <) + + rkshRemoveKey :: (MonadIO m) + => NominalDiffTime + -> ServerKey + -> m () + rkshRemoveKey _ _ = return () + + spec' = do + let makeSK = mkRenewableKeySet + RenewableKeySetHooks {..} + (fromIntegral (1 :: Integer)) + (UTCTime (toEnum 0) 0) + + context "when accessing a renewable key set" $ do + it "updates the keys when needed" $ do + sk <- makeSK + + (k, ks) <- getKeys sk + BS.length k `shouldNotBe` 0 + + (_, ks') <- threadDelay 1500000 >> getKeys sk + ks' `shouldBe` (k:ks) + + it "doesn't update the keys when not needed" $ do + sk <- makeSK + k <- getKeys sk + k' <- getKeys sk + k' `shouldBe` k + + context "when removing key from a renewable key set" $ do + it "removes specified key" $ do + sk <- makeSK + (_, ks) <- getKeys sk >> threadDelay 1500000 >> getKeys sk + length ks `shouldNotBe` 0 + + let k = head ks + removeKey sk k + (_, ks') <- getKeys sk + (k:ks') `shouldBe` ks + cookieSpec :: Spec cookieSpec = do @@ -179,7 +229,8 @@ -> (BS.ByteString -> BS.ByteString) -- ^ Encryption hook -> IO Cookie -- ^ Restored 'Cookie' cipherId h c encryptAlgorithm decryptAlgorithm cookie encryptionHook = do - sk <- mkServerKey 16 Nothing + sk <- mkPersistentServerKey <$> generateRandomBytes 16 + let sts = case def of AuthCookieSettings {..} -> AuthCookieSettings @@ -188,7 +239,7 @@ , acsHashAlgorithm = h , acsCipher = c , .. } - encryptCookie sts sk cookie >>= decryptCookie sts sk . fmap encryptionHook + encryptCookie sts sk cookie >>= (fmap wmData . decryptCookie sts sk . fmap encryptionHook) sessionSpec :: Spec sessionSpec = do @@ -229,8 +280,8 @@ -> IO (Tree a) encryptThenDecrypt _ settings x = do rs <- mkRandomSource drgNew 1000 - sk <- mkServerKey 16 Nothing - encryptSession settings rs sk x >>= decryptSession settings sk + sk <- mkPersistentServerKey <$> generateRandomBytes 16 + encryptSession settings rs sk x >>= (fmap wmData . decryptSession settings sk) data Tree a = Leaf a | Node a [Tree a] deriving (Eq, Show, Generic) @@ -246,3 +297,4 @@ oneof [ Leaf <$> arbitrary , Node <$> arbitrary <*> vectorOf l (arbitraryTree (n `quot` 2))] +

1 0

commit ghc-servant for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-servant for openSUSE:Factory checked in at 2017-08-31 20:59:06 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant (Old) and /work/SRC/openSUSE:Factory/.ghc-servant.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant" Thu Aug 31 20:59:06 2017 rev:2 rq:513482 version:0.11 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant/ghc-servant.changes 2017-05-09 18:06:37.903371793 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant.new/ghc-servant.changes 2017-08-31 20:59:07.804936722 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:11 UTC 2017 - psimons(a)suse.com + +- Update to version 0.11 revision 1. + +------------------------------------------------------------------- Old: ---- servant-0.9.1.1.tar.gz New: ---- servant-0.11.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant.spec ++++++ --- /var/tmp/diff_new_pack.bMNkl4/_old 2017-08-31 20:59:09.000768704 +0200 +++ /var/tmp/diff_new_pack.bMNkl4/_new 2017-08-31 20:59:09.004768142 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.1.1 +Version: 0.11 Release: 0 Summary: A family of combinators for defining webservices APIs License: BSD-3-Clause @@ -32,20 +32,24 @@ BuildRequires: ghc-attoparsec-devel BuildRequires: ghc-base-compat-devel BuildRequires: ghc-bytestring-devel +BuildRequires: ghc-cabal-doctest-devel BuildRequires: ghc-case-insensitive-devel BuildRequires: ghc-http-api-data-devel BuildRequires: ghc-http-media-devel BuildRequires: ghc-http-types-devel BuildRequires: ghc-mmorph-devel BuildRequires: ghc-mtl-devel +BuildRequires: ghc-natural-transformation-devel BuildRequires: ghc-network-uri-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-string-conversions-devel +BuildRequires: ghc-tagged-devel BuildRequires: ghc-text-devel BuildRequires: ghc-vault-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} BuildRequires: ghc-QuickCheck-devel +BuildRequires: ghc-aeson-compat-devel BuildRequires: ghc-directory-devel BuildRequires: ghc-doctest-devel BuildRequires: ghc-filemanip-devel ++++++ servant-0.9.1.1.tar.gz -> servant-0.11.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/CHANGELOG.md new/servant-0.11/CHANGELOG.md --- old/servant-0.9.1.1/CHANGELOG.md 2016-10-26 17:35:34.000000000 +0200 +++ new/servant-0.11/CHANGELOG.md 2017-05-24 09:22:24.000000000 +0200 @@ -1,3 +1,61 @@ +0.11 +---- + +### Breaking changes + +- `Enter` refactored + ([#734](https://github.com/haskell-servant/servant/issues/734) + , [#736](https://github.com/haskell-servant/servant/pull/736)) + +### Other changes + +- Add a type representing an empty API + ([#753](https://github.com/haskell-servant/servant/pull/753)) +- Add `linkURI'` and `Link` accessors + ([#745](https://github.com/haskell-servant/servant/pull/745) + , [#717](https://github.com/haskell-servant/servant/pull/717) + , [#715](https://github.com/haskell-servant/servant/issues/715)) +- Prepare for GHC-8.2 + ([#722](https://github.com/haskell-servant/servant/pull/722)) +- Add `HasLink AuthProtect` instance + ([#720](https://github.com/haskell-servant/servant/pull/720)) +- `AllCTRender [] ()` `TypeError` (use `NoContent`) + ([#671](https://github.com/haskell-servant/servant/pull/671)) +- Documentation improvements and typo fixes + ([#702](https://github.com/haskell-servant/servant/pull/702) + , [#709](https://github.com/haskell-servant/servant/pull/709) + , [#716](https://github.com/haskell-servant/servant/pull/716) + , [#725](https://github.com/haskell-servant/servant/pull/725) + , [#727](https://github.com/haskell-servant/servant/pull/727)) + +0.10 +---- + +### Breaking changes + +* Use `NT` from `natural-transformation` for `Enter` + ([#616](https://github.com/haskell-servant/servant/issues/616)) + +* Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link` + use its `ToHttpApiData` instance or `linkURI`. + ([#527](https://github.com/haskell-servant/servant/issues/527)) + +### Other changes + +* Add `Servant.API.TypeLevel` module with type families to work with API types. + ([#345](https://github.com/haskell-servant/servant/pull/345) + , [#305](https://github.com/haskell-servant/servant/issues/305)) + +* Default JSON content type change to `application/json;charset=utf-8`. + ([#263](https://github.com/haskell-servant/servant/issues/263)) + Related browser bugs: + [Chromium](https://bugs.chromium.org/p/chromium/issues/detail?id=438464) and + [Firefox](https://bugzilla.mozilla.org/show_bug.cgi?id=918742) + +* `Accept` class may accept multiple content-types. `MimeUnrender` adopted as well. + ([#613](https://github.com/haskell-servant/servant/pull/614) + , [#615](https://github.com/haskell-servant/servant/pull/615)) + 0.9.1 ------ @@ -14,6 +72,8 @@ ---- * Add `CaptureAll` combinator. Captures all of the remaining segments in a URL. +* Add `Servant.API.TypeLevel` module, with frequently used type-level +functionaliy. 0.8 --- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/Setup.hs new/servant-0.11/Setup.hs --- old/servant-0.9.1.1/Setup.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/Setup.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/Setup.lhs new/servant-0.11/Setup.lhs --- old/servant-0.9.1.1/Setup.lhs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.11/Setup.lhs 2017-05-24 09:22:24.000000000 +0200 @@ -0,0 +1,31 @@ +\begin{code} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif + +\end{code} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/servant.cabal new/servant-0.11/servant.cabal --- old/servant-0.9.1.1/servant.cabal 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-0.11/servant.cabal 2017-05-24 09:22:24.000000000 +0200 @@ -1,5 +1,5 @@ name: servant -version: 0.9.1.1 +version: 0.11 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them @@ -14,8 +14,8 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web -build-type: Simple +category: Servant Web +build-type: Custom cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files: @@ -25,6 +25,12 @@ type: git location: http://github.com/haskell-servant/servant.git +custom-setup + setup-depends: + base >= 4 && <5, + Cabal, + cabal-doctest >= 1.0.2 && <1.1 + library exposed-modules: Servant.API @@ -32,6 +38,7 @@ Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes + Servant.API.Empty Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion @@ -43,6 +50,7 @@ Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub + Servant.API.TypeLevel Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext @@ -51,19 +59,26 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10 - , aeson >= 0.7 && < 1.1 + , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , http-api-data >= 0.3 && < 0.4 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 + , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 - , mmorph >= 1 && < 1.1 + , mmorph >= 1 && < 1.2 + , tagged >= 0.7.3 && < 0.9 , text >= 1 && < 1.3 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 && < 2.7 , vault >= 0.3 && < 0.4 + + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.16 && < 0.19 + hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP @@ -101,10 +116,12 @@ Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec Servant.Utils.LinksSpec + Servant.Utils.EnterSpec build-depends: base == 4.* , base-compat , aeson + , aeson-compat >=0.3.3 && <0.4 , attoparsec , bytestring , hspec == 2.* @@ -115,6 +132,10 @@ , text , url + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.16 && < 0.19 + test-suite doctests build-depends: base , servant @@ -122,9 +143,14 @@ , filemanip , directory , filepath + , hspec type: exitcode-stdio-1.0 - main-is: test/Doctests.hs + main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded + if impl(ghc >= 8.2) + x-doctest-options: -fdiagnostics-color=never include-dirs: include + x-doctest-source-dirs: test + x-doctest-modules: Servant.Utils.LinksSpec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/Alternative.hs new/servant-0.11/src/Servant/API/Alternative.hs --- old/servant-0.9.1.1/src/Servant/API/Alternative.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/src/Servant/API/Alternative.hs 2017-05-24 09:22:24.000000000 +0200 @@ -7,6 +7,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where +import Data.Semigroup (Semigroup (..)) import Data.Typeable (Typeable) import Prelude () import Prelude.Compat @@ -23,6 +24,9 @@ deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 8 :<|> +instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where + (a :<|> b) <> (a' :<|> b') = (a <> a') :<|> (b <> b') + instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/ContentTypes.hs new/servant-0.11/src/Servant/API/ContentTypes.hs --- old/servant-0.9.1.1/src/Servant/API/ContentTypes.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/src/Servant/API/ContentTypes.hs 2017-05-24 09:22:24.000000000 +0200 @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -81,6 +82,7 @@ import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) import Data.String.Conversions (cs) import qualified Data.Text as TextS @@ -96,6 +98,10 @@ import Prelude () import Prelude.Compat +#if MIN_VERSION_base(4,9,0) +import qualified GHC.TypeLits as TL +#endif + -- * Provided content types data JSON deriving Typeable data PlainText deriving Typeable @@ -119,10 +125,18 @@ -- class Accept ctype where contentType :: Proxy ctype -> M.MediaType + contentType = NE.head . contentTypes + + contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType + contentTypes = (NE.:| []) . contentType + + {-# MINIMAL contentType | contentTypes #-} -- | @application/json@ instance Accept JSON where - contentType _ = "application" M.// "json" + contentTypes _ = + "application" M.// "json" M./: ("charset", "utf-8") NE.:| + [ "application" M.// "json" ] -- | @application/x-www-form-urlencoded@ instance Accept FormUrlEncoded where @@ -172,6 +186,12 @@ amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs +#if MIN_VERSION_base(4,9,0) +instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") + => AllCTRender '[] () where + handleAcceptH _ _ _ = error "unreachable" +#endif + -------------------------------------------------------------------------- -- * Unrender @@ -198,16 +218,32 @@ -- class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a + mimeUnrender p = mimeUnrenderWithType p (contentType p) + + -- | Variant which is given the actual 'M.MediaType' provided by the other party. + -- + -- In the most cases you don't want to branch based on the 'M.MediaType'. + -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example. + mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a + mimeUnrenderWithType p _ = mimeUnrender p + + {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} class AllCTUnrender (list :: [*]) a where + canHandleCTypeH + :: Proxy list + -> ByteString -- Content-Type header + -> Maybe (ByteString -> Either String a) + handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) + handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) - where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body + canHandleCTypeH p ctypeH = + M.mapContentMedia (allMimeUnrender p) (cs ctypeH) -------------------------------------------------------------------------- -- * Utils (Internal) @@ -219,9 +255,10 @@ allMime _ = [] instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where - allMime _ = (contentType pctyp):allMime pctyps - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps + allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps + where + pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h @@ -235,25 +272,31 @@ -> [(M.MediaType, ByteString)] -- content-types/response pairs instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where - allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] - where pctyp = Proxy :: Proxy ctyp + allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp + where + bs = mimeRender pctyp a + pctyp = Proxy :: Proxy ctyp instance OVERLAPPABLE_ ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where - allMimeRender _ a = (contentType pctyp, mimeRender pctyp a) - :(allMimeRender pctyps a) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy (ctyp' ': ctyps) + allMimeRender _ a = + (map (, bs) $ NE.toList $ contentTypes pctyp) + ++ allMimeRender pctyps a + where + bs = mimeRender pctyp a + pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy (ctyp' ': ctyps) -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where - allMimeRender _ _ = [(contentType pctyp, "")] - where pctyp = Proxy :: Proxy ctyp + allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp + where + pctyp = Proxy :: Proxy ctyp instance OVERLAPPING_ ( AllMime (ctyp ': ctyp' ': ctyps) @@ -265,19 +308,21 @@ -------------------------------------------------------------------------- class (AllMime list) => AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list - -> ByteString - -> [(M.MediaType, Either String a)] + -> [(M.MediaType, ByteString -> Either String a)] instance AllMimeUnrender '[] a where - allMimeUnrender _ _ = [] + allMimeUnrender _ = [] instance ( MimeUnrender ctyp a , AllMimeUnrender ctyps a ) => AllMimeUnrender (ctyp ': ctyps) a where - allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val) - :(allMimeUnrender pctyps val) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps + allMimeUnrender _ = + (map mk $ NE.toList $ contentTypes pctyp) + ++ allMimeUnrender pctyps + where + mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs) + pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps -------------------------------------------------------------------------- -- * MimeRender Instances @@ -374,6 +419,9 @@ -- $setup +-- >>> :set -XFlexibleInstances +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XOverloadedStrings -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/Empty.hs new/servant-0.11/src/Servant/API/Empty.hs --- old/servant-0.9.1.1/src/Servant/API/Empty.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.11/src/Servant/API/Empty.hs 2017-05-24 09:22:24.000000000 +0200 @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Empty(EmptyAPI(..)) where + +import Data.Typeable (Typeable) +import Prelude () +import Prelude.Compat + +-- | An empty API: one which serves nothing. Morally speaking, this should be +-- the unit of ':<|>'. Implementors of interpretations of API types should +-- treat 'EmptyAPI' as close to the unit as possible. +data EmptyAPI = EmptyAPI deriving (Typeable, Eq, Show, Bounded, Enum) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/Internal/Test/ComprehensiveAPI.hs new/servant-0.11/src/Servant/API/Internal/Test/ComprehensiveAPI.hs --- old/servant-0.9.1.1/src/Servant/API/Internal/Test/ComprehensiveAPI.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/src/Servant/API/Internal/Test/ComprehensiveAPI.hs 2017-05-24 09:22:24.000000000 +0200 @@ -37,7 +37,8 @@ Verb 'POST 204 '[JSON] NoContent :<|> Verb 'POST 204 '[JSON] Int :<|> WithNamedContext "foo" '[] GET :<|> - CaptureAll "foo" Int :> GET + CaptureAll "foo" Int :> GET :<|> + EmptyAPI comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/RemoteHost.hs new/servant-0.11/src/Servant/API/RemoteHost.hs --- old/servant-0.9.1.1/src/Servant/API/RemoteHost.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/src/Servant/API/RemoteHost.hs 2017-05-24 09:22:24.000000000 +0200 @@ -12,7 +12,7 @@ -- $remotehost -- --- | Use 'RemoteHost' whenever your request handlers need the host or IP address +-- Use 'RemoteHost' whenever your request handlers need the host or IP address -- from which the client issued the HTTP request. The corresponding handlers -- receive arguments of type @SockAddr@ (from @Network.Socket@). -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/ResponseHeaders.hs new/servant-0.11/src/Servant/API/ResponseHeaders.hs --- old/servant-0.9.1.1/src/Servant/API/ResponseHeaders.hs 2016-10-24 18:27:44.000000000 +0200 +++ new/servant-0.11/src/Servant/API/ResponseHeaders.hs 2017-05-24 09:22:24.000000000 +0200 @@ -45,7 +45,7 @@ import Prelude.Compat -- | Response Header objects. You should never need to construct one directly. --- Instead, use 'addOptionalHeader. +-- Instead, use 'addOptionalHeader'. data Headers ls a = Headers { getResponse :: a -- ^ The underlying value of a 'Headers' , getHeadersHList :: HList ls @@ -125,7 +125,7 @@ -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: -- --- 1. A simple value is wrapped in "Headers [<hdr>]": +-- 1. A simple value is wrapped in "Headers '[hdr]": -- -- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; -- >>> getHeaders example1 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/TypeLevel.hs new/servant-0.11/src/Servant/API/TypeLevel.hs --- old/servant-0.9.1.1/src/Servant/API/TypeLevel.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.11/src/Servant/API/TypeLevel.hs 2017-05-24 09:22:24.000000000 +0200 @@ -0,0 +1,264 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +This module collects utilities for manipulating @servant@ API types. The +functionality in this module is for advanced usage. + +The code samples in this module use the following type synonym: + +> type SampleAPI = "hello" :> Get '[JSON] Int +> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool + +-} +module Servant.API.TypeLevel ( + -- $setup + -- * API predicates + Endpoints, + -- ** Lax inclusion + IsElem', + IsElem, + IsSubAPI, + AllIsElem, + -- ** Strict inclusion + IsIn, + IsStrictSubAPI, + AllIsIn, + -- * Helpers + -- ** Lists + MapSub, + AppendList, + IsSubList, + Elem, + ElemGo, + -- ** Logic + Or, + And, + -- * Custom type errors + -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class, + -- which cannot be instantiated. + ) where + + +import GHC.Exts (Constraint) +import Servant.API.Alternative (type (:<|>)) +import Servant.API.Capture (Capture, CaptureAll) +import Servant.API.Header (Header) +import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) +import Servant.API.ReqBody (ReqBody) +import Servant.API.Sub (type (:>)) +import Servant.API.Verbs (Verb) +#if MIN_VERSION_base(4,9,0) +import GHC.TypeLits (TypeError, ErrorMessage(..)) +#endif + + + +-- * API predicates + +-- | Flatten API into a list of endpoints. +-- +-- >>> Refl :: Endpoints SampleAPI :~: '["hello" :> Verb 'GET 200 '[JSON] Int, "bye" :> (Capture "name" String :> Verb 'POST 200 '[JSON, PlainText] Bool)] +-- Refl +type family Endpoints api where + Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b) + Endpoints (e :> a) = MapSub e (Endpoints a) + Endpoints a = '[a] + +-- ** Lax inclusion + +-- | You may use this type family to tell the type checker that your custom +-- type may be skipped as part of a link. This is useful for things like +-- @'QueryParam'@ that are optional in a URI and do not affect them if they are +-- omitted. +-- +-- >>> data CustomThing +-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s +-- +-- Note that @'IsElem'@ is called, which will mutually recurse back to @'IsElem''@ +-- if it exhausts all other options again. +-- +-- Once you have written a @HasLink@ instance for @CustomThing@ you are ready to go. +type family IsElem' a s :: Constraint + +-- | Closed type family, check if @endpoint@ is within @api@. +-- Uses @'IsElem''@ if it exhausts all other options. +-- +-- >>> ok (Proxy :: Proxy (IsElem ("hello" :> Get '[JSON] Int) SampleAPI)) +-- OK +-- +-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI)) +-- ... +-- ... Could not deduce... +-- ... +-- +-- An endpoint is considered within an api even if it is missing combinators +-- that don't affect the URL: +-- +-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))) +-- OK +-- +-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int))) +-- OK +-- +-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL +-- represented by @a@ would match the URL represented by @b@, *not* whether a +-- request represented by @a@ matches the endpoints serving @b@ (for the +-- latter, use 'IsIn'). +type family IsElem endpoint api :: Constraint where + IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) + IsElem (e :> sa) (e :> sb) = IsElem sa sb + IsElem sa (Header sym x :> sb) = IsElem sa sb + IsElem sa (ReqBody y x :> sb) = IsElem sa sb + IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) + = IsElem sa sb + IsElem (Capture z y :> sa) (Capture x y :> sb) + = IsElem sa sb + IsElem sa (QueryParam x y :> sb) = IsElem sa sb + IsElem sa (QueryParams x y :> sb) = IsElem sa sb + IsElem sa (QueryFlag x :> sb) = IsElem sa sb + IsElem (Verb m s ct typ) (Verb m s ct' typ) + = IsSubList ct ct' + IsElem e e = () + IsElem e a = IsElem' e a + +-- | Check whether @sub@ is a sub-API of @api@. +-- +-- >>> ok (Proxy :: Proxy (IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int))) +-- OK +-- +-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI)) +-- ... +-- ... Could not deduce... +-- ... +-- +-- This uses @IsElem@ for checking; thus the note there applies here. +type family IsSubAPI sub api :: Constraint where + IsSubAPI sub api = AllIsElem (Endpoints sub) api + +-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsElem'@). +type family AllIsElem xs api :: Constraint where + AllIsElem '[] api = () + AllIsElem (x ': xs) api = (IsElem x api, AllIsElem xs api) + +-- ** Strict inclusion + +-- | Closed type family, check if @endpoint@ is exactly within @api@. +-- +-- >>> ok (Proxy :: Proxy (IsIn ("hello" :> Get '[JSON] Int) SampleAPI)) +-- OK +-- +-- Unlike 'IsElem', this requires an *exact* match. +-- +-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))) +-- ... +-- ... Could not deduce... +-- ... +type family IsIn (endpoint :: *) (api :: *) :: Constraint where + IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb) + IsIn (e :> sa) (e :> sb) = IsIn sa sb + IsIn e e = () + +-- | Check whether @sub@ is a sub API of @api@. +-- +-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'. +type family IsStrictSubAPI sub api :: Constraint where + IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api + +-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@). +-- +-- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) +-- OK +type family AllIsIn xs api :: Constraint where + AllIsIn '[] api = () + AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api) + +-- * Helpers + +-- ** Lists + +-- | Apply @(e :>)@ to every API in @xs@. +type family MapSub e xs where + MapSub e '[] = '[] + MapSub e (x ': xs) = (e :> x) ': MapSub e xs + +-- | Append two type-level lists. +type family AppendList xs ys where + AppendList '[] ys = ys + AppendList (x ': xs) ys = x ': AppendList xs ys + +type family IsSubList a b :: Constraint where + IsSubList '[] b = () + IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y + +-- | Check that a value is an element of a list: +-- +-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool])) +-- OK +-- +-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool])) +-- ... +-- ... [Char]...'[Int, Bool... +-- ... +type Elem e es = ElemGo e es es + +-- 'orig' is used to store original list for better error messages +type family ElemGo e es orig :: Constraint where + ElemGo x (x ': xs) orig = () + ElemGo y (x ': xs) orig = ElemGo y xs orig +#if MIN_VERSION_base(4,9,0) + -- Note [Custom Errors] + ElemGo x '[] orig = TypeError ('ShowType x + ':<>: 'Text " expected in list " + ':<>: 'ShowType orig) +#else + ElemGo x '[] orig = ElemNotFoundIn x orig +#endif + +-- ** Logic + +-- | If either a or b produce an empty constraint, produce an empty constraint. +type family Or (a :: Constraint) (b :: Constraint) :: Constraint where + -- This works because of: + -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap + Or () b = () + Or a () = () + +-- | If both a or b produce an empty constraint, produce an empty constraint. +type family And (a :: Constraint) (b :: Constraint) :: Constraint where + And () () = () + +-- * Custom type errors + +#if !MIN_VERSION_base(4,9,0) +class ElemNotFoundIn val list +#endif + +{- Note [Custom Errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We might try to factor these our more cleanly, but the type synonyms and type +families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). +-} + + +-- $setup +-- +-- The doctests in this module are run with following preamble: +-- +-- >>> :set -XPolyKinds +-- >>> :set -XGADTs +-- >>> import Data.Proxy +-- >>> import Data.Type.Equality +-- >>> import Servant.API +-- >>> data OK ctx where OK :: ctx => OK ctx +-- >>> instance Show (OK ctx) where show _ = "OK" +-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK +-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool +-- >>> let sampleAPI = Proxy :: Proxy SampleAPI diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API.hs new/servant-0.11/src/Servant/API.hs --- old/servant-0.9.1.1/src/Servant/API.hs 2016-10-24 18:27:44.000000000 +0200 +++ new/servant-0.11/src/Servant/API.hs 2017-05-24 09:22:24.000000000 +0200 @@ -5,6 +5,8 @@ -- | Type-level combinator for expressing subrouting: @':>'@ module Servant.API.Alternative, -- | Type-level combinator for alternative endpoints: @':<|>'@ + module Servant.API.Empty, + -- | Type-level combinator for an empty API: @'EmptyAPI'@ -- * Accessing information from the request module Servant.API.Capture, @@ -66,6 +68,7 @@ MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText) +import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) @@ -101,7 +104,7 @@ ReflectMethod (reflectMethod), Verb, StdMethod(..)) import Servant.API.WithNamedContext (WithNamedContext) -import Servant.Utils.Links (HasLink (..), IsElem, IsElem', +import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/Utils/Enter.hs new/servant-0.11/src/Servant/Utils/Enter.hs --- old/servant-0.9.1.1/src/Servant/Utils/Enter.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/src/Servant/Utils/Enter.hs 2017-05-24 09:22:24.000000000 +0200 @@ -8,9 +8,13 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Servant.Utils.Enter where +module Servant.Utils.Enter ( + module Servant.Utils.Enter, + -- * natural-transformation re-exports + (:~>)(..), + ) where -import qualified Control.Category as C +import Control.Natural import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Reader @@ -18,77 +22,101 @@ import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter -import Data.Typeable +import Data.Tagged (Tagged, retag) import Prelude () import Prelude.Compat - import Servant.API -class Enter typ arg ret | typ arg -> ret, typ ret -> arg where - enter :: arg -> typ -> ret - --- ** Servant combinators -instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2 - , arg1 ~ arg2 - ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where +-- | Helper type family to state the 'Enter' symmetry. +type family Entered m n api where + Entered m n (a -> api) = a -> Entered m n api + Entered m n (m a) = n a + Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2 + Entered m n (Tagged m a) = Tagged n a + +class + ( Entered m n typ ~ ret + , Entered n m ret ~ typ + ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m + where + -- | Map the leafs of an API type. + enter :: (m :~> n) -> typ -> ret + +-- ** Servant combinators + +instance + ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2 + , m1 ~ m2, n1 ~ n2 + , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2) + , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2) + ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2) + where enter e (a :<|> b) = enter e a :<|> enter e b -instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where +instance + ( Enter typ m n ret + , Entered m n (a -> typ) ~ (a -> ret) + , Entered n m (a -> ret) ~ (a -> typ) + ) => Enter (a -> typ) m n (a -> ret) + where enter arg f a = enter arg (f a) --- ** Useful instances - --- | A natural transformation from @m@ to @n@. Used to `enter` particular --- datatypes. -newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable - -instance C.Category (:~>) where - id = Nat id - Nat f . Nat g = Nat (f . g) +-- ** Leaf instances -instance Enter (m a) (m :~> n) (n a) where - enter (Nat f) = f +instance + ( Entered m n (Tagged m a) ~ Tagged n a + , Entered n m (Tagged n a) ~ Tagged m a + ) => Enter (Tagged m a) m n (Tagged n a) + where + enter _ = retag + +instance + ( Entered m n (m a) ~ n a + , Entered n m (n a) ~ m a + ) => Enter (m a) m n (n a) + where + enter (NT f) = f -- | Like `lift`. liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m -liftNat = Nat Control.Monad.Morph.lift +liftNat = NT Control.Monad.Morph.lift runReaderTNat :: r -> (ReaderT r m :~> m) -runReaderTNat a = Nat (`runReaderT` a) +runReaderTNat a = NT (`runReaderT` a) evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) -evalStateTLNat a = Nat (`LState.evalStateT` a) +evalStateTLNat a = NT (`LState.evalStateT` a) evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) -evalStateTSNat a = Nat (`SState.evalStateT` a) +evalStateTSNat a = NT (`SState.evalStateT` a) -- | Log the contents of `SWriter.WriterT` with the function provided as the -- first argument, and return the value of the @WriterT@ computation logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m) -logWriterTSNat logger = Nat $ \x -> do +logWriterTSNat logger = NT $ \x -> do (a, w) <- SWriter.runWriterT x liftIO $ logger w return a --- | Like `logWriterTSNat`, but for strict @WriterT@. +-- | Like `logWriterTSNat`, but for lazy @WriterT@. logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) -logWriterTLNat logger = Nat $ \x -> do +logWriterTLNat logger = NT $ \x -> do (a, w) <- LWriter.runWriterT x liftIO $ logger w return a -- | Like @mmorph@'s `hoist`. hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) -hoistNat (Nat n) = Nat $ hoist n +hoistNat (NT n) = NT $ hoist n -- | Like @mmorph@'s `embed`. embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) -embedNat (Nat n) = Nat $ embed n +embedNat (NT n) = NT $ embed n -- | Like @mmorph@'s `squash`. squashNat :: (Monad m, MMonad t) => t (t m) :~> t m -squashNat = Nat squash +squashNat = NT squash -- | Like @mmorph@'s `generalize`. generalizeNat :: Applicative m => Identity :~> m -generalizeNat = Nat (pure . runIdentity) +generalizeNat = NT (pure . runIdentity) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/Utils/Links.hs new/servant-0.11/src/Servant/Utils/Links.hs --- old/servant-0.9.1.1/src/Servant/Utils/Links.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/src/Servant/Utils/Links.hs 2017-05-24 09:22:24.000000000 +0200 @@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. @@ -30,7 +29,7 @@ -- you would like to restrict links to. The second argument is the destination -- endpoint you would like the link to point to, this will need to end with a -- verb like GET or POST. Further arguments may be required depending on the --- type of the endpoint. If everything lines up you will get a 'URI' out the +-- type of the endpoint. If everything lines up you will get a 'Link' out the -- other end. -- -- You may omit 'QueryParam's and the like should you not want to provide them, @@ -41,19 +40,19 @@ -- with an example. Here, a link is generated with no parameters: -- -- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int) --- >>> print (safeLink api hello :: URI) --- hello +-- >>> toUrlPiece (safeLink api hello :: Link) +-- "hello" -- -- If the API has an endpoint with parameters then we can generate links with -- or without those: -- -- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent) --- >>> print $ safeLink api with (Just "Hubert") --- bye?name=Hubert +-- >>> toUrlPiece $ safeLink api with (Just "Hubert") +-- "bye?name=Hubert" -- -- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent) --- >>> print $ safeLink api without --- bye +-- >>> toUrlPiece $ safeLink api without +-- "bye" -- -- If you would like create a helper for generating links only within that API, -- you can partially apply safeLink if you specify a correct type signature @@ -79,27 +78,30 @@ -- bad_link under api after trying the open (but empty) type family -- `IsElem'` as a last resort. module Servant.Utils.Links ( + module Servant.API.TypeLevel, + -- * Building and using safe links -- - -- | Note that 'URI' is Network.URI.URI from the network-uri package. + -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink , URI(..) -- * Adding custom types , HasLink(..) - , linkURI , Link - , IsElem' - -- * Illustrative exports - , IsElem - , Or + , linkURI + , linkURI' + , LinkArrayElementStyle (..) + -- ** Link accessors + , Param (..) + , linkSegments + , linkQueryParams ) where -import qualified Data.ByteString.Char8 as BSC import Data.List import Data.Monoid.Compat ( (<>) ) import Data.Proxy ( Proxy(..) ) import qualified Data.Text as Text -import GHC.Exts (Constraint) +import qualified Data.Text.Encoding as TE import GHC.TypeLits ( KnownSymbol, symbolVal ) import Network.URI ( URI(..), escapeURIString, isUnreserved ) import Prelude () @@ -115,77 +117,31 @@ import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) -import Servant.API.Alternative ( type (:<|>) ) +import Servant.API.TypeLevel +import Servant.API.Experimental.Auth ( AuthProtect ) -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any -- 'Link' is guaranteed to be part of the mentioned API. data Link = Link - { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] - , _queryParams :: [Param Query] + { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] + , _queryParams :: [Param] } deriving Show -instance ToHttpApiData Link where - toUrlPiece = Text.pack . show - toHeader = BSC.pack . show +linkSegments :: Link -> [String] +linkSegments = _segments --- | If either a or b produce an empty constraint, produce an empty constraint. -type family Or (a :: Constraint) (b :: Constraint) :: Constraint where - -- This works because of: - -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap - Or () b = () - Or a () = () - --- | If both a or b produce an empty constraint, produce an empty constraint. -type family And (a :: Constraint) (b :: Constraint) :: Constraint where - And () () = () - --- | You may use this type family to tell the type checker that your custom --- type may be skipped as part of a link. This is useful for things like --- 'QueryParam' that are optional in a URI and do not affect them if they are --- omitted. --- --- >>> data CustomThing --- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s --- --- Note that 'IsElem' is called, which will mutually recurse back to `IsElem'` --- if it exhausts all other options again. --- --- Once you have written a HasLink instance for CustomThing you are ready to --- go. -type family IsElem' a s :: Constraint - --- | Closed type family, check if endpoint is within api -type family IsElem endpoint api :: Constraint where - IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) - IsElem (e :> sa) (e :> sb) = IsElem sa sb - IsElem sa (Header sym x :> sb) = IsElem sa sb - IsElem sa (ReqBody y x :> sb) = IsElem sa sb - IsElem (Capture z y :> sa) (Capture x y :> sb) - = IsElem sa sb - IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) - = IsElem sa sb - IsElem sa (QueryParam x y :> sb) = IsElem sa sb - IsElem sa (QueryParams x y :> sb) = IsElem sa sb - IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Verb m s ct typ) (Verb m s ct' typ) - = IsSubList ct ct' - IsElem e e = () - IsElem e a = IsElem' e a - -type family IsSubList a b :: Constraint where - IsSubList '[] b = () - IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y - -type family Elem e es :: Constraint where - Elem x (x ': xs) = () - Elem y (x ': xs) = Elem y xs +linkQueryParams :: Link -> [Param] +linkQueryParams = _queryParams --- Phantom types for Param -data Query +instance ToHttpApiData Link where + toHeader = TE.encodeUtf8 . toUrlPiece + toUrlPiece l = + let uri = linkURI l + in Text.pack $ uriPath uri ++ uriQuery uri --- | Query param -data Param a +-- | Query parameter. +data Param = SingleParam String Text.Text | ArrayElemParam String Text.Text | FlagParam String @@ -194,27 +150,63 @@ addSegment :: String -> Link -> Link addSegment seg l = l { _segments = _segments l <> [seg] } -addQueryParam :: Param Query -> Link -> Link +addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } +-- | Transform 'Link' into 'URI'. +-- +-- >>> type API = "something" :> Get '[JSON] Int +-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) +-- something +-- +-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int +-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] +-- sum?x[]=1&x[]=2&x[]=3 +-- +-- >>> type API = "foo/bar" :> Get '[JSON] Int +-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) +-- foo%2Fbar +-- linkURI :: Link -> URI -linkURI (Link segments q_params) = +linkURI = linkURI' LinkArrayElementBracket + +-- | How to encode array query elements. +data LinkArrayElementStyle + = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@ + | LinkArrayElementPlain -- ^ @foo=1&foo=2@ + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Configurable 'linkURI'. +-- +-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int +-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] +-- sum?x[]=1&x[]=2&x[]=3 +-- +-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] +-- sum?x=1&x=2&x=3 +-- +linkURI' :: LinkArrayElementStyle -> Link -> URI +linkURI' addBrackets (Link segments q_params) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative) - (intercalate "/" segments) + (intercalate "/" $ map escape segments) (makeQueries q_params) mempty where - makeQueries :: [Param Query] -> String + makeQueries :: [Param] -> String makeQueries [] = "" makeQueries xs = "?" <> intercalate "&" (fmap makeQuery xs) - makeQuery :: Param Query -> String - makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v) + makeQuery :: Param -> String + makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v) makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k + style = case addBrackets of + LinkArrayElementBracket -> "[]=" + LinkArrayElementPlain -> "=" + escape :: String -> String escape = escapeURIString isUnreserved @@ -307,9 +299,17 @@ -- Verb (terminal) instances instance HasLink (Verb m s ct a) where - type MkLink (Verb m s ct a) = URI - toLink _ = linkURI + type MkLink (Verb m s ct a) = Link + toLink _ = id instance HasLink Raw where - type MkLink Raw = URI - toLink _ = linkURI + type MkLink Raw = Link + toLink _ = id + +-- AuthProtext instances +instance HasLink sub => HasLink (AuthProtect tag :> sub) where + type MkLink (AuthProtect tag :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + +-- $setup +-- >>> import Servant.API diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Doctests.hs new/servant-0.11/test/Doctests.hs --- old/servant-0.9.1.1/test/Doctests.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/test/Doctests.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,40 +0,0 @@ -module Main where - -import Data.List (isPrefixOf) -import System.Directory -import System.FilePath -import System.FilePath.Find -import Test.DocTest - -main :: IO () -main = do - files <- find always (extension ==? ".hs") "src" - tfiles <- find always (extension ==? ".hs") "test/Servant" - mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : "-Iinclude" : - (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ - "-XOverloadedStrings" : - "-XFlexibleInstances" : - "-XMultiParamTypeClasses" : - (files ++ tfiles) - -getCabalMacrosFile :: IO (Maybe FilePath) -getCabalMacrosFile = do - exists <- doesDirectoryExist "dist" - if exists - then do - contents <- getDirectoryContents "dist" - let rest = "build" </> "autogen" </> "cabal_macros.h" - whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of - [x] -> "dist" </> x </> rest - [] -> "dist" </> rest - xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n" - ++ show xs ++ "\nTry cabal clean" - else return Nothing - where - whenExists :: FilePath -> IO (Maybe FilePath) - whenExists file = do - exists <- doesFileExist file - return $ if exists - then Just file - else Nothing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Servant/API/ContentTypesSpec.hs new/servant-0.11/test/Servant/API/ContentTypesSpec.hs --- old/servant-0.9.1.1/test/Servant/API/ContentTypesSpec.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/test/Servant/API/ContentTypesSpec.hs 2017-05-24 09:22:24.000000000 +0200 @@ -11,21 +11,25 @@ import Prelude () import Prelude.Compat -import Data.Aeson +import Data.Aeson.Compat import Data.ByteString.Char8 (ByteString, append, pack) import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either import Data.Function (on) import Data.List (maximumBy) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, isJust, isNothing) import Data.Proxy import Data.String (IsString (..)) import Data.String.Conversions (cs) import qualified Data.Text as TextS +import qualified Data.Text.Encoding as TextSE import qualified Data.Text.Lazy as TextL import GHC.Generics import Test.Hspec import Test.QuickCheck +import Text.Read (readMaybe) import "quickcheck-instances" Test.QuickCheck.Instances () import Servant.API.ContentTypes @@ -101,23 +105,31 @@ "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` isJust + it "returns Just if the 'Accept' header matches, with multiple mime types" $ do + handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int) + `shouldBe` Nothing + it "returns the Content-Type as the first element of the tuple" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust) it "returns the appropriately serialized representation" $ do property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData) - == Just ("application/json", encode x) + == Just ("application/json;charset=utf-8", encode x) it "respects the Accept spec ordering" $ do let highest a b c = maximumBy (compare `on` snd) [ ("application/octet-stream", a) - , ("application/json", b) + , ("application/json;charset=utf-8", b) , ("text/plain;charset=utf-8", c) ] let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $ @@ -158,6 +170,24 @@ (encode val) `shouldBe` Just (Right val) + it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do + let val = 42 :: Int + handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json" + "42" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain" + "42" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" + "42" `shouldBe` (Nothing :: Maybe (Either String Int)) + + it "passes content-type to mimeUnrenderWithType" $ do + let val = "foobar" :: TextS.Text + handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json" + "\"foobar\"" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain" + "foobar" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" + "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) + #if MIN_VERSION_aeson(0,9,0) -- aeson >= 0.9 decodes top-level strings describe "eitherDecodeLenient" $ do @@ -201,6 +231,23 @@ instance IsString AcceptHeader where fromString = AcceptHeader . fromString +-- To test multiple content types +data JSONorText + +instance Accept JSONorText where + contentTypes _ = "text/plain" NE.:| [ "application/json" ] + +instance MimeRender JSONorText Int where + mimeRender _ = cs . show + +instance MimeUnrender JSONorText Int where + mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack + +instance MimeUnrender JSONorText TextS.Text where + mimeUnrenderWithType _ mt + | mt == "application/json" = maybe (Left "") Right . decode + | otherwise = Right . TextSE.decodeUtf8 . BSL.toStrict + addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Servant/Utils/EnterSpec.hs new/servant-0.11/test/Servant/Utils/EnterSpec.hs --- old/servant-0.9.1.1/test/Servant/Utils/EnterSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.11/test/Servant/Utils/EnterSpec.hs 2017-05-24 09:22:24.000000000 +0200 @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Utils.EnterSpec where + +import Test.Hspec (Spec) + +import Servant.API +import Servant.Utils.Enter + +------------------------------------------------------------------------------- +-- https://github.com/haskell-servant/servant/issues/734 +------------------------------------------------------------------------------- + +-- This didn't fail if executed in GHCi; cannot have as a doctest. + +data App a + +f :: App :~> App +f = NT id + +server :: App Int :<|> (String -> App Bool) +server = undefined + +server' :: App Int :<|> (String -> App Bool) +server' = enter f server + +------------------------------------------------------------------------------- +-- Spec +------------------------------------------------------------------------------- + +spec :: Spec +spec = return () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Servant/Utils/LinksSpec.hs new/servant-0.11/test/Servant/Utils/LinksSpec.hs --- old/servant-0.9.1.1/test/Servant/Utils/LinksSpec.hs 2016-10-24 17:04:42.000000000 +0200 +++ new/servant-0.11/test/Servant/Utils/LinksSpec.hs 2017-05-24 09:22:24.000000000 +0200 @@ -7,6 +7,7 @@ import Data.Proxy (Proxy (..)) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) +import Data.String (fromString) import Servant.API @@ -24,6 +25,7 @@ :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] NoContent :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent :<|> "raw" :> Raw + :<|> NoEndpoint apiLink :: (IsElem endpoint TestApi, HasLink endpoint) @@ -32,47 +34,49 @@ -- | Convert a link to a URI and ensure that this maps to the given string -- given string -shouldBeURI :: URI -> String -> Expectation -shouldBeURI link expected = - show link `shouldBe` expected +shouldBeLink :: Link -> String -> Expectation +shouldBeLink link expected = + toUrlPiece link `shouldBe` fromString expected spec :: Spec spec = describe "Servant.Utils.Links" $ do it "generates correct links for capture query params" $ do let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent) - apiLink l1 "hi" `shouldBeURI` "hello/hi" + apiLink l1 "hi" `shouldBeLink` "hello/hi" let l2 = Proxy :: Proxy ("hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent) - apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true" + apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" it "generates correct links for CaptureAll" $ do apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) ["roads", "lead", "to", "rome"] - `shouldBeURI` "all/roads/lead/to/rome" + `shouldBeLink` "all/roads/lead/to/rome" it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent) - apiLink l1 True True `shouldBeURI` "balls?bouncy&fast" - apiLink l1 False True `shouldBeURI` "balls?fast" + apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" + apiLink l1 False True `shouldBeLink` "balls?fast" it "generates correct links for all of the verbs" $ do - apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeURI` "get" - apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeURI` "put" - apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeURI` "post" - apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeURI` "delete" - apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw" + apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" + apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put" + apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post" + apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete" + apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" -- | -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, -- we'll just use doctest -- +-- with TypeError comparing for errors is difficult. +-- -- >>> apiLink (Proxy :: Proxy WrongPath) -- ... --- ...Could not deduce... +-- ......:...:... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongReturnType) @@ -82,7 +86,7 @@ -- -- >>> apiLink (Proxy :: Proxy WrongContentType) -- ... --- ...Could not deduce... +-- ......:...:... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongMethod) @@ -95,12 +99,18 @@ -- ...Could not deduce... -- ... -- +-- >>> apiLink (Proxy :: Proxy NoEndpoint) +-- ... +-- ...No instance for... +-- ... +-- -- sanity check --- >>> apiLink (Proxy :: Proxy AllGood) --- get +-- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood) +-- "get" type WrongPath = "getTypo" :> Get '[JSON] NoContent type WrongReturnType = "get" :> Get '[JSON] Bool type WrongContentType = "get" :> Get '[OctetStream] NoContent type WrongMethod = "get" :> Post '[JSON] NoContent type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool type AllGood = "get" :> Get '[JSON] NoContent +type NoEndpoint = "empty" :> EmptyAPI diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/doctests.hs new/servant-0.11/test/doctests.hs --- old/servant-0.9.1.1/test/doctests.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.11/test/doctests.hs 2017-05-24 09:22:24.000000000 +0200 @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2012-14 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett <ekmett(a)gmail.com> +-- 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 ++++++ servant.cabal ++++++ --- /var/tmp/diff_new_pack.bMNkl4/_old 2017-08-31 20:59:09.676673737 +0200 +++ /var/tmp/diff_new_pack.bMNkl4/_new 2017-08-31 20:59:09.688672052 +0200 @@ -1,5 +1,5 @@ name: servant -version: 0.9.1.1 +version: 0.11 x-revision: 1 synopsis: A family of combinators for defining webservices APIs description: @@ -15,8 +15,8 @@ author: Servant Contributors maintainer: haskell-servant-maintainers(a)googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web -build-type: Simple +category: Servant Web +build-type: Custom cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files: @@ -26,6 +26,12 @@ type: git location: http://github.com/haskell-servant/servant.git +custom-setup + setup-depends: + base >= 4 && <5, + Cabal, + cabal-doctest >= 1.0.2 && <1.1 + library exposed-modules: Servant.API @@ -33,6 +39,7 @@ Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes + Servant.API.Empty Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion @@ -44,27 +51,35 @@ Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub + Servant.API.TypeLevel Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext Servant.Utils.Links Servant.Utils.Enter build-depends: - base >= 4.7 && < 4.10 + base >= 4.7 && < 4.11 , base-compat >= 0.9 && < 0.10 - , aeson >= 0.7 && < 1.2 + , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , http-api-data >= 0.3 && < 0.4 - , http-media >= 0.4 && < 0.7 + , http-media >= 0.4 && < 0.8 , http-types >= 0.8 && < 0.10 + , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 - , mmorph >= 1 && < 1.1 + , mmorph >= 1 && < 1.2 + , tagged >= 0.7.3 && < 0.9 , text >= 1 && < 1.3 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 && < 2.7 , vault >= 0.3 && < 0.4 + + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.16 && < 0.19 + hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP @@ -102,10 +117,12 @@ Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec Servant.Utils.LinksSpec + Servant.Utils.EnterSpec build-depends: base == 4.* , base-compat , aeson + , aeson-compat >=0.3.3 && <0.4 , attoparsec , bytestring , hspec == 2.* @@ -116,6 +133,10 @@ , text , url + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.16 && < 0.19 + test-suite doctests build-depends: base , servant @@ -123,9 +144,14 @@ , filemanip , directory , filepath + , hspec type: exitcode-stdio-1.0 - main-is: test/Doctests.hs + main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded + if impl(ghc >= 8.2) + x-doctest-options: -fdiagnostics-color=never include-dirs: include + x-doctest-source-dirs: test + x-doctest-modules: Servant.Utils.LinksSpec

1 0

commit ghc-semigroups for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-semigroups for openSUSE:Factory checked in at 2017-08-31 20:59:03 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-semigroups (Old) and /work/SRC/openSUSE:Factory/.ghc-semigroups.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-semigroups" Thu Aug 31 20:59:03 2017 rev:10 rq:513481 version:0.18.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-semigroups/ghc-semigroups.changes 2016-10-22 13:20:39.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-semigroups.new/ghc-semigroups.changes 2017-08-31 20:59:04.385417174 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:53 UTC 2017 - psimons(a)suse.com + +- Update to version 0.18.3. + +------------------------------------------------------------------- Old: ---- semigroups-0.18.2.tar.gz New: ---- semigroups-0.18.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-semigroups.spec ++++++ --- /var/tmp/diff_new_pack.R8G0q1/_old 2017-08-31 20:59:05.649239603 +0200 +++ /var/tmp/diff_new_pack.R8G0q1/_new 2017-08-31 20:59:05.657238479 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-semigroups # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,7 +18,7 @@ %global pkg_name semigroups Name: ghc-%{pkg_name} -Version: 0.18.2 +Version: 0.18.3 Release: 0 Summary: Anything that associates License: BSD-3-Clause ++++++ semigroups-0.18.2.tar.gz -> semigroups-0.18.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroups-0.18.2/.travis.yml new/semigroups-0.18.3/.travis.yml --- old/semigroups-0.18.2/.travis.yml 2016-06-23 04:12:10.000000000 +0200 +++ new/semigroups-0.18.3/.travis.yml 2017-04-16 18:47:49.000000000 +0200 @@ -21,21 +21,30 @@ matrix: include: - - env: CABALVER=1.16 GHCVER=7.0.4 + - env: CABALVER=1.18 GHCVER=7.0.4 compiler: ": #GHC 7.0.4" - addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4], sources: [hvr-ghc]}} - - env: CABALVER=1.16 GHCVER=7.4.2 + addons: {apt: {packages: [cabal-install-1.18,ghc-7.0.4], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.2.2 + compiler: ": #GHC 7.2.2" + addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" - addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2], sources: [hvr-ghc]}} - - env: CABALVER=1.16 GHCVER=7.6.3 + addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}} + addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.10.2 - compiler: ": #GHC 7.10.2" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}} + - env: CABALVER=1.22 GHCVER=7.10.3 + compiler: ": #GHC 7.10.3" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=8.0.2 + compiler: ": #GHC 8.0.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} + - env: CABALVER=2.0 GHCVER=8.2.1 + compiler: ": #GHC 8.2.1" + addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}} - env: CABALVER=head GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} @@ -71,9 +80,9 @@ echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install --only-dependencies --enable-tests --enable-benchmarks; + cabal install -j --only-dependencies --enable-tests --enable-benchmarks; fi - + # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroups-0.18.2/CHANGELOG.markdown new/semigroups-0.18.3/CHANGELOG.markdown --- old/semigroups-0.18.2/CHANGELOG.markdown 2016-06-23 04:12:10.000000000 +0200 +++ new/semigroups-0.18.3/CHANGELOG.markdown 2017-04-16 18:47:49.000000000 +0200 @@ -1,3 +1,11 @@ +0.18.3 +------ +* Add `Semigroup` instance for `IO`, as well as for `Event` and `Lifetime` from + `GHC.Event` +* Add `Eq1`, `Ord1`, `Read1`, and `Show1` instances for `NonEmpty` +* Define `Generic` and `Generic1` instances back to GHC 7.2, and expose the + `Data.Semigroup.Generic` module on GHC 7.2 + 0.18.2 ------ * Depend on the `bytestring-builder` package to ensure `Semigroup` instances for bytestring `Builder` and `ShortByteString` are always defined diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroups-0.18.2/semigroups.cabal new/semigroups-0.18.3/semigroups.cabal --- old/semigroups-0.18.2/semigroups.cabal 2016-06-23 04:12:10.000000000 +0200 +++ new/semigroups-0.18.3/semigroups.cabal 2017-04-16 18:47:49.000000000 +0200 @@ -1,6 +1,6 @@ name: semigroups category: Algebra, Data, Data Structures, Math -version: 0.18.2 +version: 0.18.3 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE @@ -50,17 +50,17 @@ flag bytestring-builder description: - You can disable the use of the `bytestring-builder` package using `-f-bytestring-builder`. + Decides whether to use an older version of bytestring along with bytestring-builder or just a newer version of bytestring. . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - default: True + This flag normally toggles automatically but you can use `-fbytestring-builder` or `-f-bytestring-builder` to explicitly change it. + default: False manual: False flag containers description: You can disable the use of the `containers` package using `-f-containers`. . - Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True @@ -68,7 +68,7 @@ description: You can disable the use of the `deepseq` package using `-f-deepseq`. . - Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True @@ -90,7 +90,7 @@ flag transformers description: - You can disable the use of the `transformers` package using `-f-transformers`. + You can disable the use of the `transformers` and `transformers-compat` packages using `-f-transformers`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True @@ -111,7 +111,7 @@ build-depends: base >= 2 && < 5 - if impl(ghc >= 7.4) + if impl(ghc >= 7.2) exposed-modules: Data.Semigroup.Generic @@ -127,7 +127,7 @@ if impl(ghc < 7.10) build-depends: nats >= 0.1 && < 2 - if impl(ghc >= 7.4 && < 7.5) + if impl(ghc >= 7.2 && < 7.5) build-depends: ghc-prim if flag(binary) @@ -159,4 +159,5 @@ build-depends: unordered-containers >= 0.2 && < 0.3 if flag(transformers) - build-depends: transformers >= 0.2 && < 0.6 + build-depends: transformers >= 0.2 && < 0.6 + , transformers-compat >= 0.5 && < 1 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroups-0.18.2/src/Data/Semigroup/Generic.hs new/semigroups-0.18.3/src/Data/Semigroup/Generic.hs --- old/semigroups-0.18.2/src/Data/Semigroup/Generic.hs 2016-06-23 04:12:10.000000000 +0200 +++ new/semigroups-0.18.3/src/Data/Semigroup/Generic.hs 2017-04-16 18:47:49.000000000 +0200 @@ -1,6 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Semigroup.Generic diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroups-0.18.2/src-ghc7/Data/List/NonEmpty.hs new/semigroups-0.18.3/src-ghc7/Data/List/NonEmpty.hs --- old/semigroups-0.18.2/src-ghc7/Data/List/NonEmpty.hs 2016-06-23 04:12:10.000000000 +0200 +++ new/semigroups-0.18.3/src-ghc7/Data/List/NonEmpty.hs 2017-04-16 18:47:49.000000000 +0200 @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -#if defined(MIN_VERSION_hashable) || __GLASGOW_HASKELL__ >= 708 +#if defined(MIN_VERSION_hashable) || __GLASGOW_HASKELL__ == 702 \ + || __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Safe #-} @@ -13,13 +14,12 @@ {-# LANGUAGE DeriveDataTypeable #-} #endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 #define LANGUAGE_DeriveGeneric {-# LANGUAGE DeriveGeneric #-} -#endif - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #endif #ifndef MIN_VERSION_base @@ -136,7 +136,7 @@ #endif #ifdef LANGUAGE_DeriveDataTypeable -import Data.Data +import Data.Data hiding (Infix) #endif #if MIN_VERSION_base(4,8,0) @@ -153,6 +153,10 @@ import Data.Hashable #endif +#ifdef MIN_VERSION_transformers +import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) +#endif + import qualified Data.List as List import Data.Ord (comparing) @@ -198,6 +202,28 @@ toList = toList #endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 NonEmpty where + type Rep1 NonEmpty + = D1 D1NonEmpty + (C1 C1_0NonEmpty + (S1 NoSelector Par1 + :*: S1 NoSelector (Rec1 []))) + from1 (h :| t) = M1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))) + to1 (M1 (M1 (M1 h :*: M1 t))) = unPar1 h :| unRec1 t + +instance Datatype D1NonEmpty where + datatypeName _ = "NonEmpty" + moduleName _ = "Data.List.NonEmpty" + +instance Constructor C1_0NonEmpty where + conName _ = ":|" + conFixity _ = Infix RightAssociative 5 + +data D1NonEmpty +data C1_0NonEmpty +#endif + #ifdef MIN_VERSION_deepseq instance NFData a => NFData (NonEmpty a) where rnf (x :| xs) = rnf x `seq` rnf xs @@ -214,6 +240,44 @@ munzip = unzip #endif +#ifdef MIN_VERSION_transformers +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +instance Eq1 NonEmpty where + liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs + +instance Ord1 NonEmpty where + liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs + +instance Read1 NonEmpty where + liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do + (a, s'') <- rdP 6 s' + (":|", s''') <- lex s'' + (as, s'''') <- rdL s''' + return (a :| as, s'''')) s + +instance Show1 NonEmpty where + liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $ + shwP 6 a . showString " :| " . shwL as +# else +instance Eq1 NonEmpty where + eq1 (a :| as) (b :| bs) = a == b && as == bs + +instance Ord1 NonEmpty where + compare1 (a :| as) (b :| bs) = compare a b `mappend` compare as bs + +instance Read1 NonEmpty where + readsPrec1 p s = readParen (p > 5) (\s' -> do + (a, s'') <- readsPrec 6 s' + (":|", s''') <- lex s'' + (as, s'''') <- readList s''' + return (a :| as, s'''')) s + +instance Show1 NonEmpty where + showsPrec1 p (a :| as) = showParen (p > 5) $ + showsPrec 6 a . showString " :| " . showList as +# endif +#endif + length :: NonEmpty a -> Int length (_ :| xs) = 1 + Prelude.length xs {-# INLINE length #-} @@ -277,6 +341,10 @@ foldl1 f ~(a :| as) = foldl f a as foldMap f ~(a :| as) = f a `mappend` foldMap f as fold ~(m :| ms) = m `mappend` fold ms +#if MIN_VERSION_base(4,8,0) + length = length + toList = toList +#endif -- | Extract the first element of the stream. head :: NonEmpty a -> a @@ -581,7 +649,7 @@ {-# INLINE unzip #-} -- | The 'nub' function removes duplicate elements from a list. In --- particular, it keeps only the first occurence of each element. +-- particular, it keeps only the first occurrence of each element. -- (The name 'nub' means \'essence\'.) -- It is a special case of 'nubBy', which allows the programmer to -- supply their own inequality test. @@ -599,8 +667,8 @@ -- > transpose . transpose /= id transpose :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) transpose = fmap fromList - . fromList . List.transpose . Foldable.toList - . fmap Foldable.toList + . fromList . List.transpose . toList + . fmap toList -- | 'sortBy' for 'NonEmpty', behaves the same as 'Data.List.sortBy' sortBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroups-0.18.2/src-ghc7/Data/Semigroup.hs new/semigroups-0.18.3/src-ghc7/Data/Semigroup.hs --- old/semigroups-0.18.2/src-ghc7/Data/Semigroup.hs 2016-06-23 04:12:10.000000000 +0200 +++ new/semigroups-0.18.3/src-ghc7/Data/Semigroup.hs 2017-04-16 18:47:49.000000000 +0200 @@ -8,18 +8,21 @@ #if __GLASGOW_HASKELL__ >= 702 #define LANGUAGE_DefaultSignatures {-# LANGUAGE DefaultSignatures #-} -#if (defined(MIN_VERSION_hashable)) || __GLASGOW_HASKELL__ >= 708 +#if (defined(MIN_VERSION_hashable)) || __GLASGOW_HASKELL__ == 702 \ + || __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Safe #-} #endif #endif -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 702 #define LANGUAGE_DeriveGeneric {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #endif #if __GLASGOW_HASKELL__ >= 706 @@ -113,6 +116,9 @@ import Control.Monad.Fix import qualified Data.Monoid as Monoid import Data.List.NonEmpty +#if MIN_VERSION_base(4,4,0) && !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) +import GHC.Event +#endif #ifdef MIN_VERSION_deepseq import Control.DeepSeq (NFData(..)) @@ -511,6 +517,28 @@ signum (Min a) = Min (signum a) fromInteger = Min . fromInteger +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 Min where + type Rep1 Min = D1 D1Min (C1 C1_0Min (S1 S1_0_0Min Par1)) + from1 (Min x) = M1 (M1 (M1 (Par1 x))) + to1 (M1 (M1 (M1 x))) = Min (unPar1 x) + +instance Datatype D1Min where + datatypeName _ = "Min" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0Min where + conName _ = "Min" + conIsRecord _ = True + +instance Selector S1_0_0Min where + selName _ = "getMin" + +data D1Min +data C1_0Min +data S1_0_0Min +#endif + newtype Max a = Max { getMax :: a } deriving ( Eq, Ord, Show, Read #ifdef LANGUAGE_DeriveDataTypeable @@ -596,6 +624,27 @@ signum (Max a) = Max (signum a) fromInteger = Max . fromInteger +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 Max where + type Rep1 Max = D1 D1Max (C1 C1_0Max (S1 S1_0_0Max Par1)) + from1 (Max x) = M1 (M1 (M1 (Par1 x))) + to1 (M1 (M1 (M1 x))) = Max (unPar1 x) + +instance Datatype D1Max where + datatypeName _ = "Max" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0Max where + conName _ = "Max" + conIsRecord _ = True + +instance Selector S1_0_0Max where + selName _ = "getMax" + +data D1Max +data C1_0Max +data S1_0_0Max +#endif -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be placed inside 'Min' and 'Max' -- to compute an arg min or arg max. @@ -655,6 +704,27 @@ bimap f g (Arg a b) = Arg (f a) (g b) #endif +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 (Arg a) where + type Rep1 (Arg a) + = D1 D1Arg + (C1 C1_0Arg + (S1 NoSelector (Rec0 a) + :*: S1 NoSelector Par1)) + from1 (Arg a b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) + to1 (M1 (M1 (M1 a :*: M1 b))) = Arg (unK1 a) (unPar1 b) + +instance Datatype D1Arg where + datatypeName _ = "Arg" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0Arg where + conName _ = "Arg" + +data D1Arg +data C1_0Arg +#endif + -- | Use @'Option' ('First' a)@ to get the behavior of 'Data.Monoid.First' from @Data.Monoid@. newtype First a = First { getFirst :: a } deriving ( Eq, Ord, Show, Read @@ -725,6 +795,28 @@ rnf (First a) = rnf a #endif +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 First where + type Rep1 First = D1 D1First (C1 C1_0First (S1 S1_0_0First Par1)) + from1 (First x) = M1 (M1 (M1 (Par1 x))) + to1 (M1 (M1 (M1 x))) = First (unPar1 x) + +instance Datatype D1First where + datatypeName _ = "First" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0First where + conName _ = "First" + conIsRecord _ = True + +instance Selector S1_0_0First where + selName _ = "getFirst" + +data D1First +data C1_0First +data S1_0_0First +#endif + -- | Use @'Option' ('Last' a)@ to get the behavior of 'Data.Monoid.Last' from @Data.Monoid@ newtype Last a = Last { getLast :: a } deriving ( Eq, Ord, Show, Read @@ -795,6 +887,28 @@ rnf (Last a) = rnf a #endif +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 Last where + type Rep1 Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last Par1)) + from1 (Last x) = M1 (M1 (M1 (Par1 x))) + to1 (M1 (M1 (M1 x))) = Last (unPar1 x) + +instance Datatype D1Last where + datatypeName _ = "Last" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0Last where + conName _ = "Last" + conIsRecord _ = True + +instance Selector S1_0_0Last where + selName _ = "getLast" + +data D1Last +data C1_0Last +data S1_0_0Last +#endif + -- (==)/XNOR on Bool forms a 'Semigroup', but has no good name #ifdef MIN_VERSION_binary @@ -897,6 +1011,28 @@ rnf (WrapMonoid a) = rnf a #endif +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 WrappedMonoid where + type Rep1 WrappedMonoid = D1 D1WrappedMonoid (C1 C1_0WrappedMonoid (S1 S1_0_0WrappedMonoid Par1)) + from1 (WrapMonoid x) = M1 (M1 (M1 (Par1 x))) + to1 (M1 (M1 (M1 x))) = WrapMonoid (unPar1 x) + +instance Datatype D1WrappedMonoid where + datatypeName _ = "WrappedMonoid" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0WrappedMonoid where + conName _ = "WrapMonoid" + conIsRecord _ = True + +instance Selector S1_0_0WrappedMonoid where + selName _ = "unwrapMonoid" + +data D1WrappedMonoid +data C1_0WrappedMonoid +data S1_0_0WrappedMonoid +#endif + -- | Repeat a value @n@ times. -- -- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times @@ -999,6 +1135,28 @@ mempty = Option Nothing mappend = (<>) +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 +instance Generic1 Option where + type Rep1 Option = D1 D1Option (C1 C1_0Option (S1 S1_0_0Option (Rec1 Maybe))) + from1 (Option x) = M1 (M1 (M1 (Rec1 x))) + to1 (M1 (M1 (M1 x))) = Option (unRec1 x) + +instance Datatype D1Option where + datatypeName _ = "Option" + moduleName _ = "Data.Semigroup" + +instance Constructor C1_0Option where + conName _ = "Option" + conIsRecord _ = True + +instance Selector S1_0_0Option where + selName _ = "getOption" + +data D1Option +data C1_0Option +data S1_0_0Option +#endif + -- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. diff :: Semigroup m => m -> Endo m diff = Endo . (<>) @@ -1050,3 +1208,20 @@ # endif stimes n (Tagged a) = Tagged (stimes n a) #endif + +instance Semigroup a => Semigroup (IO a) where + (<>) = liftA2 (<>) + +#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) +# if MIN_VERSION_base(4,4,0) +instance Semigroup Event where + (<>) = mappend + stimes = stimesMonoid +# endif + +# if MIN_VERSION_base(4,8,1) +instance Semigroup Lifetime where + (<>) = mappend + stimes = stimesMonoid +# endif +#endif

1 0

commit ghc-semigroupoids for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-semigroupoids for openSUSE:Factory checked in at 2017-08-31 20:59:01 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-semigroupoids (Old) and /work/SRC/openSUSE:Factory/.ghc-semigroupoids.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-semigroupoids" Thu Aug 31 20:59:01 2017 rev:6 rq:513480 version:5.2 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-semigroupoids/ghc-semigroupoids.changes 2016-11-01 09:58:08.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-semigroupoids.new/ghc-semigroupoids.changes 2017-08-31 20:59:02.405695330 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:03:56 UTC 2017 - psimons(a)suse.com + +- Update to version 5.2. + +------------------------------------------------------------------- Old: ---- semigroupoids-5.1.tar.gz New: ---- semigroupoids-5.2.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-semigroupoids.spec ++++++ --- /var/tmp/diff_new_pack.X6JxFR/_old 2017-08-31 20:59:03.393556533 +0200 +++ /var/tmp/diff_new_pack.X6JxFR/_new 2017-08-31 20:59:03.413553724 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-semigroupoids # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name semigroupoids %bcond_with tests Name: ghc-%{pkg_name} -Version: 5.1 +Version: 5.2 Release: 0 Summary: Semigroupoids: Category sans id License: BSD-2-Clause @@ -29,6 +29,7 @@ BuildRequires: ghc-Cabal-devel BuildRequires: ghc-base-orphans-devel BuildRequires: ghc-bifunctors-devel +BuildRequires: ghc-cabal-doctest-devel BuildRequires: ghc-comonad-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-contravariant-devel @@ -40,9 +41,7 @@ BuildRequires: ghc-transformers-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} -BuildRequires: ghc-directory-devel BuildRequires: ghc-doctest-devel -BuildRequires: ghc-filepath-devel %endif %description ++++++ semigroupoids-5.1.tar.gz -> semigroupoids-5.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/.ghci new/semigroupoids-5.2/.ghci --- old/semigroupoids-5.1/.ghci 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/.ghci 1970-01-01 01:00:00.000000000 +0100 @@ -1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/.travis.yml new/semigroupoids-5.2/.travis.yml --- old/semigroupoids-5.1/.travis.yml 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/.travis.yml 2017-04-19 17:14:28.000000000 +0200 @@ -13,26 +13,37 @@ matrix: include: - - env: CABALVER=1.18 GHCVER=7.4.2 + - env: CABALVER=1.24 GHCVER=7.0.4 + compiler: ": #GHC 7.0.4" + addons: {apt: {packages: [cabal-install-1.24,ghc-7.0.4], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=7.2.2 + compiler: ": #GHC 7.2.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-7.2.2], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.6.3 + addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.8.4 + addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.10.3 + addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=8.0.1 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} + addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=8.0.2 + compiler: ": #GHC 8.0.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=8.2.1 + compiler: ": #GHC 8.2.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-1.24,ghc-head], sources: [hvr-ghc]}} allow_failures: + - env: CABALVER=1.24 GHCVER=7.0.4 + - env: CABALVER=1.24 GHCVER=7.2.2 - env: CABALVER=1.24 GHCVER=head before_install: @@ -64,7 +75,6 @@ rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j --only-dependencies --enable-tests; - if [ "$GHCVER" = "7.10.3" ]; then cabal install Cabal-1.22.4.0; fi; fi # snapshot package-db on cache miss diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/CHANGELOG.markdown new/semigroupoids-5.2/CHANGELOG.markdown --- old/semigroupoids-5.1/CHANGELOG.markdown 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/CHANGELOG.markdown 2017-04-19 17:14:28.000000000 +0200 @@ -1,3 +1,10 @@ +5.2 +--- +* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build + with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and + sandboxes. +* Added instances to `Alt`, `Plus`, `Apply`, `Bind` and `Extend` for `GHC.Generics`, `Tagged` and `Proxy` where appropriate. + 5.1 --- * The remaining orphan instances in `Data.Traversable.Instances` have been replaced in favor of the orphan instances from `transformers-compat-0.5`. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/Setup.lhs new/semigroupoids-5.2/Setup.lhs --- old/semigroupoids-5.1/Setup.lhs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/Setup.lhs 2017-04-19 17:14:28.000000000 +0200 @@ -1,50 +1,182 @@ -#!/usr/bin/runhaskell \begin{code} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + + +#if MIN_VERSION_cabal_doctest(1,0,0) +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +#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.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Data.String ( fromString ) +import Distribution.Package ( InstalledPackageId ) +import Distribution.Package ( PackageId, Package (..), packageVersion ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..)) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) 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 - , postHaddock = \args flags pkg lbi -> do - postHaddock simpleUserHooks args flags pkg lbi - } +#if MIN_VERSION_Cabal(1,25,0) +import Distribution.Simple.BuildPaths ( autogenComponentModulesDir ) +#endif + +#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 -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" + -- 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 +defaultMainWithDoctests :: String -> IO () +defaultMainWithDoctests testSuiteName = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule testSuiteName flags pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +#endif + +main :: IO () +main = defaultMainWithDoctests "doctests" + \end{code} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/semigroupoids.cabal new/semigroupoids-5.2/semigroupoids.cabal --- old/semigroupoids-5.1/semigroupoids.cabal 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/semigroupoids.cabal 2017-04-19 17:14:28.000000000 +0200 @@ -1,6 +1,6 @@ name: semigroupoids category: Control, Comonads -version: 5.1 +version: 5.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -10,11 +10,10 @@ homepage: http://github.com/ekmett/semigroupoids bug-reports: http://github.com/ekmett/semigroupoids/issues copyright: Copyright (C) 2011-2015 Edward A. Kmett +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 build-type: Custom -tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 synopsis: Semigroupoids: Category sans id extra-source-files: - .ghci .travis.yml .gitignore .vim.custom @@ -57,6 +56,12 @@ type: git location: git://github.com/ekmett/semigroupoids.git +custom-setup + setup-depends: + base >= 4 && < 5, + Cabal, + cabal-doctest >= 1 && < 1.1 + flag containers description: You can disable the use of the `containers` package using `-f-containers`. @@ -114,13 +119,19 @@ library build-depends: - base >= 4 && < 5, - base-orphans >= 0.3 && < 1, + base >= 4.3 && < 5, + base-orphans >= 0.5.4 && < 1, bifunctors >= 5 && < 6, semigroups >= 0.8.3.1 && < 1, transformers >= 0.2 && < 0.6, transformers-compat >= 0.5 && < 0.6 + if impl(ghc >= 7.0 && < 7.4) + build-depends: generic-deriving >= 1.11 && < 1.12 + + if impl(ghc >= 7.4 && < 7.6) + build-depends: ghc-prim + if flag(containers) build-depends: containers >= 0.3 && < 0.6 @@ -173,8 +184,5 @@ buildable: False else build-depends: - base >= 4 && < 5, - doctest >= 0.9.1 && < 0.12, - directory >= 1.0, - filepath - + base >= 4 && < 5, + doctest >= 0.11.1 && < 0.12 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Functor/Alt.hs new/semigroupoids-5.2/src/Data/Functor/Alt.hs --- old/semigroupoids-5.1/src/Data/Functor/Alt.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Functor/Alt.hs 2017-04-19 17:14:28.000000000 +0200 @@ -1,12 +1,16 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) +#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE ConstrainedClassMethods #-} #endif +{-# options_ghc -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Alt @@ -48,7 +52,8 @@ import Data.Functor.Reverse import Data.Semigroup hiding (Product) import Data.List.NonEmpty (NonEmpty(..)) -import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either) +import Prelude (($),Either(..),Maybe(..),const,IO,Ord,(++),(.),either,seq,undefined) +import Unsafe.Coerce #ifdef MIN_VERSION_containers import qualified Data.IntMap as IntMap @@ -58,6 +63,16 @@ import Data.Map (Map) #endif +#if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) +import Data.Proxy +#endif + +#ifdef MIN_VERSION_generic_deriving +import Generics.Deriving.Base +#else +import GHC.Generics +#endif + infixl 3 <!> -- | Laws: @@ -102,6 +117,37 @@ where many_v = some_v <!> pure [] some_v = (:) <$> v <*> many_v +instance (Alt f, Alt g) => Alt (f :*: g) where + (as :*: bs) <!> (cs :*: ds) = (as <!> cs) :*: (bs <!> ds) + +newtype Magic f = Magic { runMagic :: forall a. Applicative f => f a -> f [a] } + +instance Alt f => Alt (M1 i c f) where + M1 f <!> M1 g = M1 (f <!> g) + some = runMagic (unsafeCoerce (Magic some :: Magic f)) + many = runMagic (unsafeCoerce (Magic many :: Magic f)) + +instance Alt f => Alt (Rec1 f) where + Rec1 f <!> Rec1 g = Rec1 (f <!> g) + some = runMagic (unsafeCoerce (Magic some :: Magic f)) + many = runMagic (unsafeCoerce (Magic many :: Magic f)) + +instance Alt U1 where + _ <!> _ = U1 + some _ = U1 + many _ = U1 + +instance Alt V1 where + v <!> u = v `seq` u `seq` undefined + some v = v `seq` undefined + many v = v `seq` undefined + +#if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) +instance Alt Proxy where + _ <!> _ = Proxy + some _ = Proxy + many _ = Proxy +#endif instance Alt (Either a) where Left _ <!> b = b diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Functor/Bind/Class.hs new/semigroupoids-5.2/src/Data/Functor/Bind/Class.hs --- old/semigroupoids-5.1/src/Data/Functor/Bind/Class.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Functor/Bind/Class.hs 2017-04-19 17:14:28.000000000 +0200 @@ -44,16 +44,12 @@ ) where import Data.Semigroup -import Data.Tagged import Control.Applicative import Control.Applicative.Backwards import Control.Applicative.Lift import Control.Arrow import Control.Category import Control.Monad (ap) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 -import Control.Monad.Instances () -#endif import Control.Monad.Trans.Cont import Control.Monad.Trans.Error import Control.Monad.Trans.Except @@ -83,6 +79,7 @@ import Data.Functor.Reverse import Data.Functor.Extend import Data.List.NonEmpty +import Data.Orphans () import Prelude hiding (id, (.)) #ifdef MIN_VERSION_containers @@ -94,6 +91,15 @@ import Data.Tree (Tree) #endif +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) +import Data.Proxy +#endif + + #ifdef MIN_VERSION_comonad import Control.Comonad import Control.Comonad.Trans.Env @@ -138,6 +144,20 @@ (<.) :: f a -> f b -> f a a <. b = const <$> a <.> b +#ifdef MIN_VERSION_tagged +instance Apply (Tagged a) where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) +#endif + +#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) +instance Apply Proxy where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) +#endif + instance Apply f => Apply (Backwards f) where Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f) @@ -415,6 +435,18 @@ instance Semigroup m => Bind ((,)m) where ~(m, a) >>- f = let (n, b) = f a in (m <> n, b) +#ifdef MIN_VERSION_tagged +instance Bind (Tagged a) where + Tagged a >>- f = f a + join (Tagged a) = a +#endif + +#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) +instance Bind Proxy where + _ >>- _ = Proxy + join _ = Proxy +#endif + instance Bind (Either a) where Left a >>- _ = Left a Right a >>- f = f a @@ -579,9 +611,11 @@ Const f <<.>> Const x = Const (f x) {-# INLINE (<<.>>) #-} +#ifdef MIN_VERSION_tagged instance Biapply Tagged where Tagged f <<.>> Tagged x = Tagged (f x) {-# INLINE (<<.>>) #-} +#endif instance (Biapply p, Apply f, Apply g) => Biapply (Biff p f g) where Biff fg <<.>> Biff xy = Biff (bimap (<.>) (<.>) fg <<.>> xy) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Functor/Bind/Trans.hs new/semigroupoids-5.2/src/Data/Functor/Bind/Trans.hs --- old/semigroupoids-5.1/src/Data/Functor/Bind/Trans.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Functor/Bind/Trans.hs 2017-04-19 17:14:28.000000000 +0200 @@ -16,9 +16,6 @@ -- import _everything_ import Control.Category -#if __GLASGOW_HASKELL__ < 707 -import Control.Monad.Instances () -#endif import Control.Monad.Trans.Class import Control.Monad.Trans.Cont -- import Control.Monad.Trans.Error @@ -33,6 +30,7 @@ import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Bind +import Data.Orphans () import Data.Semigroup hiding (Product) import Prelude hiding (id, (.)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Functor/Extend.hs new/semigroupoids-5.2/src/Data/Functor/Extend.hs --- old/semigroupoids-5.1/src/Data/Functor/Extend.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Functor/Extend.hs 2017-04-19 17:14:28.000000000 +0200 @@ -42,6 +42,15 @@ import Control.Comonad.Trans.Traced #endif +#ifdef MIN_VERSION_tagged +import Data.Tagged +#endif + +#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) +import Data.Proxy +#endif + + class Functor w => Extend w where -- | -- > duplicated = extended id @@ -72,6 +81,17 @@ instance Extend [] where duplicated = init . tails +#ifdef MIN_VERSION_tagged +instance Extend (Tagged a) where + duplicated = Tagged +#endif + +#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0) +instance Extend Proxy where + duplicated _ = Proxy + extended _ _ = Proxy +#endif + instance Extend Maybe where duplicated Nothing = Nothing duplicated j = Just j diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Functor/Plus.hs new/semigroupoids-5.2/src/Data/Functor/Plus.hs --- old/semigroupoids-5.1/src/Data/Functor/Plus.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Functor/Plus.hs 2017-04-19 17:14:28.000000000 +0200 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL <= 706 && defined(MIN_VERSION_comonad) && !(MIN_VERSION_comonad(3,0,3)) {-# LANGUAGE Trustworthy #-} @@ -54,6 +55,16 @@ import Data.Map (Map) #endif +#if defined(MIN_VERSION_tagged) || (MIN_VERSION_base(4,7,0)) +import Data.Proxy +#endif + +#ifdef MIN_VERSION_generic_deriving +import Generics.Deriving.Base +#else +import GHC.Generics +#endif + -- | Laws: -- -- > zero <!> m = m @@ -64,6 +75,21 @@ class Alt f => Plus f where zero :: f a +instance Plus Proxy where + zero = Proxy + +instance Plus U1 where + zero = U1 + +instance (Plus f, Plus g) => Plus (f :*: g) where + zero = zero :*: zero + +instance Plus f => Plus (M1 i c f) where + zero = M1 zero + +instance Plus f => Plus (Rec1 f) where + zero = Rec1 zero + instance Plus IO where zero = error "zero" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Semigroup/Foldable/Class.hs new/semigroupoids-5.2/src/Data/Semigroup/Foldable/Class.hs --- old/semigroupoids-5.1/src/Data/Semigroup/Foldable/Class.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Semigroup/Foldable/Class.hs 2017-04-19 17:14:28.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TypeOperators #-} #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0 @@ -40,7 +40,11 @@ import Data.Functor.Reverse import Data.Functor.Sum import Data.List.NonEmpty (NonEmpty(..)) + +#ifdef MIN_VERSION_tagged import Data.Tagged +#endif + import Data.Traversable.Instances () #ifdef MIN_VERSION_containers @@ -48,6 +52,13 @@ #endif import Data.Semigroup hiding (Product, Sum) + +#ifdef MIN_VERSION_generic_deriving +import Generics.Deriving.Base +#else +import GHC.Generics +#endif + import Prelude hiding (foldr) class Foldable t => Foldable1 t where @@ -57,6 +68,28 @@ foldMap1 f = maybe (error "foldMap1") id . getOption . foldMap (Option . Just . f) fold1 = foldMap1 id +instance Foldable1 f => Foldable1 (Rec1 f) where + foldMap1 f (Rec1 as) = foldMap1 f as + +instance Foldable1 f => Foldable1 (M1 i c f) where + foldMap1 f (M1 as) = foldMap1 f as + +instance Foldable1 Par1 where + foldMap1 f (Par1 a) = f a + +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where + foldMap1 f (as :*: bs) = foldMap1 f as <> foldMap1 f bs + +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where + foldMap1 f (L1 as) = foldMap1 f as + foldMap1 f (R1 bs) = foldMap1 f bs + +instance Foldable1 V1 where + foldMap1 _ v = v `seq` undefined + +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where + foldMap1 f (Comp1 m) = foldMap1 (foldMap1 f) m + class Bifoldable t => Bifoldable1 t where bifold1 :: Semigroup m => t m m -> m bifold1 = bifoldMap1 id id @@ -96,9 +129,11 @@ bifoldMap1 f _ (Const a) = f a {-# INLINE bifoldMap1 #-} +#ifdef MIN_VERSION_tagged instance Bifoldable1 Tagged where bifoldMap1 _ g (Tagged b) = g b {-# INLINE bifoldMap1 #-} +#endif instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff @@ -141,6 +176,11 @@ instance Foldable1 Identity where foldMap1 f = f . runIdentity +#ifdef MIN_VERSION_tagged +instance Foldable1 (Tagged a) where + foldMap1 f (Tagged a) = f a +#endif + instance Foldable1 m => Foldable1 (IdentityT m) where foldMap1 f = foldMap1 f . runIdentityT diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Semigroup/Traversable/Class.hs new/semigroupoids-5.2/src/Data/Semigroup/Traversable/Class.hs --- old/semigroupoids-5.1/src/Data/Semigroup/Traversable/Class.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Semigroup/Traversable/Class.hs 2017-04-19 17:14:28.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett @@ -39,7 +39,9 @@ import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Bifoldable +#ifdef MIN_VERSION_tagged import Data.Tagged +#endif #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #endif @@ -49,6 +51,12 @@ import Data.Tree #endif +#ifdef MIN_VERSION_generic_deriving +import Generics.Deriving.Base +#else +import GHC.Generics +#endif + class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) bitraverse1 f g = bisequence1 . bimap f g @@ -92,9 +100,11 @@ bitraverse1 f _ (Const a) = Const <$> f a {-# INLINE bitraverse1 #-} +#ifdef MIN_VERSION_tagged instance Bitraversable1 Tagged where bitraverse1 _ g (Tagged b) = Tagged <$> g b {-# INLINE bitraverse1 #-} +#endif instance (Bitraversable1 p, Traversable1 f, Traversable1 g) => Bitraversable1 (Biff p f g) where bitraverse1 f g = fmap Biff . bitraverse1 (traverse1 f) (traverse1 g) . runBiff @@ -130,6 +140,7 @@ bitraverse1 f g = fmap WrapBifunctor . bitraverse1 f g . unwrapBifunctor {-# INLINE bitraverse1 #-} + class (Foldable1 t, Traversable t) => Traversable1 t where traverse1 :: Apply f => (a -> f b) -> t a -> f (t b) sequence1 :: Apply f => t (f b) -> f (t b) @@ -141,6 +152,28 @@ {-# MINIMAL traverse1 | sequence1 #-} #endif +instance Traversable1 f => Traversable1 (Rec1 f) where + traverse1 f (Rec1 as) = Rec1 <$> traverse1 f as + +instance Traversable1 f => Traversable1 (M1 i c f) where + traverse1 f (M1 as) = M1 <$> traverse1 f as + +instance Traversable1 Par1 where + traverse1 f (Par1 a) = Par1 <$> f a + +instance Traversable1 V1 where + traverse1 _ v = v `seq` undefined + +instance (Traversable1 f, Traversable1 g) => Traversable1 (f :*: g) where + traverse1 f (as :*: bs) = (:*:) <$> traverse1 f as <.> traverse1 f bs + +instance (Traversable1 f, Traversable1 g) => Traversable1 (f :+: g) where + traverse1 f (L1 as) = L1 <$> traverse1 f as + traverse1 f (R1 bs) = R1 <$> traverse1 f bs + +instance (Traversable1 f, Traversable1 g) => Traversable1 (f :.: g) where + traverse1 f (Comp1 m) = Comp1 <$> traverse1 (traverse1 f) m + instance Traversable1 Identity where traverse1 f = fmap Identity . f . runIdentity @@ -167,6 +200,11 @@ traverse1 f (Functor.InL x) = Functor.InL <$> traverse1 f x traverse1 f (Functor.InR y) = Functor.InR <$> traverse1 f y +#ifdef MIN_VERSION_tagged +instance Traversable1 (Tagged a) where + traverse1 f (Tagged a) = Tagged <$> f a +#endif + #ifdef MIN_VERSION_containers instance Traversable1 Tree where traverse1 f (Node a []) = (`Node`[]) <$> f a diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/src/Data/Semigroupoid/Static.hs new/semigroupoids-5.2/src/Data/Semigroupoid/Static.hs --- old/semigroupoids-5.1/src/Data/Semigroupoid/Static.hs 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/src/Data/Semigroupoid/Static.hs 2017-04-19 17:14:28.000000000 +0200 @@ -22,13 +22,11 @@ import Control.Arrow import Control.Applicative import Control.Category -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 -import Control.Monad.Instances () -#endif import Control.Monad (ap) import Data.Functor.Apply import Data.Functor.Plus import Data.Functor.Extend +import Data.Orphans () import Data.Semigroup import Data.Semigroupoid import Prelude hiding ((.), id) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/test/doctests.hs new/semigroupoids-5.2/test/doctests.hs --- old/semigroupoids-5.1/test/doctests.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/semigroupoids-5.2/test/doctests.hs 2017-04-19 17:14:28.000000000 +0200 @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2012-14 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett <ekmett(a)gmail.com> +-- 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/semigroupoids-5.1/test/doctests.hsc new/semigroupoids-5.2/test/doctests.hsc --- old/semigroupoids-5.1/test/doctests.hsc 2016-06-16 01:25:50.000000000 +0200 +++ new/semigroupoids-5.2/test/doctests.hsc 1970-01-01 01:00:00.000000000 +0100 @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett(a)gmail.com> --- 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 (autogen_dir, deps) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -##if defined(mingw32_HOST_OS) -##if defined(i386_HOST_ARCH) -##define USE_CP -import Control.Applicative -import Control.Exception -import Foreign.C.Types -foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool -foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##elif defined(x86_64_HOST_ARCH) -##define USE_CP -import Control.Applicative -import Control.Exception -import Foreign.C.Types -foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool -foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##endif -##endif - --- | Run in a modified codepage where we can print UTF-8 values on Windows. -withUnicode :: IO a -> IO a -##ifdef USE_CP -withUnicode m = do - cp <- c_GetConsoleCP - (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp -##else -withUnicode m = m -##endif - -main :: IO () -main = withUnicode $ 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

1 0