fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(versionbump): Removed redundant imports and restrictions, fixed instances, ...

Browse Source
This commit is contained in:
Stephan Barth 2024-05-09 20:13:20 +02:00
parent 0d84d3650a
commit 59cd492fb1
4 changed files with 22 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
src/Jobs/Types.hs
View File

@ -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`

12
src/Model/Tokens/Bearer.hs
View File

@ -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)

5
src/Model/Tokens/Upload.hs
View File

@ -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

4
src/Utils/Tokens.hs
View File

@ -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