diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Unreleased next version +# 0.1.1.0 + +- Add tests to prevent accidental API changes in Redis (thanks @stoeffel / #82) + # 0.1.0.0 - Initial release. diff --git a/nri-test-encoding.cabal b/nri-test-encoding.cabal --- a/nri-test-encoding.cabal +++ b/nri-test-encoding.cabal @@ -1,15 +1,15 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack name: nri-test-encoding -version: 0.1.0.0 +version: 0.1.1.0 synopsis: A library to simplify writing golden tests for encoding types. -description: Please see the README at . +description: Please see the README at . category: Testing -homepage: https://github.com/NoRedInk/haskell-libraries#readme +homepage: https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-test-encoding#readme bug-reports: https://github.com/NoRedInk/haskell-libraries/issues author: NoRedInk maintainer: haskell-open-source@noredink.com @@ -32,11 +32,25 @@ Examples Test.Encoding Test.Encoding.Routes + Redis.Test other-modules: Paths_nri_test_encoding hs-source-dirs: src - default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators + default-extensions: + DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + ScopedTypeVariables + Strict + TypeOperators ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns build-depends: aeson >=1.4.6.0 && <1.6 @@ -45,6 +59,7 @@ , bytestring >=0.10.8.2 && <0.12 , filepath >=1.4.2.1 && <1.5 , nri-prelude >=0.1.0.0 && <0.7 + , nri-redis >=0.1.0.0 && <0.2 , servant >=0.16.2 && <0.19 , servant-auth-server >=0.4.5.1 && <0.5 , servant-server >=0.16.2 && <0.19 diff --git a/src/Examples.hs b/src/Examples.hs --- a/src/Examples.hs +++ b/src/Examples.hs @@ -96,3 +96,6 @@ instance HasExamples () where examples _ = example "unit" () + +instance HasExamples Text where + examples _ = example "text" ("" :: Text) diff --git a/src/Redis/Test.hs b/src/Redis/Test.hs new file mode 100644 --- /dev/null +++ b/src/Redis/Test.hs @@ -0,0 +1,29 @@ +-- | Useful to test encoding of data stored in redis. +module Redis.Test (encoding) where + +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Typeable as Typeable +import qualified Examples +import NriPrelude +import Test (Test) +import qualified Test.Encoding +import qualified Text + +-- | Turns a Redis.Api into a test. +-- The test does the following: +-- +-- 1. get examples from the `HasExamples` constraint +-- 2. encoded the examples into JSON +-- 3. check the encoded JSON against the generated file +-- NOTE: it will generate the file if it doesn't exist yet +encoding :: forall m key a. (Typeable.Typeable a, Examples.HasExamples a) => m key a -> Test +encoding _ = + let proxy = Proxy :: Proxy a + tyCon = + Typeable.typeRep proxy + |> Typeable.typeRepTyCon + typeName = + Typeable.tyConModule tyCon ++ "." ++ Typeable.tyConName tyCon + |> Text.fromList + in Examples.examples proxy + |> Test.Encoding.examplesToTest typeName ("redis-encoding-" ++ typeName) diff --git a/src/Test/Encoding/Routes.hs b/src/Test/Encoding/Routes.hs --- a/src/Test/Encoding/Routes.hs +++ b/src/Test/Encoding/Routes.hs @@ -12,7 +12,9 @@ -- have comitted to the repo. module Test.Encoding.Routes (tests, IsApi (..)) where +import qualified Data.List.NonEmpty as NonEmpty import Data.Proxy (Proxy (Proxy)) +import qualified Data.Semigroup import qualified Data.Typeable as Typeable import qualified Debug import qualified Examples @@ -21,7 +23,17 @@ import qualified List import NriPrelude import qualified Servant -import Servant.API (Capture', QueryFlag, Raw, ReqBody, Verb, (:<|>), (:>)) +import Servant.API + ( Capture', + Header, + QueryFlag, + Raw, + ReqBody', + Summary, + Verb, + (:<|>), + (:>), + ) import Servant.API.Generic (ToServantApi) import qualified Servant.Auth.Server import Test (Test, describe, test) @@ -55,6 +67,7 @@ data Route = Route { path :: [Text], method :: Text, + headers :: [(Text, SomeType)], requestBody :: Maybe SomeType, responseBody :: SomeType } @@ -66,13 +79,21 @@ routesWithExamples routes = routes |> List.map - ( \route@Route {requestBody, responseBody} -> + ( \route@Route {requestBody, responseBody, headers} -> ( route, case (requestBody, responseBody) of - (Nothing, SomeType t) -> Examples.examples t - (Just (SomeType s), SomeType t) -> Examples.examples s ++ Examples.examples t + (Nothing, SomeType t) -> + List.map headersToExamples headers + |> (NonEmpty.:|) (Examples.examples t) + |> Data.Semigroup.sconcat + (Just (SomeType s), SomeType t) -> + List.map headersToExamples headers + |> (NonEmpty.:|) (Examples.examples s ++ Examples.examples t) + |> Data.Semigroup.sconcat ) ) + where + headersToExamples (_, SomeType t) = Examples.examples t routeName :: Route -> Text routeName route = @@ -87,33 +108,43 @@ routes |> List.concatMap ( \route -> - case requestBody route of - Nothing -> - [ Text.join - " " - [ routeName route, - "response", - printType (responseBody route) - ] - ] - Just body -> - [ Text.join - " " - [ routeName route, - "response", - printType (responseBody route) - ], - Text.join - " " - [ routeName route, - "request", - printType body - ] - ] + [ case headers route of + [] -> Nothing + headers' -> + Just + <| Text.join + " " + ( routeName route : + "headers" : + List.map printHeaders headers' + ), + Just + <| Text.join + " " + [ routeName route, + "response", + printType (responseBody route) + ], + case requestBody route of + Nothing -> Nothing + Just body -> + Just + <| Text.join + " " + [ routeName route, + "request", + printType body + ] + ] ) + |> List.filterMap identity |> List.sort |> Text.join "\n" +printHeaders :: (Text, SomeType) -> Text +printHeaders (key, val) = + "(" ++ key ++ ", " ++ printType val ++ ")" + printType :: SomeType -> Text printType (SomeType t) = Typeable.typeRep t @@ -156,16 +187,6 @@ } ) -instance (Typeable.Typeable body, Examples.HasExamples body, IsApi a) => IsApi (ReqBody encodings body :> a) where - crawl _ = - crawl (Proxy :: Proxy a) - |> List.map - ( \route -> - route - { requestBody = Just (SomeType (Proxy :: Proxy body)) - } - ) - instance (Typeable.Typeable method, Typeable.Typeable body, Examples.HasExamples body) => IsApi (Verb method status encodings body) @@ -173,6 +194,7 @@ crawl _ = [ Route { path = [], + headers = [], requestBody = Nothing, method = Typeable.typeRep (Proxy :: Proxy method) @@ -188,6 +210,40 @@ crawl _ = [] instance (IsApi a) => IsApi (QueryFlag flag :> a) where + crawl _ = crawl (Proxy :: Proxy a) + +instance (Typeable.Typeable body, Examples.HasExamples body, IsApi a) => IsApi (ReqBody' x encodings body :> a) where + crawl _ = + crawl (Proxy :: Proxy a) + |> List.map + ( \route -> + route + { requestBody = Just (SomeType (Proxy :: Proxy body)) + } + ) + +instance + ( KnownSymbol key, + Typeable.Typeable val, + Examples.HasExamples val, + IsApi a + ) => + IsApi (Header key val :> a) + where + crawl _ = + crawl (Proxy :: Proxy a) + |> List.map + ( \route -> + route + { headers = + ( Text.fromList (symbolVal (Proxy :: Proxy key)), + SomeType (Proxy :: Proxy val) + ) : + headers route + } + ) + +instance (IsApi a) => IsApi (Summary x :> a) where crawl _ = crawl (Proxy :: Proxy a) instance Examples.HasExamples Servant.NoContent where