icepeak 0.7.4.0 → 1.0.0.0
raw patch · 13 files changed
+278/−273 lines, 13 filesdep ~QuickCheckdep ~aesondep ~base
Dependency ranges changed: QuickCheck, aeson, base, hspec, hspec-core, hspec-expectations, hspec-wai, jwt, optparse-applicative, prometheus-client, quickcheck-instances, random
Files
- app/Icepeak/Main.hs +0/−1
- app/IcepeakTokenGen/Main.hs +1/−2
- icepeak.cabal +207/−212
- src/Config.hs +7/−5
- src/JwtAuth.hs +3/−3
- src/JwtMiddleware.hs +3/−4
- src/MetricsServer.hs +0/−1
- src/Server.hs +0/−1
- src/Store.hs +28/−7
- src/Subscription.hs +0/−1
- tests/JwtSpec.hs +8/−6
- tests/OrphanInstances.hs +0/−9
- tests/StoreSpec.hs +21/−21
app/Icepeak/Main.hs view
@@ -5,7 +5,6 @@ import Control.Exception (fromException, catch, handle, AsyncException, SomeException) import Control.Monad (forM, void, when) import Data.Foldable (forM_)-import Data.Semigroup ((<>)) import Options.Applicative (execParser) import System.Environment (getEnvironment) import System.IO (BufferMode (..), hSetBuffering, stdout)
app/IcepeakTokenGen/Main.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Data.Semigroup ((<>)) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Options.Applicative@@ -13,7 +12,7 @@ import JwtAuth data Config = Config- { configJwtSecret :: Maybe JWT.Signer+ { configJwtSecret :: Maybe JWT.EncodeSigner , configExpiresSeconds :: Maybe Integer , configWhitelist :: [AuthPath] }
icepeak.cabal view
@@ -1,222 +1,217 @@ cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.34.2.------ see: https://github.com/sol/hpack+name: icepeak+version: 1.0.0.0+license: BSD3+copyright: (c) 2022, Channable+maintainer: rkrzr+author: Channable+homepage: https://github.com/channable/icepeak+bug-reports: https://github.com/channable/icepeak/issues+synopsis: A fast JSON document store with push notification support.+description:+ Icepeak is a fast JSON document store with push notification support. -name: icepeak-version: 0.7.4.0-synopsis: A fast JSON document store with push notification support.-description: Icepeak is a fast JSON document store with push notification support.-category: web-homepage: https://github.com/channable/icepeak-bug-reports: https://github.com/channable/icepeak/issues-author: Channable-maintainer: rkrzr-copyright: (c) 2020, Channable-license: BSD3-build-type: Simple+category: web+build-type: Simple library- exposed-modules:- AccessControl- Config- Core- HTTPMethodInvalid- HttpServer- JwtAuth- JwtMiddleware- Logger- Metrics- MetricsServer- Persistence- SentryLogging- Server- Store- Subscription- WebsocketServer- other-modules:- Paths_icepeak- hs-source-dirs:- src- ghc-options: -Wall -Wno-orphans -Wno-unused-top-binds -O2 -fno-ignore-asserts -funbox-strict-fields- build-depends:- aeson >=1.4.6 && <1.6- , async >=2.2.2 && <2.3- , base >=4.12.0 && <4.15- , bytestring >=0.10.8 && <0.11- , containers >=0.6.0 && <0.7- , directory >=1.3.3 && <1.4- , hashable >=1.2.0 && <1.4- , http-types >=0.12.3 && <0.13- , jwt >=0.10.0 && <0.11- , monad-logger >=0.3.31 && <0.4- , mtl >=2.2.2 && <2.3- , network >=2.8.0 && <3.2- , optparse-applicative >=0.14.0 && <0.16- , prometheus-client >=1.0.0 && <1.1- , prometheus-metrics-ghc >=1.0.0 && <1.1- , random >=1.1 && <1.2- , raven-haskell >=0.1.2 && <0.2- , scotty >=0.11.5 && <0.13- , securemem >=0.1.10 && <0.2- , sqlite-simple >=0.4.16 && <0.5- , stm >=2.5.0 && <2.6- , text >=1.2.3 && <1.3- , time >=1.8.0 && <1.10- , unix >=2.7.2 && <2.8- , unordered-containers >=0.2.10 && <0.3- , uuid >=1.3.13 && <1.4- , wai >=3.2.2 && <3.3- , wai-extra >=3.0.29 && <3.2- , wai-middleware-prometheus >=1.0.0 && <1.1- , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.0 && <3.4- , websockets >=0.12.7 && <0.13- default-language: Haskell2010+ exposed-modules:+ AccessControl+ Config+ Core+ HTTPMethodInvalid+ HttpServer+ JwtAuth+ JwtMiddleware+ Logger+ Metrics+ MetricsServer+ Persistence+ SentryLogging+ Server+ Store+ Subscription+ WebsocketServer + hs-source-dirs: src+ other-modules: Paths_icepeak+ default-language: Haskell2010+ ghc-options:+ -Wall -Wno-orphans -Wno-unused-top-binds -O2 -fno-ignore-asserts+ -funbox-strict-fields++ build-depends:+ aeson >=1.4.6 && <2.1,+ async >=2.2.2 && <2.3,+ base >=4.15.0 && <4.16,+ bytestring >=0.10.8 && <0.11,+ containers >=0.6.0 && <0.7,+ directory >=1.3.3 && <1.4,+ hashable >=1.2.0 && <1.4,+ http-types >=0.12.3 && <0.13,+ jwt >=0.10.0 && <0.12,+ monad-logger >=0.3.31 && <0.4,+ mtl >=2.2.2 && <2.3,+ network >=2.8.0 && <3.2,+ optparse-applicative >=0.16.0 && <0.17,+ prometheus-client >=1.0.0 && <1.2,+ prometheus-metrics-ghc >=1.0.0 && <1.1,+ random >=1.1 && <1.3,+ raven-haskell >=0.1.2 && <0.2,+ scotty >=0.11.5 && <0.13,+ securemem >=0.1.10 && <0.2,+ sqlite-simple >=0.4.16 && <0.5,+ stm >=2.5.0 && <2.6,+ text >=1.2.3 && <1.3,+ time >=1.8.0 && <1.10,+ unix >=2.7.2 && <2.8,+ unordered-containers >=0.2.10 && <0.3,+ uuid >=1.3.13 && <1.4,+ wai >=3.2.2 && <3.3,+ wai-extra >=3.0.29 && <3.2,+ wai-middleware-prometheus >=1.0.0 && <1.1,+ wai-websockets >=3.0.1 && <3.1,+ warp >=3.3.0 && <3.4,+ websockets >=0.12.7 && <0.13+ executable icepeak- main-is: Main.hs- other-modules:- Paths_icepeak- hs-source-dirs:- app/Icepeak- ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -I0"- build-depends:- aeson >=1.4.6 && <1.6- , async >=2.2.2 && <2.3- , base >=4.12.0 && <4.15- , bytestring >=0.10.8 && <0.11- , containers >=0.6.0 && <0.7- , directory >=1.3.3 && <1.4- , hashable >=1.2.0 && <1.4- , http-types >=0.12.3 && <0.13- , icepeak- , jwt >=0.10.0 && <0.11- , monad-logger >=0.3.31 && <0.4- , mtl >=2.2.2 && <2.3- , network >=2.8.0 && <3.2- , optparse-applicative >=0.14.0 && <0.16- , prometheus-client >=1.0.0 && <1.1- , prometheus-metrics-ghc >=1.0.0 && <1.1- , random >=1.1 && <1.2- , raven-haskell >=0.1.2 && <0.2- , scotty >=0.11.5 && <0.13- , securemem >=0.1.10 && <0.2- , sqlite-simple >=0.4.16 && <0.5- , stm >=2.5.0 && <2.6- , text >=1.2.3 && <1.3- , time >=1.8.0 && <1.10- , unix >=2.7.2 && <2.8- , unordered-containers >=0.2.10 && <0.3- , uuid >=1.3.13 && <1.4- , wai >=3.2.2 && <3.3- , wai-extra >=3.0.29 && <3.2- , wai-middleware-prometheus >=1.0.0 && <1.1- , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.0 && <3.4- , websockets >=0.12.7 && <0.13- default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: app/Icepeak+ other-modules: Paths_icepeak+ default-language: Haskell2010+ ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -I0"+ build-depends:+ aeson >=1.4.6 && <2.1,+ async >=2.2.2 && <2.3,+ base >=4.15.0 && <4.16,+ bytestring >=0.10.8 && <0.11,+ containers >=0.6.0 && <0.7,+ directory >=1.3.3 && <1.4,+ hashable >=1.2.0 && <1.4,+ http-types >=0.12.3 && <0.13,+ icepeak,+ jwt >=0.10.0 && <0.12,+ monad-logger >=0.3.31 && <0.4,+ mtl >=2.2.2 && <2.3,+ network >=2.8.0 && <3.2,+ optparse-applicative >=0.16.0 && <0.17,+ prometheus-client >=1.0.0 && <1.2,+ prometheus-metrics-ghc >=1.0.0 && <1.1,+ random >=1.1 && <1.3,+ raven-haskell >=0.1.2 && <0.2,+ scotty >=0.11.5 && <0.13,+ securemem >=0.1.10 && <0.2,+ sqlite-simple >=0.4.16 && <0.5,+ stm >=2.5.0 && <2.6,+ text >=1.2.3 && <1.3,+ time >=1.8.0 && <1.10,+ unix >=2.7.2 && <2.8,+ unordered-containers >=0.2.10 && <0.3,+ uuid >=1.3.13 && <1.4,+ wai >=3.2.2 && <3.3,+ wai-extra >=3.0.29 && <3.2,+ wai-middleware-prometheus >=1.0.0 && <1.1,+ wai-websockets >=3.0.1 && <3.1,+ warp >=3.3.0 && <3.4,+ websockets >=0.12.7 && <0.13 executable icepeak-token-gen- main-is: Main.hs- other-modules:- Paths_icepeak- hs-source-dirs:- app/IcepeakTokenGen- ghc-options: -Wall- build-depends:- aeson >=1.4.6 && <1.6- , async >=2.2.2 && <2.3- , base >=4.12.0 && <4.15- , bytestring >=0.10.8 && <0.11- , containers >=0.6.0 && <0.7- , directory >=1.3.3 && <1.4- , hashable >=1.2.0 && <1.4- , http-types >=0.12.3 && <0.13- , icepeak- , jwt >=0.10.0 && <0.11- , monad-logger >=0.3.31 && <0.4- , mtl >=2.2.2 && <2.3- , network >=2.8.0 && <3.2- , optparse-applicative >=0.14.0 && <0.16- , prometheus-client >=1.0.0 && <1.1- , prometheus-metrics-ghc >=1.0.0 && <1.1- , random >=1.1 && <1.2- , raven-haskell >=0.1.2 && <0.2- , scotty >=0.11.5 && <0.13- , securemem >=0.1.10 && <0.2- , sqlite-simple >=0.4.16 && <0.5- , stm >=2.5.0 && <2.6- , text >=1.2.3 && <1.3- , time >=1.8.0 && <1.10- , unix >=2.7.2 && <2.8- , unordered-containers >=0.2.10 && <0.3- , uuid >=1.3.13 && <1.4- , wai >=3.2.2 && <3.3- , wai-extra >=3.0.29 && <3.2- , wai-middleware-prometheus >=1.0.0 && <1.1- , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.0 && <3.4- , websockets >=0.12.7 && <0.13- default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: app/IcepeakTokenGen+ other-modules: Paths_icepeak+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ aeson >=1.4.6 && <2.1,+ async >=2.2.2 && <2.3,+ base >=4.15.0 && <4.16,+ bytestring >=0.10.8 && <0.11,+ containers >=0.6.0 && <0.7,+ directory >=1.3.3 && <1.4,+ hashable >=1.2.0 && <1.4,+ http-types >=0.12.3 && <0.13,+ icepeak,+ jwt >=0.10.0 && <0.12,+ monad-logger >=0.3.31 && <0.4,+ mtl >=2.2.2 && <2.3,+ network >=2.8.0 && <3.2,+ optparse-applicative >=0.16.0 && <0.17,+ prometheus-client >=1.0.0 && <1.2,+ prometheus-metrics-ghc >=1.0.0 && <1.1,+ random >=1.1 && <1.3,+ raven-haskell >=0.1.2 && <0.2,+ scotty >=0.11.5 && <0.13,+ securemem >=0.1.10 && <0.2,+ sqlite-simple >=0.4.16 && <0.5,+ stm >=2.5.0 && <2.6,+ text >=1.2.3 && <1.3,+ time >=1.8.0 && <1.10,+ unix >=2.7.2 && <2.8,+ unordered-containers >=0.2.10 && <0.3,+ uuid >=1.3.13 && <1.4,+ wai >=3.2.2 && <3.3,+ wai-extra >=3.0.29 && <3.2,+ wai-middleware-prometheus >=1.0.0 && <1.1,+ wai-websockets >=3.0.1 && <3.1,+ warp >=3.3.0 && <3.4,+ websockets >=0.12.7 && <0.13 test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules:- AccessControlSpec- ApiSpec- CoreSpec- JwtSpec- OrphanInstances- PersistenceSpec- RequestSpec- SocketSpec- StoreSpec- SubscriptionTreeSpec- Paths_icepeak- hs-source-dirs:- tests- ghc-options: -Wall -Wno-orphans- build-depends:- QuickCheck- , aeson >=1.4.6 && <1.6- , async >=2.2.2 && <2.3- , base >=4.12.0 && <4.15- , bytestring >=0.10.8 && <0.11- , containers >=0.6.0 && <0.7- , directory >=1.3.3 && <1.4- , hashable >=1.2.0 && <1.4- , hspec- , hspec-core- , hspec-expectations- , hspec-wai- , http-types >=0.12.3 && <0.13- , icepeak- , jwt >=0.10.0 && <0.11- , monad-logger >=0.3.31 && <0.4- , mtl >=2.2.2 && <2.3- , network >=2.8.0 && <3.2- , optparse-applicative >=0.14.0 && <0.16- , prometheus-client >=1.0.0 && <1.1- , prometheus-metrics-ghc >=1.0.0 && <1.1- , quickcheck-instances- , random >=1.1 && <1.2- , raven-haskell >=0.1.2 && <0.2- , scotty >=0.11.5 && <0.13- , securemem >=0.1.10 && <0.2- , sqlite-simple >=0.4.16 && <0.5- , stm >=2.5.0 && <2.6- , text >=1.2.3 && <1.3- , time >=1.8.0 && <1.10- , unix >=2.7.2 && <2.8- , unordered-containers >=0.2.10 && <0.3- , uuid >=1.3.13 && <1.4- , wai >=3.2.2 && <3.3- , wai-extra >=3.0.29 && <3.2- , wai-middleware-prometheus >=1.0.0 && <1.1- , wai-websockets >=3.0.1 && <3.1- , warp >=3.3.0 && <3.4- , websockets >=0.12.7 && <0.13- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: tests+ other-modules:+ AccessControlSpec+ ApiSpec+ CoreSpec+ JwtSpec+ OrphanInstances+ PersistenceSpec+ RequestSpec+ SocketSpec+ StoreSpec+ SubscriptionTreeSpec+ Paths_icepeak++ default-language: Haskell2010+ ghc-options: -Wall -Wno-orphans+ build-depends:+ QuickCheck <2.15,+ aeson >=1.4.6 && <2.1,+ async >=2.2.2 && <2.3,+ base >=4.15.0 && <4.16,+ bytestring >=0.10.8 && <0.11,+ containers >=0.6.0 && <0.7,+ directory >=1.3.3 && <1.4,+ hashable >=1.2.0 && <1.4,+ hspec <2.9,+ hspec-core <2.9,+ hspec-expectations <0.9,+ hspec-wai <0.12,+ http-types >=0.12.3 && <0.13,+ icepeak,+ jwt >=0.10.0 && <0.12,+ monad-logger >=0.3.31 && <0.4,+ mtl >=2.2.2 && <2.3,+ network >=2.8.0 && <3.2,+ optparse-applicative >=0.16.0 && <0.17,+ prometheus-client >=1.0.0 && <1.2,+ prometheus-metrics-ghc >=1.0.0 && <1.1,+ quickcheck-instances <0.4,+ random >=1.1 && <1.3,+ raven-haskell >=0.1.2 && <0.2,+ scotty >=0.11.5 && <0.13,+ securemem >=0.1.10 && <0.2,+ sqlite-simple >=0.4.16 && <0.5,+ stm >=2.5.0 && <2.6,+ text >=1.2.3 && <1.3,+ time >=1.8.0 && <1.10,+ unix >=2.7.2 && <2.8,+ unordered-containers >=0.2.10 && <0.3,+ uuid >=1.3.13 && <1.4,+ wai >=3.2.2 && <3.3,+ wai-extra >=3.0.29 && <3.2,+ wai-middleware-prometheus >=1.0.0 && <1.1,+ wai-websockets >=3.0.1 && <3.1,+ warp >=3.3.0 && <3.4,+ websockets >=0.12.7 && <0.13
src/Config.hs view
@@ -6,9 +6,9 @@ configInfo, ) where -import Control.Applicative (optional)-import Data.Semigroup ((<>))-import Options.Applicative+import Options.Applicative ((<|>), auto, eitherReader, flag, flag', fullDesc, header, help, helper,+ info, long, metavar, option, optional, strOption, switch, value,+ Parser, ParserInfo, ReadM) import qualified Network.Wai.Handler.Warp as Warp import qualified Text.Read as Read import qualified Data.Char as Char@@ -30,7 +30,7 @@ -- | The secret used for verifying the JWT signatures. If no secret is -- specified even though JWT authorization is enabled, tokens will still be -- used, but not be verified.- , configJwtSecret :: Maybe JWT.Signer+ , configJwtSecret :: Maybe JWT.VerifySigner , configMetricsEndpoint :: Maybe MetricsConfig , configQueueCapacity :: Word , configSyncIntervalMicroSeconds :: Maybe Int@@ -108,7 +108,9 @@ readFromEnvironment :: Read a => String -> Maybe a readFromEnvironment var = lookup var environment >>= Read.readMaybe - secretOption m = JWT.hmacSecret . Text.pack <$> strOption m+ -- Note: We need a VerifySigner here (and not an EncodeSigner) since the Icepeak+ -- server only verifies tokens+ secretOption m = JWT.toVerify . JWT.hmacSecret . Text.pack <$> strOption m configInfo :: EnvironmentConfig -> ParserInfo Config configInfo environment = info parser description
src/JwtAuth.hs view
@@ -27,7 +27,7 @@ deriving (Show, Eq) -- | Check that a token is valid at the given time for the given secret.-verifyToken :: POSIXTime -> JWT.Signer -> SBS.ByteString -> Either VerificationError (JWT VerifiedJWT)+verifyToken :: POSIXTime -> JWT.VerifySigner -> SBS.ByteString -> Either VerificationError (JWT VerifiedJWT) verifyToken now secret = verifyNotBefore now <=< verifyExpiry now <=< verifySignature secret@@ -54,7 +54,7 @@ else Right token -- | Verify that the token contains a valid signature.-verifySignature :: JWT.Signer -> JWT UnverifiedJWT -> Either VerificationError (JWT VerifiedJWT)+verifySignature :: JWT.VerifySigner -> JWT UnverifiedJWT -> Either VerificationError (JWT VerifiedJWT) verifySignature secret token = case JWT.verify secret token of Nothing -> Left TokenSignatureInvalid@@ -74,7 +74,7 @@ deriving (Show, Eq) -- | Verify the token and extract the icepeak claim from it.-extractClaim :: POSIXTime -> JWT.Signer -> SBS.ByteString -> Either TokenError IcepeakClaim+extractClaim :: POSIXTime -> JWT.VerifySigner -> SBS.ByteString -> Either TokenError IcepeakClaim extractClaim now secret tokenBytes = do jwt <- first VerificationError $ verifyToken now secret tokenBytes claim <- first ClaimError $ getIcepeakClaim jwt
src/JwtMiddleware.hs view
@@ -18,7 +18,6 @@ import AccessControl import JwtAuth-import Store (Path) -- | Defines the kinds of errors that cause authorization to fail. data AuthError@@ -39,7 +38,7 @@ -- | Check whether accessing the given path with the given mode is authorized by -- the token supplied in the request headers or query string (which may not be -- present, then failing the check).-isRequestAuthorized :: Http.RequestHeaders -> Http.Query -> POSIXTime -> Maybe JWT.Signer -> Path -> AccessMode -> AuthResult+isRequestAuthorized :: Http.RequestHeaders -> Http.Query -> POSIXTime -> Maybe JWT.VerifySigner -> Path -> AccessMode -> AuthResult isRequestAuthorized headers query now maybeSecret path mode = case getRequestClaim headers query now maybeSecret of Left err -> AuthRejected (TokenError err)@@ -49,7 +48,7 @@ -> AuthRejected OperationNotAllowed -- | Extract the JWT claim from the request.-getRequestClaim :: Http.RequestHeaders -> Http.Query -> POSIXTime -> Maybe JWT.Signer -> Either TokenError IcepeakClaim+getRequestClaim :: Http.RequestHeaders -> Http.Query -> POSIXTime -> Maybe JWT.VerifySigner -> Either TokenError IcepeakClaim getRequestClaim headers query now maybeSecret = let getTokenBytes = maybe (Left $ VerificationError TokenNotFound) Right (findTokenBytes headers query) in case maybeSecret of@@ -90,7 +89,7 @@ -- * Middleware -jwtMiddleware :: Maybe JWT.Signer -> Wai.Application -> Wai.Application+jwtMiddleware :: Maybe JWT.VerifySigner -> Wai.Application -> Wai.Application jwtMiddleware secret app req respond = do now <- Clock.getPOSIXTime case getRequestClaim headers query now secret of
src/MetricsServer.hs view
@@ -2,7 +2,6 @@ module MetricsServer where import Data.Function ((&))-import Data.Monoid ((<>)) import qualified Data.Text as Text import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Prometheus as PrometheusWai
src/Server.hs view
@@ -5,7 +5,6 @@ ) where -import Data.Semigroup ((<>)) import Data.Text (pack) import Network.Wai (Application)
src/Store.hs view
@@ -4,6 +4,8 @@ Modification (..), Path, Value,+ adjust,+ alter, modificationPath, applyModification, delete,@@ -14,13 +16,15 @@ where import Data.Aeson (Value (..), (.=), (.:))+import Data.Functor.Identity (runIdentity) import Data.Maybe (fromMaybe) import Data.Text (Text) import Prelude hiding (lookup) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson-import qualified Data.HashMap.Strict as HashMap+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as Key type Path = [Text] @@ -60,7 +64,7 @@ case path of [] -> Just value key : pathTail -> case value of- Object dict -> HashMap.lookup key dict >>= lookup pathTail+ Object dict -> KeyMap.lookup (Key.fromText key) dict >>= lookup pathTail _notObject -> Nothing -- Look up a value, returning null if the path does not exist.@@ -72,15 +76,15 @@ applyModification (Delete path) value = Store.delete path value applyModification (Put path newValue) value = Store.insert path newValue value --- Overwrite a value at the given path, and create the path leading up to it if+-- Insert or overwrite a value at the given path, and create the path leading up to it if -- it did not exist. insert :: Path -> Value -> Value -> Value insert path newValue value = case path of [] -> newValue key : pathTail -> Object $ case value of- Object dict -> HashMap.alter (Just . (insert pathTail newValue) . fromMaybe Null) key dict- _notObject -> HashMap.singleton key $ insert pathTail newValue Null+ Object dict -> alter (Just . (insert pathTail newValue) . fromMaybe Null) (Key.fromText key) dict+ _notObject -> KeyMap.singleton (Key.fromText key) $ insert pathTail newValue Null -- Delete key at the given path. If the path is empty, return null. delete :: Path -> Value -> Value@@ -88,8 +92,25 @@ case path of [] -> Null key : [] -> case value of- Object dict -> Object $ HashMap.delete key dict+ Object dict -> Object $ KeyMap.delete (Key.fromText key) dict notObject -> notObject key : pathTail -> case value of- Object dict -> Object $ HashMap.adjust (delete pathTail) key dict+ Object dict -> Object $ adjust (delete pathTail) (Key.fromText key) dict notObject -> notObject+++-- Note: We add two helper functions below, since Aeson does not implement them for the KeyMap type++-- Adjust a value at a specific key. When the key is not+-- a member of the KeyMap, the original KeyMap is returned.+adjust :: (v -> v) -> Key.Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v+adjust f key keymap = runIdentity (KeyMap.alterF fMaybe key keymap)+ where+ fMaybe Nothing = pure Nothing+ fMaybe (Just v) = pure (Just (f v))++-- When the key is not a member of the KeyMap, then the key is inserted into the KeyMap.+-- When the 'f' function returns Nothing for a given key then the key is deleted from the KeyMap+-- and the altered KeyMap is returned.+alter :: (Maybe v -> Maybe v) -> Key.Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v+alter f key keymap = runIdentity (KeyMap.alterF (pure . f) key keymap)
src/Subscription.hs view
@@ -19,7 +19,6 @@ import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Control.Concurrent.Async as Async
tests/JwtSpec.hs view
@@ -36,7 +36,9 @@ let testClaims = addIcepeakClaim testAccess emptyClaim - let testSecret = JWT.HMACSecret "2o8357cEuc2o835cmsoei"+ -- create an EncodeSigner for encoding secrets+ let testSecret = JWT.hmacSecret "2o8357cEuc2o835cmsoei"+ verifySigner = JWT.toVerify testSecret let now = 12512 :: NominalDiffTime @@ -49,28 +51,28 @@ it "should accept a valid token" $ do let token = Text.encodeUtf8 $ JWT.encodeSigned testSecret joseHeader testClaims- extractClaim now testSecret token `shouldBe` Right testAccess+ extractClaim now verifySigner token `shouldBe` Right testAccess it "should reject an expired token" $ do let Just expDate = JWT.numericDate $ now - 10 claims = testClaims { JWT.exp = Just expDate } expiredToken = Text.encodeUtf8 $ JWT.encodeSigned testSecret joseHeader claims- extractClaim now testSecret expiredToken `shouldBe` Left (VerificationError TokenExpired)+ extractClaim now verifySigner expiredToken `shouldBe` Left (VerificationError TokenExpired) it "should reject a token before its 'not before' date" $ do let Just nbfDate = JWT.numericDate $ now + 10 claims = testClaims { JWT.nbf = Just nbfDate } nbfToken = Text.encodeUtf8 $ JWT.encodeSigned testSecret joseHeader claims- extractClaim now testSecret nbfToken `shouldBe` Left (VerificationError TokenUsedTooEarly)+ extractClaim now verifySigner nbfToken `shouldBe` Left (VerificationError TokenUsedTooEarly) it "should reject a token with wrong secret" $ do let claims = testClaims nbfToken = Text.encodeUtf8 $ JWT.encodeSigned testSecret joseHeader claims- otherSecret = JWT.HMACSecret "dfhwcmo845cm8e5"+ otherSecret = JWT.toVerify $ JWT.hmacSecret "dfhwcmo845cm8e5" extractClaim now otherSecret nbfToken `shouldBe` Left (VerificationError TokenSignatureInvalid) prop "should correctly encode and decode token" $ \icepeakClaim -> let claims = addIcepeakClaim icepeakClaim emptyClaim encoded = Text.encodeUtf8 $ JWT.encodeSigned testSecret joseHeader claims- decoded = extractClaim now testSecret encoded+ decoded = extractClaim now verifySigner encoded in decoded == Right icepeakClaim
tests/OrphanInstances.hs view
@@ -22,12 +22,3 @@ [ Put <$> arbitrary <*> arbitrary , Delete <$> arbitrary ]--instance Arbitrary Value where- arbitrary = Gen.oneof- [ Object <$> Gen.scale (`div` 2) arbitrary- , Array <$> Gen.scale (`div` 2) arbitrary- , String <$> arbitrary- , Bool <$> arbitrary- , pure Null- ]
tests/StoreSpec.hs view
@@ -7,7 +7,7 @@ import Test.Hspec.QuickCheck (prop) import Test.QuickCheck.Instances () -import qualified Data.HashMap.Strict as HashMap+import qualified Data.Aeson.KeyMap as KeyMap import OrphanInstances () import Store (Modification (..))@@ -20,42 +20,42 @@ it "creates an object when putting 'x' into Null" $ let before = Null- after = Object $ HashMap.singleton "x" (String "Robert")+ after = Object $ KeyMap.singleton "x" (String "Robert") in Store.insert ["x"] (String "Robert") before `shouldBe` after it "overwrites a key when putting 'x' into {'x': ...}" $ let- before = Object $ HashMap.singleton "x" (String "Arian")- after = Object $ HashMap.singleton "x" (String "Robert")+ before = Object $ KeyMap.singleton "x" (String "Arian")+ after = Object $ KeyMap.singleton "x" (String "Robert") in Store.insert ["x"] (String "Robert") before `shouldBe` after it "adds a key when putting 'x' into {'y': ...}" $ let- before = Object $ HashMap.singleton "y" (String "Arian")- after = Object $ HashMap.fromList [("x", String "Robert"), ("y", String "Arian")]+ before = Object $ KeyMap.singleton "y" (String "Arian")+ after = Object $ KeyMap.fromList [("x", String "Robert"), ("y", String "Arian")] in Store.insert ["x"] (String "Robert") before `shouldBe` after it "creates a nested object when putting 'x/y' into Null" $ let before = Null- after = Object $ HashMap.singleton "x" $ Object $ HashMap.singleton "y" "Stefan"+ after = Object $ KeyMap.singleton "x" $ Object $ KeyMap.singleton "y" "Stefan" in Store.insert ["x", "y"] (String "Stefan") before `shouldBe` after it "updates a nested object when putting 'x/y' into {'x': {'y': ...}}" $ let- before = Object $ HashMap.singleton "x" $ Object $ HashMap.singleton "y" "Radek"- after = Object $ HashMap.singleton "x" $ Object $ HashMap.singleton "y" "Stefan"+ before = Object $ KeyMap.singleton "x" $ Object $ KeyMap.singleton "y" "Radek"+ after = Object $ KeyMap.singleton "x" $ Object $ KeyMap.singleton "y" "Stefan" in Store.insert ["x", "y"] (String "Stefan") before `shouldBe` after it "adds a nested key when putting 'x/y' into {'x': {'y': ...}, 'z': ...}" $ let- before = Object $ HashMap.fromList [("x", Object $ HashMap.singleton "y" "Nuno"), ("z", Null)]- after = Object $ HashMap.fromList [("x", Object $ HashMap.singleton "y" "Stefan"), ("z", Null)]+ before = Object $ KeyMap.fromList [("x", Object $ KeyMap.singleton "y" "Nuno"), ("z", Null)]+ after = Object $ KeyMap.fromList [("x", Object $ KeyMap.singleton "y" "Stefan"), ("z", Null)] in Store.insert ["x", "y"] (String "Stefan") before `shouldBe` after @@ -83,23 +83,23 @@ let put = Put ["x"] (String "Robert") before = Null- after = Object $ HashMap.singleton "x" (String "Robert")+ after = Object $ KeyMap.singleton "x" (String "Robert") in Store.applyModification put before `shouldBe` after it "overwrites a key when putting 'x' into {'x': ...}" $ let put = Put ["x"] (String "Robert")- before = Object $ HashMap.singleton "x" (String "Arian")- after = Object $ HashMap.singleton "x" (String "Robert")+ before = Object $ KeyMap.singleton "x" (String "Arian")+ after = Object $ KeyMap.singleton "x" (String "Robert") in Store.applyModification put before `shouldBe` after it "adds a key when putting 'x' into {'y': ...}" $ let put = Put ["x"] (String "Robert")- before = Object $ HashMap.singleton "y" (String "Arian")- after = Object $ HashMap.fromList [("x", String "Robert"), ("y", String "Arian")]+ before = Object $ KeyMap.singleton "y" (String "Arian")+ after = Object $ KeyMap.fromList [("x", String "Robert"), ("y", String "Arian")] in Store.applyModification put before `shouldBe` after @@ -107,23 +107,23 @@ let put = Put ["x", "y"] (String "Stefan") before = Null- after = Object $ HashMap.singleton "x" $ Object $ HashMap.singleton "y" "Stefan"+ after = Object $ KeyMap.singleton "x" $ Object $ KeyMap.singleton "y" "Stefan" in Store.applyModification put before `shouldBe` after it "updates a nested object when putting 'x/y' into {'x': {'y': ...}}" $ let put = Put ["x", "y"] (String "Stefan")- before = Object $ HashMap.singleton "x" $ Object $ HashMap.singleton "y" "Radek"- after = Object $ HashMap.singleton "x" $ Object $ HashMap.singleton "y" "Stefan"+ before = Object $ KeyMap.singleton "x" $ Object $ KeyMap.singleton "y" "Radek"+ after = Object $ KeyMap.singleton "x" $ Object $ KeyMap.singleton "y" "Stefan" in Store.applyModification put before `shouldBe` after it "adds a nested key when putting 'x/y' into {'x': {'y': ...}, 'z': ...}" $ let put = Put ["x", "y"] (String "Stefan")- before = Object $ HashMap.fromList [("x", Object $ HashMap.singleton "y" "Nuno"), ("z", Null)]- after = Object $ HashMap.fromList [("x", Object $ HashMap.singleton "y" "Stefan"), ("z", Null)]+ before = Object $ KeyMap.fromList [("x", Object $ KeyMap.singleton "y" "Nuno"), ("z", Null)]+ after = Object $ KeyMap.fromList [("x", Object $ KeyMap.singleton "y" "Stefan"), ("z", Null)] in Store.applyModification put before `shouldBe` after