diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index dc8e04120..c50095752 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -33,13 +33,13 @@ import Model import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap - import Data.Unique import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Data.Aeson.KeyMap as KeyMap + import Data.PQueue.Prio.Max (MaxPQueue) import qualified Data.PQueue.Prio.Max as PQ @@ -50,6 +50,8 @@ import GHC.Conc (unsafeIOToSTM) import Data.Generics.Product.Types (Children, ChGeneric, HasTypesCustom(..)) +import Data.Maybe + {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} @@ -177,16 +179,15 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 , tagSingleConstructors = True - , sumEncoding = TaggedObject "job" "data" - } ''Job + , sumEncoding = TaggedObject "notification" "data" + } ''Notification deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 , tagSingleConstructors = True - , sumEncoding = TaggedObject "notification" "data" - } ''Notification - + , sumEncoding = TaggedObject "job" "data" + } ''Job data JobChildren type instance Children JobChildren a = ChildrenJobChildren a @@ -214,7 +215,7 @@ classifyJob :: Job -> String classifyJob job = unpack tag where Aeson.Object obj = Aeson.toJSON job - Aeson.String tag = obj HashMap.! "job" + Aeson.String tag = fromJust $ obj KeyMap.!? "job" data JobCtlPrewarmSource @@ -267,7 +268,7 @@ classifyJobCtl :: JobCtl -> String classifyJobCtl jobctl = unpack tag where Aeson.Object obj = Aeson.toJSON jobctl - Aeson.String tag = obj HashMap.! "instruction" + Aeson.String tag = fromJust $ obj KeyMap.!? "instruction" -- | Slightly modified Version of `YesodDB` for `runDBJobs` diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index 9ba12c896..399fb9d6e 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/src/Model/Tokens/Bearer.hs @@ -40,6 +40,8 @@ import Data.Aeson.Types (Parser, (.:?), (.!=)) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON +import qualified Data.Aeson.KeyMap as KeyMap + import CryptoID import Data.Time.Clock.POSIX @@ -105,17 +107,17 @@ instance HasTokenExpiresAt (BearerToken site) (Maybe UTCTime) where instance HasTokenStartsAt (BearerToken site) (Maybe UTCTime) where _tokenStartsAt = _bearerStartsAt -_bearerRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a +_bearerRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site)) => Route site -> Traversal' (BearerToken site) a -- ^ Focus a singular restriction (by route) if it exists -- -- This /cannot/ be used to add restrictions, use `_bearerRestrictionAt` or `bearerRestrict` instead _bearerRestrictionIx route = _bearerRestrictions . ix route . _JSON -_bearerRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a) +_bearerRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a) -- ^ Focus a singular restriction (by route) whether it exists, or not _bearerRestrictionAt route = _bearerRestrictions . at route . maybePrism _JSON -bearerRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site +bearerRestrict :: (ToJSON a, Hashable (Route site)) => Route site -> a -> BearerToken site -> BearerToken site -- ^ Add a restriction to a `BearerToken` -- -- If a restriction already exists for the targeted route, it's silently overwritten @@ -153,10 +155,10 @@ bearerToJSON BearerToken{..} = do , ("add-auth" .=) <$> bearerAddAuth , ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions ] - ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm + ++ let JSON.Object hm = toJSON stdPayload in KeyMap.toList hm bearerParseJSON :: forall site. - ( Hashable (AuthId site), Eq (AuthId site) + ( Hashable (AuthId site) , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser) , ParseRoute site , Hashable (Route site) diff --git a/src/Model/Tokens/Upload.hs b/src/Model/Tokens/Upload.hs index 199a08d6f..2a819c993 100644 --- a/src/Model/Tokens/Upload.hs +++ b/src/Model/Tokens/Upload.hs @@ -28,10 +28,11 @@ import Data.Time.Clock.POSIX import Control.Monad.Fail import qualified Data.Aeson as JSON +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.TH import Utils.PathPiece -import qualified Data.HashMap.Strict as HashMap +-- import qualified Data.HashMap.Strict as HashMap import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Data.ByteString.Base64.URL as Base64 @@ -101,7 +102,7 @@ instance ToJSON UploadToken where toJSON UploadToken{..} = JSON.object . catMaybes $ [ pure $ "config" JSON..= uploadTokenConfig , fmap ("state" JSON..=) uploadTokenState - ] ++ let JSON.Object hm = toJSON Jose.JwtClaims{..} in (pure <$> HashMap.toList hm) + ] ++ let JSON.Object hm = toJSON Jose.JwtClaims{..} in (pure <$> KeyMap.toList hm) where jwtIss = Just $ toPathPiece uploadTokenIssuedBy jwtSub = Just $ toPathPiece uploadTokenNonce jwtAud = Just . pure $ toPathPiece uploadTokenIssuedFor diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index e66de2cd1..42211662f 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -37,7 +37,7 @@ import Text.Blaze (Markup) bearerParseJSON' :: forall site m. - ( Hashable (AuthId site), Eq (AuthId site) + ( Hashable (AuthId site) , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser) , ParseRoute site , Hashable (Route site) @@ -116,7 +116,7 @@ decodeBearer :: forall site m. ( MonadSite site m , MonadIO m , HasJSONWebKeySet site JwkSet - , Hashable (AuthId site), Eq (AuthId site) + , Hashable (AuthId site) , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser) , MonadCryptoKey m ~ CryptoIDKey , MonadCrypto m