mirror of
https://github.com/typeable/bloodhound.git
synced 2024-09-11 08:25:32 +03:00
Also add Semigroup superclass to v5
This commit is contained in:
parent
0f6becf27a
commit
edaac67fcb
@ -364,40 +364,44 @@ module Database.V5.Bloodhound.Types
|
||||
, EsPassword(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative as A
|
||||
import Control.Arrow (first)
|
||||
import Control.Applicative as A
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types (Pair, Parser, emptyObject,
|
||||
parseEither, parseMaybe)
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import Data.Aeson.Types (Pair, Parser,
|
||||
emptyObject,
|
||||
parseEither, parseMaybe)
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import Data.Char
|
||||
import Data.Hashable (Hashable)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List (foldl', intercalate, nub)
|
||||
import Data.List.NonEmpty (NonEmpty (..), toList)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Hashable (Hashable)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List (foldl', intercalate,
|
||||
nub)
|
||||
import Data.List.NonEmpty (NonEmpty (..), toList)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Semigroup
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime)
|
||||
import Data.Time.Clock (NominalDiffTime,
|
||||
UTCTime)
|
||||
import Data.Time.Clock.POSIX
|
||||
import qualified Data.Traversable as DT
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Version as Vers
|
||||
import qualified Data.Traversable as DT
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Version as Vers
|
||||
import GHC.Enum
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client
|
||||
import qualified Network.HTTP.Types.Method as NHTM
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
import qualified Text.Read as TR
|
||||
import qualified Network.HTTP.Types.Method as NHTM
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
import qualified Text.Read as TR
|
||||
|
||||
import Database.V5.Bloodhound.Types.Class
|
||||
import Database.V5.Bloodhound.Types.Internal
|
||||
@ -452,11 +456,11 @@ runBH :: BHEnv -> BH m a -> m a
|
||||
runBH e f = runReaderT (unBH f) e
|
||||
|
||||
{-| 'Version' is embedded in 'Status' -}
|
||||
data Version = Version { number :: VersionNumber
|
||||
, build_hash :: BuildHash
|
||||
, build_date :: UTCTime
|
||||
, build_snapshot :: Bool
|
||||
, lucene_version :: VersionNumber } deriving (Eq, Read, Show, Generic, Typeable)
|
||||
data Version = Version { number :: VersionNumber
|
||||
, build_hash :: BuildHash
|
||||
, build_date :: UTCTime
|
||||
, build_snapshot :: Bool
|
||||
, lucene_version :: VersionNumber } deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
-- | Traditional software versioning number
|
||||
newtype VersionNumber = VersionNumber { versionNumber :: Vers.Version
|
||||
@ -494,7 +498,7 @@ defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
|
||||
for more info.
|
||||
-}
|
||||
data ForceMergeIndexSettings =
|
||||
ForceMergeIndexSettings { maxNumSegments :: Maybe Int
|
||||
ForceMergeIndexSettings { maxNumSegments :: Maybe Int
|
||||
-- ^ Number of segments to optimize to. 1 will fully optimize the index. If omitted, the default behavior is to only optimize if the server deems it necessary.
|
||||
, onlyExpungeDeletes :: Bool
|
||||
-- ^ Should the optimize process only expunge segments with deletes in them? If the purpose of the optimization is to free disk space, this should be set to True.
|
||||
@ -847,8 +851,8 @@ data SortSpec = DefaultSortSpec DefaultSort
|
||||
{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
|
||||
'mkSort' convenience function for when you want to specify only the most
|
||||
common parameters.
|
||||
|
||||
The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type'
|
||||
|
||||
The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type'
|
||||
|
||||
<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
|
||||
-}
|
||||
@ -1206,7 +1210,7 @@ data Query =
|
||||
deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
-- | As of Elastic 2.0, 'Filters' are just 'Queries' housed in a Bool Query, and
|
||||
-- flagged in a different context.
|
||||
-- flagged in a different context.
|
||||
newtype Filter = Filter { unFilter :: Query }
|
||||
deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
@ -1631,12 +1635,12 @@ data SearchHits a =
|
||||
, maxScore :: Score
|
||||
, hits :: [Hit a] } deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Semigroup (SearchHits a) where
|
||||
(SearchHits ta ma ha) <> (SearchHits tb mb hb) = SearchHits (ta + tb) (max ma mb) (ha <> hb)
|
||||
|
||||
instance Monoid (SearchHits a) where
|
||||
mempty = SearchHits 0 Nothing mempty
|
||||
mappend (SearchHits ta ma ha) (SearchHits tb mb hb) =
|
||||
SearchHits (ta + tb) (max ma mb) (ha <> hb)
|
||||
|
||||
mappend = (<>)
|
||||
|
||||
data Hit a =
|
||||
Hit { hitIndex :: IndexName
|
||||
@ -1659,7 +1663,7 @@ showText = T.pack . show
|
||||
readMay :: Read a => String -> Maybe a
|
||||
readMay s = case reads s of
|
||||
(a, ""):_ -> Just a
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
parseReadText :: Read a => Text -> Parser a
|
||||
parseReadText = maybe mzero return . readMay . T.unpack
|
||||
@ -1708,8 +1712,8 @@ data Aggregation = TermsAgg TermsAggregation
|
||||
| ValueCountAgg ValueCountAggregation
|
||||
| FilterAgg FilterAggregation
|
||||
| DateRangeAgg DateRangeAggregation
|
||||
| MissingAgg MissingAggregation
|
||||
| TopHitsAgg TopHitsAggregation
|
||||
| MissingAgg MissingAggregation
|
||||
| TopHitsAgg TopHitsAggregation
|
||||
deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
data TopHitsAggregation = TopHitsAggregation
|
||||
@ -1846,21 +1850,21 @@ instance ToJSON ExecutionHint where
|
||||
toJSON Map = "map"
|
||||
|
||||
instance ToJSON Interval where
|
||||
toJSON Year = "year"
|
||||
toJSON Year = "year"
|
||||
toJSON Quarter = "quarter"
|
||||
toJSON Month = "month"
|
||||
toJSON Week = "week"
|
||||
toJSON Day = "day"
|
||||
toJSON Hour = "hour"
|
||||
toJSON Minute = "minute"
|
||||
toJSON Second = "second"
|
||||
toJSON Month = "month"
|
||||
toJSON Week = "week"
|
||||
toJSON Day = "day"
|
||||
toJSON Hour = "hour"
|
||||
toJSON Minute = "minute"
|
||||
toJSON Second = "second"
|
||||
|
||||
instance Show TimeInterval where
|
||||
show Weeks = "w"
|
||||
show Days = "d"
|
||||
show Hours = "h"
|
||||
show Minutes = "m"
|
||||
show Seconds = "s"
|
||||
show Weeks = "w"
|
||||
show Days = "d"
|
||||
show Hours = "h"
|
||||
show Minutes = "m"
|
||||
show Seconds = "s"
|
||||
|
||||
instance Read TimeInterval where
|
||||
readPrec = f =<< TR.get
|
||||
@ -1916,7 +1920,7 @@ instance ToJSON Aggregation where
|
||||
toJSON (MissingAgg (MissingAggregation{..})) =
|
||||
object ["missing" .= object ["field" .= maField]]
|
||||
|
||||
toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =
|
||||
toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =
|
||||
omitNulls ["top_hits" .= omitNulls [ "size" .= msize
|
||||
, "from" .= mfrom
|
||||
, "sort" .= msort
|
||||
@ -1931,22 +1935,22 @@ instance ToJSON DateRangeAggregation where
|
||||
]
|
||||
|
||||
instance ToJSON DateRangeAggRange where
|
||||
toJSON (DateRangeFrom e) = object [ "from" .= e ]
|
||||
toJSON (DateRangeTo e) = object [ "to" .= e ]
|
||||
toJSON (DateRangeFrom e) = object [ "from" .= e ]
|
||||
toJSON (DateRangeTo e) = object [ "to" .= e ]
|
||||
toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]
|
||||
|
||||
instance ToJSON DateMathExpr where
|
||||
toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))
|
||||
where fmtA DMNow = "now"
|
||||
where fmtA DMNow = "now"
|
||||
fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"
|
||||
fmtMod (AddTime n u) = "+" <> showText n <> fmtU u
|
||||
fmtMod (AddTime n u) = "+" <> showText n <> fmtU u
|
||||
fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u
|
||||
fmtMod (RoundDownTo u) = "/" <> fmtU u
|
||||
fmtU DMYear = "y"
|
||||
fmtU DMMonth = "M"
|
||||
fmtU DMWeek = "w"
|
||||
fmtU DMDay = "d"
|
||||
fmtU DMHour = "h"
|
||||
fmtMod (RoundDownTo u) = "/" <> fmtU u
|
||||
fmtU DMYear = "y"
|
||||
fmtU DMMonth = "M"
|
||||
fmtU DMWeek = "w"
|
||||
fmtU DMDay = "d"
|
||||
fmtU DMHour = "h"
|
||||
fmtU DMMinute = "m"
|
||||
fmtU DMSecond = "s"
|
||||
|
||||
@ -2026,8 +2030,8 @@ instance (FromJSON a, BucketAggregation a) => FromJSON (Bucket a) where
|
||||
instance FromJSON BucketValue where
|
||||
parseJSON (String t) = return $ TextValue t
|
||||
parseJSON (Number s) = return $ ScientificValue s
|
||||
parseJSON (Bool b) = return $ BoolValue b
|
||||
parseJSON _ = mempty
|
||||
parseJSON (Bool b) = return $ BoolValue b
|
||||
parseJSON _ = mempty
|
||||
|
||||
instance FromJSON MissingResult where
|
||||
parseJSON = withObject "MissingResult" parse
|
||||
@ -2086,11 +2090,11 @@ fieldTagged f o = case HM.toList o of
|
||||
_ -> fail "Expected object with 1 field-named key"
|
||||
|
||||
-- Try to get an AggregationResults when we don't know the
|
||||
-- field name. We filter out the known keys to try to minimize the noise.
|
||||
-- field name. We filter out the known keys to try to minimize the noise.
|
||||
getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
|
||||
getNamedSubAgg o knownKeys = maggRes
|
||||
where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
|
||||
maggRes
|
||||
maggRes
|
||||
| HM.null unknownKeys = Nothing
|
||||
| otherwise = Just . M.fromList $ HM.toList unknownKeys
|
||||
|
||||
@ -2188,7 +2192,7 @@ instance ToJSON Query where
|
||||
object ["exists" .= object
|
||||
["field" .= fieldName]
|
||||
]
|
||||
toJSON QueryMatchNoneQuery =
|
||||
toJSON QueryMatchNoneQuery =
|
||||
object ["match_none" .= object []]
|
||||
|
||||
instance FromJSON Query where
|
||||
@ -2259,9 +2263,9 @@ instance FromJSON Query where
|
||||
|
||||
omitNulls :: [(Text, Value)] -> Value
|
||||
omitNulls = object . filter notNull where
|
||||
notNull (_, Null) = False
|
||||
notNull (_, Null) = False
|
||||
notNull (_, Array a) = (not . V.null) a
|
||||
notNull _ = True
|
||||
notNull _ = True
|
||||
|
||||
instance ToJSON SimpleQueryStringQuery where
|
||||
toJSON SimpleQueryStringQuery {..} =
|
||||
@ -2804,10 +2808,10 @@ instance FromJSON MultiMatchQuery where
|
||||
<*> o .:? "lenient"
|
||||
|
||||
instance ToJSON MultiMatchQueryType where
|
||||
toJSON MultiMatchBestFields = "best_fields"
|
||||
toJSON MultiMatchMostFields = "most_fields"
|
||||
toJSON MultiMatchCrossFields = "cross_fields"
|
||||
toJSON MultiMatchPhrase = "phrase"
|
||||
toJSON MultiMatchBestFields = "best_fields"
|
||||
toJSON MultiMatchMostFields = "most_fields"
|
||||
toJSON MultiMatchCrossFields = "cross_fields"
|
||||
toJSON MultiMatchPhrase = "phrase"
|
||||
toJSON MultiMatchPhrasePrefix = "phrase_prefix"
|
||||
|
||||
instance FromJSON MultiMatchQueryType where
|
||||
@ -2821,7 +2825,7 @@ instance FromJSON MultiMatchQueryType where
|
||||
|
||||
instance ToJSON BooleanOperator where
|
||||
toJSON And = String "and"
|
||||
toJSON Or = String "or"
|
||||
toJSON Or = String "or"
|
||||
|
||||
instance FromJSON BooleanOperator where
|
||||
parseJSON = withText "BooleanOperator" parse
|
||||
@ -2840,7 +2844,7 @@ instance FromJSON ZeroTermsQuery where
|
||||
parse q = fail ("Unexpected ZeroTermsQuery: " <> show q)
|
||||
|
||||
instance ToJSON MatchQueryType where
|
||||
toJSON MatchPhrase = "phrase"
|
||||
toJSON MatchPhrase = "phrase"
|
||||
toJSON MatchPhrasePrefix = "phrase_prefix"
|
||||
|
||||
instance FromJSON MatchQueryType where
|
||||
@ -2974,7 +2978,7 @@ instance FromJSON IndexSettingsSummary where
|
||||
<*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")
|
||||
_ -> fail "Expected single-key object with index name"
|
||||
redundant (NumberOfReplicas _) = True
|
||||
redundant _ = False
|
||||
redundant _ = False
|
||||
|
||||
-- | For some reason in several settings APIs, all leaf values get returned
|
||||
-- as strings. This function attepmts to recover from this for all
|
||||
@ -2984,7 +2988,7 @@ unStringlyTypeJSON (String "true") = Bool True
|
||||
unStringlyTypeJSON (String "false") = Bool False
|
||||
unStringlyTypeJSON (String "null") = Null
|
||||
unStringlyTypeJSON v@(String t) = case readMay (T.unpack t) of
|
||||
Just n -> Number n
|
||||
Just n -> Number n
|
||||
Nothing -> v
|
||||
unStringlyTypeJSON v = v
|
||||
|
||||
@ -3001,7 +3005,7 @@ parseSettings o = do
|
||||
return (catMaybes parses)
|
||||
|
||||
oPath :: ToJSON a => NonEmpty Text -> a -> Value
|
||||
oPath (k :| []) v = object [k .= v]
|
||||
oPath (k :| []) v = object [k .= v]
|
||||
oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
|
||||
|
||||
attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
|
||||
@ -3011,12 +3015,12 @@ attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
|
||||
parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)
|
||||
parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse
|
||||
where parse o = case HM.toList o of
|
||||
[] -> fail "Expected non-empty list of NodeAttrFilters"
|
||||
[] -> fail "Expected non-empty list of NodeAttrFilters"
|
||||
x:xs -> DT.mapM (uncurry parse') (x :| xs)
|
||||
parse' n = withText "Text" $ \t ->
|
||||
case T.splitOn "," t of
|
||||
fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))
|
||||
[] -> fail "Expected non-empty list of filter values"
|
||||
[] -> fail "Expected non-empty list of filter values"
|
||||
|
||||
instance ToJSON ReplicaBounds where
|
||||
toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)
|
||||
@ -3070,12 +3074,12 @@ instance ToJSON FSType where
|
||||
|
||||
instance FromJSON FSType where
|
||||
parseJSON = withText "FSType" parse
|
||||
where parse "simple" = pure FSSimple
|
||||
where parse "simple" = pure FSSimple
|
||||
parse "buffered" = pure FSBuffered
|
||||
parse t = fail ("Invalid FSType: " <> show t)
|
||||
parse t = fail ("Invalid FSType: " <> show t)
|
||||
|
||||
instance ToJSON CompoundFormat where
|
||||
toJSON (CompoundFileFormat x) = Bool x
|
||||
toJSON (CompoundFileFormat x) = Bool x
|
||||
toJSON (MergeSegmentVsTotalIndex x) = toJSON x
|
||||
|
||||
instance FromJSON CompoundFormat where
|
||||
@ -3193,7 +3197,7 @@ instance ToJSON Search where
|
||||
, "track_scores" .= sTrackSortScores
|
||||
, "fields" .= sFields
|
||||
, "_source" .= sSource]
|
||||
|
||||
|
||||
where query' = case sFilter of
|
||||
Nothing -> mquery
|
||||
Just x -> Just . QueryBoolQuery $ mkBoolQuery (maybeToList mquery) [x] [] []
|
||||
@ -3334,8 +3338,8 @@ instance ToJSON SortMode where
|
||||
|
||||
|
||||
instance ToJSON Missing where
|
||||
toJSON LastMissing = String "_last"
|
||||
toJSON FirstMissing = String "_first"
|
||||
toJSON LastMissing = String "_last"
|
||||
toJSON FirstMissing = String "_first"
|
||||
toJSON (CustomMissing txt) = String txt
|
||||
|
||||
|
||||
@ -3351,7 +3355,7 @@ instance FromJSON ScoreType where
|
||||
parse "avg" = pure ScoreTypeAvg
|
||||
parse "sum" = pure ScoreTypeSum
|
||||
parse "none" = pure ScoreTypeNone
|
||||
parse t = fail ("Unexpected ScoreType: " <> show t)
|
||||
parse t = fail ("Unexpected ScoreType: " <> show t)
|
||||
|
||||
instance ToJSON Distance where
|
||||
toJSON (Distance dCoefficient dUnit) =
|
||||
@ -3369,7 +3373,7 @@ instance FromJSON Distance where
|
||||
validForNumber '-' = True
|
||||
validForNumber '.' = True
|
||||
validForNumber 'e' = True
|
||||
validForNumber c = isNumber c
|
||||
validForNumber c = isNumber c
|
||||
parseCoeff "" = fail "Empty string cannot be parsed as number"
|
||||
parseCoeff s = return (read (T.unpack s))
|
||||
|
||||
@ -3396,7 +3400,7 @@ instance FromJSON DistanceUnit where
|
||||
parse "cm" = pure Centimeters
|
||||
parse "mm" = pure Millimeters
|
||||
parse "nmi" = pure NauticalMiles
|
||||
parse u = fail ("Unrecognized DistanceUnit: " <> show u)
|
||||
parse u = fail ("Unrecognized DistanceUnit: " <> show u)
|
||||
|
||||
instance ToJSON DistanceType where
|
||||
toJSON Arc = String "arc"
|
||||
@ -3405,21 +3409,21 @@ instance ToJSON DistanceType where
|
||||
|
||||
instance FromJSON DistanceType where
|
||||
parseJSON = withText "DistanceType" parse
|
||||
where parse "arc" = pure Arc
|
||||
where parse "arc" = pure Arc
|
||||
parse "sloppy_arc" = pure SloppyArc
|
||||
parse "plane" = pure Plane
|
||||
parse t = fail ("Unrecognized DistanceType: " <> show t)
|
||||
parse "plane" = pure Plane
|
||||
parse t = fail ("Unrecognized DistanceType: " <> show t)
|
||||
|
||||
|
||||
instance ToJSON OptimizeBbox where
|
||||
toJSON NoOptimizeBbox = String "none"
|
||||
toJSON NoOptimizeBbox = String "none"
|
||||
toJSON (OptimizeGeoFilterType gft) = toJSON gft
|
||||
|
||||
instance FromJSON OptimizeBbox where
|
||||
parseJSON v = withText "NoOptimizeBbox" parseNoOptimize v
|
||||
<|> parseOptimize v
|
||||
where parseNoOptimize "none" = pure NoOptimizeBbox
|
||||
parseNoOptimize _ = mzero
|
||||
parseNoOptimize _ = mzero
|
||||
parseOptimize = fmap OptimizeGeoFilterType . parseJSON
|
||||
|
||||
instance ToJSON GeoBoundingBoxConstraint where
|
||||
@ -4202,7 +4206,7 @@ instance SnapshotRepo FsSnapshotRepo where
|
||||
|
||||
parseRepo :: Parser a -> Either SnapshotRepoConversionError a
|
||||
parseRepo parser = case parseEither (const parser) () of
|
||||
Left e -> Left (OtherRepoConversionError (T.pack e))
|
||||
Left e -> Left (OtherRepoConversionError (T.pack e))
|
||||
Right a -> Right a
|
||||
|
||||
|
||||
@ -4683,7 +4687,7 @@ instance FromJSON NodeProcessStats where
|
||||
<*> o .: "open_file_descriptors"
|
||||
<*> o .: "max_file_descriptors"
|
||||
<*> cpu .: "percent"
|
||||
<*> (unMS <$> cpu .: "total_in_millis")
|
||||
<*> (unMS <$> cpu .: "total_in_millis")
|
||||
<*> mem .: "total_virtual_in_bytes"
|
||||
|
||||
instance FromJSON NodeOSStats where
|
||||
@ -4720,7 +4724,7 @@ instance FromJSON NodeIndicesStats where
|
||||
where
|
||||
parse o = do
|
||||
let (.::) mv k = case mv of
|
||||
Just v -> Just <$> v .: k
|
||||
Just v -> Just <$> v .: k
|
||||
Nothing -> pure Nothing
|
||||
mRecovery <- o .:? "recovery"
|
||||
mQueryCache <- o .:? "query_cache"
|
||||
@ -4965,8 +4969,8 @@ parseStringInterval s = case span isNumber s of
|
||||
("", _) -> fail "Invalid interval"
|
||||
(nS, unitS) -> case (readMay nS, readMay unitS) of
|
||||
(Just n, Just unit) -> return (fromInteger (n * unitNDT unit))
|
||||
(Nothing, _) -> fail "Invalid interval number"
|
||||
(_, Nothing) -> fail "Invalid interval unit"
|
||||
(Nothing, _) -> fail "Invalid interval number"
|
||||
(_, Nothing) -> fail "Invalid interval unit"
|
||||
where
|
||||
unitNDT Seconds = 1
|
||||
unitNDT Minutes = 60
|
||||
@ -4985,8 +4989,8 @@ instance FromJSON ThreadPoolSize where
|
||||
parseAsString = withText "ThreadPoolSize" $ \t ->
|
||||
case first (readMay . T.unpack) (T.span isNumber t) of
|
||||
(Just n, "k") -> return (ThreadPoolBounded (n * 1000))
|
||||
(Just n, "") -> return (ThreadPoolBounded n)
|
||||
_ -> fail ("Invalid thread pool size " <> T.unpack t)
|
||||
(Just n, "") -> return (ThreadPoolBounded n)
|
||||
_ -> fail ("Invalid thread pool size " <> T.unpack t)
|
||||
|
||||
instance FromJSON ThreadPoolType where
|
||||
parseJSON = withText "ThreadPoolType" parse
|
||||
@ -5001,10 +5005,10 @@ instance FromJSON NodeTransportInfo where
|
||||
where
|
||||
parse o = NodeTransportInfo <$> (maybe (return mempty) parseProfiles =<< o .:? "profiles")
|
||||
<*> parseJSON (Object o)
|
||||
parseProfiles (Object o) | HM.null o = return []
|
||||
parseProfiles (Object o) | HM.null o = return []
|
||||
parseProfiles v@(Array _) = parseJSON v
|
||||
parseProfiles Null = return []
|
||||
parseProfiles _ = fail "Could not parse profiles"
|
||||
parseProfiles Null = return []
|
||||
parseProfiles _ = fail "Could not parse profiles"
|
||||
|
||||
instance FromJSON NodeNetworkInfo where
|
||||
parseJSON = withObject "NodeNetworkInfo" parse
|
||||
@ -5025,4 +5029,4 @@ newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
|
||||
|
||||
instance FromJSON a => FromJSON (MaybeNA a) where
|
||||
parseJSON (String "NA") = pure $ MaybeNA Nothing
|
||||
parseJSON o = MaybeNA . Just <$> parseJSON o
|
||||
parseJSON o = MaybeNA . Just <$> parseJSON o
|
||||
|
Loading…
Reference in New Issue
Block a user