From 04f8de239d7cd4580affdb5114e68e65006b9cef Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Wed, 3 Jul 2024 12:05:35 +0700 Subject: [PATCH 1/8] Simplify `ModelMetadata` --- inferno-ml-server-types/src/Inferno/ML/Server/Types.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index 1e301c2..e049469 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -499,11 +499,9 @@ instance FromJSON ModelDescription where -- | Metadata for the model, inspired by Hugging Face model card format data ModelMetadata = ModelMetadata - { languages :: Vector ISO63912, - tags :: Vector Text, + { categories :: Vector Int, datasets :: Vector Text, metrics :: Vector Text, - license :: Maybe Text, baseModel :: Maybe Text, thumbnail :: Maybe (Text, URIRef Absolute) } @@ -515,11 +513,9 @@ instance NFData ModelMetadata where instance FromJSON ModelMetadata where parseJSON = withObject "ModelMetadata" $ \o -> ModelMetadata - <$> o .:? "languages" .!= mempty - <*> o .:? "tags" .!= mempty + <$> o .:? "categories" .!= mempty <*> o .:? "datasets" .!= mempty <*> o .:? "metrics" .!= mempty - <*> o .:? "license" <*> o .:? "base_model" <*> (thumbnailP =<< o .:? "thumbnail") where From 419ce69a2fc436b26997d887564d135f59a40837 Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Wed, 3 Jul 2024 14:49:29 +0700 Subject: [PATCH 2/8] Arbitrary instances all over the place --- .../inferno-ml-server-types.cabal | 3 + .../src/Inferno/ML/Server/Types.hs | 242 ++++++++++-------- 2 files changed, 139 insertions(+), 106 deletions(-) diff --git a/inferno-ml-server-types/inferno-ml-server-types.cabal b/inferno-ml-server-types/inferno-ml-server-types.cabal index c20e952..3df91d0 100644 --- a/inferno-ml-server-types/inferno-ml-server-types.cabal +++ b/inferno-ml-server-types/inferno-ml-server-types.cabal @@ -56,6 +56,9 @@ library , iproute , microlens-platform , postgresql-simple + , QuickCheck + , quickcheck-arbitrary-adt + , quickcheck-instances , scientific , servant-client , servant-conduit diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index e049469..60b0280 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -9,6 +9,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Inferno.ML.Server.Types where @@ -26,14 +27,13 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as ByteString.Char8 import Data.Data (Typeable) import Data.Generics.Product (HasType (typed), the) -import Data.Generics.Wrapped (wrappedTo) +import Data.Generics.Wrapped (wrappedFrom, wrappedTo) import Data.Hashable (Hashable) import qualified Data.IP import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import Data.Ord (comparing) import Data.Scientific (toRealFloat) import Data.Text (Text) @@ -65,6 +65,7 @@ import Database.PostgreSQL.Simple.Types ) import Foreign.C (CUInt (CUInt)) import GHC.Generics (Generic) +import Inferno.Instances.Arbitrary () import Inferno.Types.Syntax (Ident) import Inferno.Types.VersionControl ( VCObjectHash, @@ -88,6 +89,25 @@ import Servant ) import Servant.Conduit () import System.Posix (EpochTime) +import Test.QuickCheck + ( Arbitrary (arbitrary), + Gen, + Positive (getPositive), + choose, + ) +import Test.QuickCheck.Arbitrary.ADT + ( ADTArbitrary (ADTArbitrary), + ADTArbitrarySingleton (ADTArbitrarySingleton), + ConstructorArbitraryPair (ConstructorArbitraryPair), + ToADTArbitrary + ( toADTArbitrary, + toADTArbitrarySingleton + ), + genericArbitrary, + ) +import Test.QuickCheck.Instances.Time () +import Test.QuickCheck.Instances.UUID () +import Test.QuickCheck.Instances.Vector () import Text.Read (readMaybe) import URI.ByteString (Absolute, URIRef) import URI.ByteString.Aeson () @@ -182,7 +202,10 @@ newtype Id a = Id Int64 ToHttpApiData, FromHttpApiData ) - deriving anyclass (NFData) + deriving anyclass (NFData, ToADTArbitrary) + +instance Arbitrary (Id a) where + arbitrary = wrappedFrom . getPositive <$> arbitrary -- | Row for the table containing inference script closures data InferenceScript uid gid = InferenceScript @@ -192,6 +215,15 @@ data InferenceScript uid gid = InferenceScript obj :: VCMeta uid gid VCObject } deriving stock (Show, Eq, Generic) + deriving anyclass (ToADTArbitrary) + +instance + ( Arbitrary uid, + Arbitrary gid + ) => + Arbitrary (InferenceScript uid gid) + where + arbitrary = genericArbitrary -- Newtype just for `FromRow`/`ToRow` instances. It would be possible to just -- add the instances to `inferno-types`, but then there would be a dependency @@ -257,6 +289,16 @@ data Model uid gid = Model terminated :: Maybe UTCTime } deriving stock (Show, Eq, Generic) + deriving anyclass (ToADTArbitrary) + +instance + ( Ord gid, + Arbitrary gid, + Arbitrary uid + ) => + Arbitrary (Model uid gid) + where + arbitrary = genericArbitrary instance NFData (Model uid gid) where rnf = rwhnf @@ -363,7 +405,11 @@ data ModelVersion uid gid c = ModelVersion terminated :: Maybe UTCTime } deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + -- NOTE: This may require an orphan instance for the `c` type variable + deriving anyclass (NFData, ToADTArbitrary) + +instance Arbitrary c => Arbitrary (ModelVersion uid gid c) where + arbitrary = genericArbitrary instance ( FromField uid, @@ -447,7 +493,10 @@ data ModelPermissions | -- | The model can be updated e.g. during training WriteModel deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + deriving anyclass (NFData, ToADTArbitrary) + +instance Arbitrary ModelPermissions where + arbitrary = genericArbitrary instance FromJSON ModelPermissions where parseJSON = withText "ModelPermissions" $ \case @@ -468,9 +517,12 @@ data ModelCard = ModelCard metadata :: ModelMetadata } deriving stock (Show, Eq, Generic) - deriving anyclass (FromJSON, ToJSON, NFData) + deriving anyclass (FromJSON, ToJSON, NFData, ToADTArbitrary) deriving (FromField, ToField) via Aeson ModelCard +instance Arbitrary ModelCard where + arbitrary = genericArbitrary + -- | Structured description of a model data ModelDescription = ModelDescription { -- | General summary of model, cannot be empty @@ -484,7 +536,10 @@ data ModelDescription = ModelDescription evaluation :: Text } deriving stock (Show, Eq, Generic) - deriving anyclass (ToJSON, NFData) + deriving anyclass (ToJSON, NFData, ToADTArbitrary) + +instance Arbitrary ModelDescription where + arbitrary = genericArbitrary {- ORMOLU_DISABLE -} instance FromJSON ModelDescription where @@ -507,6 +562,27 @@ data ModelMetadata = ModelMetadata } deriving stock (Show, Eq, Generic) +instance Arbitrary ModelMetadata where + arbitrary = + ModelMetadata + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + -- For the sake of simplicity, just set this field + -- unconditionally to `Nothing` for now + <*> pure Nothing + +instance ToADTArbitrary ModelMetadata where + toADTArbitrarySingleton _ = + ADTArbitrarySingleton "Inferno.ML.Server.Types" "ModelMetadata" + . ConstructorArbitraryPair "ModelMetadata" + <$> arbitrary + + toADTArbitrary _ = + ADTArbitrary "Inferno.ML.Server.Types" "ModelMetadata" + <$> sequence [ConstructorArbitraryPair "ModelMetadata" <$> arbitrary] + instance NFData ModelMetadata where rnf = rwhnf @@ -542,7 +618,10 @@ data Version [Text] -- ^ Any tags deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + deriving anyclass (NFData, ToADTArbitrary) + +instance Arbitrary Version where + arbitrary = genericArbitrary -- Compares based on digits, not on tag instance Ord Version where @@ -628,7 +707,16 @@ data InferenceParam uid gid p s = InferenceParam user :: uid } deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, ToJSON) + deriving anyclass (NFData, ToJSON, ToADTArbitrary) + +instance + ( Arbitrary s, + Arbitrary p, + Arbitrary uid + ) => + Arbitrary (InferenceParam uid gid p s) + where + arbitrary = genericArbitrary {- ORMOLU_DISABLE -} instance @@ -714,7 +802,10 @@ data ScriptInputType -- types of access enabled ReadableWritable deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) + deriving anyclass (NFData, ToADTArbitrary) + +instance Arbitrary ScriptInputType where + arbitrary = genericArbitrary instance FromJSON ScriptInputType where parseJSON = withText "ScriptInputType" $ \case @@ -754,7 +845,10 @@ data EvaluationInfo uid gid p = EvaluationInfo cpu :: Word64 } deriving stock (Show, Eq, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (FromJSON, ToJSON, ToADTArbitrary) + +instance Arbitrary (EvaluationInfo uid gid p) where + arbitrary = genericArbitrary instance FromRow (EvaluationInfo uid gid p) where fromRow = @@ -787,14 +881,40 @@ data User uid gid = User ToRow, FromJSON, ToJSON, - NFData + NFData, + ToADTArbitrary ) +instance (Arbitrary uid, Arbitrary gid) => Arbitrary (User uid gid) where + arbitrary = genericArbitrary + -- | IPv4 address with some useful instances newtype IPv4 = IPv4 Data.IP.IPv4 deriving stock (Generic) deriving newtype (Show, Eq, Ord, Read) +instance Arbitrary IPv4 where + arbitrary = genFromOctects + +instance ToADTArbitrary IPv4 where + toADTArbitrarySingleton _ = + ADTArbitrarySingleton "Inferno.ML.Server.Types" "IPv4" + . ConstructorArbitraryPair "IPv4" + <$> arbitrary + + toADTArbitrary _ = + ADTArbitrary "Inferno.ML.Server.Types" "IPv4" + <$> sequence [ConstructorArbitraryPair "IPv4" <$> arbitrary] + +genFromOctects :: Gen IPv4 +genFromOctects = + toIPv4 + <$> ( (,,,) <$> octetGen <*> octetGen <*> octetGen <*> octetGen + ) + +octetGen :: Gen Int +octetGen = choose (0, 255) + instance NFData IPv4 where rnf = rwhnf @@ -906,7 +1026,10 @@ data SingleOrMany a = Single a | Many (Vector a) deriving stock (Show, Eq, Generic, Functor) - deriving anyclass (NFData) + deriving anyclass (NFData, ToADTArbitrary) + +instance Arbitrary a => Arbitrary (SingleOrMany a) where + arbitrary = genericArbitrary instance FromJSON a => FromJSON (SingleOrMany a) where parseJSON v = @@ -937,96 +1060,3 @@ maybeConversion f fld = maybe (returnError UnexpectedNull fld mempty) $ maybe (returnError ConversionFailed fld mempty) pure . f - --- ISO63912 language tag for model card - -data ISO63912 = ISO63912 - { code :: (Char, Char), - name :: Text - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -instance FromJSON ISO63912 where - parseJSON = withText "ISO63912" $ \case - t - | Just (f, r) <- Text.uncons t, - Just (s, l) <- Text.uncons r, - l == mempty -> - maybe (fail "Missing ISO6391 language") pure $ fromChars (f, s) - | otherwise -> fail "Invalid ISO63912 code" - where - fromChars :: (Char, Char) -> Maybe ISO63912 - fromChars c = ISO63912 c <$> Map.lookup c languagesByCode - -instance ToJSON ISO63912 where - toJSON (ISO63912 (f, s) _) = String . flip Text.snoc s $ Text.singleton f - -{- ORMOLU_DISABLE -} -languagesByCode :: Map (Char, Char) Text -languagesByCode = - Map.fromList - [ (('a', 'a'), "Afar"), (('a', 'b'), "Abkhazian"), (('a', 'e'), "Avestan"), - (('a', 'f'), "Afrikaans"), (('a', 'k'), "Akan"), (('a', 'm'), "Amharic"), - (('a', 'n'), "Aragonese"), (('a', 'r'), "Arabic"), (('a', 's'), "Assamese"), - (('a', 'v'), "Avaric"), (('a', 'y'), "Aymara"), (('a', 'z'), "Azerbaijani"), - (('b', 'a'), "Bashkir"), (('b', 'e'), "Belarusian"), (('b', 'g'), "Bulgarian"), - (('b', 'h'), "Bihari"), (('b', 'm'), "Bambara"), (('b', 'i'), "Bislama"), - (('b', 'n'), "Bengali"), (('b', 'o'), "Tibetan"), (('b', 'r'), "Breton"), - (('b', 's'), "Bosnian"), (('c', 'a'), "Catalan"), (('c', 'e'), "Chechen"), - (('c', 'h'), "Chamorro"), (('c', 'o'), "Corsican"), (('c', 'r'), "Cree"), - (('c', 's'), "Czech"), (('c', 'u'), "Church Slavic"), (('c', 'v'), "Chuvash"), - (('c', 'y'), "Welsh"), (('d', 'a'), "Danish"), (('d', 'e'), "German"), - (('d', 'v'), "Divehi"), (('d', 'z'), "Dzongkha"), (('e', 'e'), "Ewe"), - (('e', 'l'), "Greek"), (('e', 'n'), "English"), (('e', 'o'), "Esperanto"), - (('e', 's'), "Spanish"), (('e', 't'), "Estonian"), (('e', 'u'), "Basque"), - (('f', 'a'), "Persian"), (('f', 'f'), "Fulah"), (('f', 'i'), "Finnish"), - (('f', 'j'), "Fijian"), (('f', 'o'), "Faroese"), (('f', 'r'), "French"), - (('f', 'y'), "Frisian"), (('g', 'a'), "Irish"), (('g', 'd'), "Gaelic"), - (('g', 'l'), "Galician"), (('g', 'n'), "Guarani"), (('g', 'u'), "Gujarati"), - (('g', 'v'), "Manx"), (('h', 'a'), "Hausa"), (('h', 'e'), "Hebrew"), - (('h', 'i'), "Hindi"), (('h', 'o'), "Hiri Motu"), (('h', 'r'), "Croatian"), - (('h', 't'), "Haitian"), (('h', 'u'), "Hungarian"), (('h', 'y'), "Armenian"), - (('h', 'z'), "Herero"), (('i', 'a'), "Interlingua"), (('i', 'd'), "Indonesian"), - (('i', 'e'), "Interlingue"), (('i', 'g'), "Igbo"), (('i', 'i'), "Sichuan Yi"), - (('i', 'k'), "Inupiaq"), (('i', 'o'), "Ido"), (('i', 's'), "Icelandic"), - (('i', 't'), "Italian"), (('i', 'u'), "Inuktitut"), (('j', 'a'), "Japanese"), - (('j', 'v'), "Javanese"), (('k', 'a'), "Georgian"), (('k', 'g'), "Kongo"), - (('k', 'i'), "Kikuyu"), (('k', 'j'), "Kuanyama"), (('k', 'k'), "Kazakh"), - (('k', 'l'), "Kalaallisut"), (('k', 'm'), "Khmer"), (('k', 'n'), "Kannada"), - (('k', 'o'), "Korean"), (('k', 'r'), "Kanuri"), (('k', 's'), "Kashmiri"), - (('k', 'u'), "Kurdish"), (('k', 'v'), "Komi"), (('k', 'w'), "Cornish"), - (('k', 'y'), "Kirghiz"), (('l', 'a'), "Latin"), (('l', 'b'), "Luxembourgish"), - (('l', 'g'), "Ganda"), (('l', 'i'), "Limburgan"), (('l', 'n'), "Lingala"), - (('l', 'o'), "Lao"), (('l', 't'), "Lithuanian"), (('l', 'u'), "Luba-Katanga"), - (('l', 'v'), "Latvian"), (('m', 'g'), "Malagasy"), (('m', 'h'), "Marshallese"), - (('m', 'i'), "Maori"), (('m', 'k'), "Macedonian"), (('m', 'l'), "Malayalam"), - (('m', 'n'), "Mongolian"), (('m', 'r'), "Marathi"), (('m', 's'), "Malay"), - (('m', 't'), "Maltese"), (('m', 'y'), "Burmese"), (('n', 'a'), "Nauru"), - (('n', 'b'), "Bokmål"), (('n', 'd'), "Ndebele, North"), (('n', 'e'), "Nepali"), - (('n', 'g'), "Ndonga"), (('n', 'l'), "Dutch"), (('n', 'n'), "Nynorsk"), - (('n', 'o'), "Norwegian"), (('n', 'r'), "Ndebele"), (('n', 'v'), "Navajo"), - (('n', 'y'), "Chichewa"), (('o', 'c'), "Occitan"), (('o', 'j'), "Ojibwa"), - (('o', 'm'), "Oromo"), (('o', 'r'), "Oriya"), (('o', 's'), "Ossetian"), - (('p', 'a'), "Panjabi"), (('p', 'i'), "Pali"), (('p', 'l'), "Polish"), - (('p', 's'), "Pushto"), (('p', 't'), "Portuguese"), (('q', 'u'), "Quechua"), - (('r', 'm'), "Romansh"), (('r', 'n'), "Rundi"), (('r', 'o'), "Romanian"), - (('r', 'u'), "Russian"), (('r', 'w'), "Kinyarwanda"), (('s', 'a'), "Sanskrit"), - (('s', 'c'), "Sardinian"), (('s', 'd'), "Sindhi"), (('s', 'e'), "Sami"), - (('s', 'g'), "Sango"), (('s', 'i'), "Sinhala"), (('s', 'k'), "Slovak"), - (('s', 'l'), "Slovenian"), (('s', 'm'), "Samoan"), (('s', 'n'), "Shona"), - (('s', 'o'), "Somali"), (('s', 'q'), "Albanian"), (('s', 'r'), "Serbian"), - (('s', 's'), "Swati"), (('s', 't'), "Sotho"), (('s', 'u'), "Sundanese"), - (('s', 'v'), "Swedish"), (('s', 'w'), "Swahili"), (('t', 'a'), "Tamil"), - (('t', 'e'), "Telugu"), (('t', 'g'), "Tajik"), (('t', 'h'), "Thai"), - (('t', 'i'), "Tigrinya"), (('t', 'k'), "Turkmen"), (('t', 'l'), "Tagalog"), - (('t', 'n'), "Tswana"), (('t', 'o'), "Tonga"), (('t', 'r'), "Turkish"), - (('t', 's'), "Tsonga"), (('t', 't'), "Tatar"), (('t', 'w'), "Twi"), - (('t', 'y'), "Tahitian"), (('u', 'g'), "Uighur"), (('u', 'k'), "Ukrainian"), - (('u', 'r'), "Urdu"), (('u', 'z'), "Uzbek"), (('v', 'e'), "Venda"), - (('v', 'i'), "Vietnamese"), (('v', 'o'), "Volapük"), (('w', 'a'), "Walloon"), - (('w', 'o'), "Wolof"), (('x', 'h'), "Xhosa"), (('y', 'i'), "Yiddish"), - (('y', 'o'), "Yoruba"), (('z', 'a'), "Zhuang"), (('z', 'h'), "Chinese"), - (('z', 'u'), "Zulu") - ] -{- ORMOLU_ENABLE -} From 3787e2a94d9b04eb4e7d924ffb09d36d63e262e1 Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Wed, 3 Jul 2024 14:52:52 +0700 Subject: [PATCH 3/8] Don't need orphans --- inferno-ml-server-types/src/Inferno/ML/Server/Types.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index 60b0280..e5d6b9a 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -9,7 +9,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Inferno.ML.Server.Types where From 5b07d48e74b467c4140287600f6e8bb56ed85de8 Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Wed, 3 Jul 2024 16:12:57 +0700 Subject: [PATCH 4/8] Make `Arbitrary` instance for `Version` not awful --- .../src/Inferno/ML/Server/Types.hs | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index e5d6b9a..a6d1f5e 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -24,6 +24,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec import Data.Bool (bool) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as ByteString.Char8 +import Data.Char (chr) import Data.Data (Typeable) import Data.Generics.Product (HasType (typed), the) import Data.Generics.Wrapped (wrappedFrom, wrappedTo) @@ -93,6 +94,9 @@ import Test.QuickCheck Gen, Positive (getPositive), choose, + listOf, + suchThat, + vectorOf, ) import Test.QuickCheck.Arbitrary.ADT ( ADTArbitrary (ADTArbitrary), @@ -620,7 +624,20 @@ data Version deriving anyclass (NFData, ToADTArbitrary) instance Arbitrary Version where - arbitrary = genericArbitrary + arbitrary = + Version + <$> genDigits + -- This can't be some arbitrary text, otherwise JSON parsing will fail + <*> genTags + where + genDigits :: Gen (NonEmpty Int) + genDigits = fmap (fmap abs) $ arbitrary `suchThat` ((<= 5) . length) + + genTags :: Gen [Text] + genTags = listOf asciiTextGen `suchThat` ((<= 5) . length) + where + asciiTextGen :: Gen Text + asciiTextGen = fmap Text.pack . vectorOf 5 $ chr <$> choose (97, 122) -- Compares based on digits, not on tag instance Ord Version where From 9586205a56a848ca09421ea246d65a3f92867760 Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Wed, 3 Jul 2024 16:23:57 +0700 Subject: [PATCH 5/8] Relax JSON parsing for `ModelVersion` --- inferno-ml-server-types/src/Inferno/ML/Server/Types.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index a6d1f5e..a4c0e1e 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -457,10 +457,7 @@ instance where parseJSON = withObject "ModelVersion" $ \o -> ModelVersion - -- Note that for a model serialized as JSON, the `id` must be present - -- (this assumes that a model version serialized as JSON always refers - -- to one that exists in the DB already) - <$> fmap Just (o .: "id") + <$> o .:? "id" <*> o .: "model" <*> o .: "card" <*> fmap (Oid . fromIntegral @Word64) (o .: "contents") From f66ac98df9fc394f6b612ea974695b6a9eb41e1b Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Fri, 5 Jul 2024 13:49:54 +0700 Subject: [PATCH 6/8] Get rid of `thumbnail` for now --- .../inferno-ml-server-types.cabal | 2 -- .../src/Inferno/ML/Server/Types.hs | 14 +------------- 2 files changed, 1 insertion(+), 15 deletions(-) diff --git a/inferno-ml-server-types/inferno-ml-server-types.cabal b/inferno-ml-server-types/inferno-ml-server-types.cabal index 3df91d0..c1094a0 100644 --- a/inferno-ml-server-types/inferno-ml-server-types.cabal +++ b/inferno-ml-server-types/inferno-ml-server-types.cabal @@ -66,7 +66,5 @@ library , text , time , unix - , uri-bytestring - , uri-bytestring-aeson , uuid , vector diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index a4c0e1e..41021c3 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -112,8 +112,6 @@ import Test.QuickCheck.Instances.Time () import Test.QuickCheck.Instances.UUID () import Test.QuickCheck.Instances.Vector () import Text.Read (readMaybe) -import URI.ByteString (Absolute, URIRef) -import URI.ByteString.Aeson () import Web.HttpApiData ( FromHttpApiData (parseUrlPiece), ToHttpApiData (toUrlPiece), @@ -557,8 +555,7 @@ data ModelMetadata = ModelMetadata { categories :: Vector Int, datasets :: Vector Text, metrics :: Vector Text, - baseModel :: Maybe Text, - thumbnail :: Maybe (Text, URIRef Absolute) + baseModel :: Maybe Text } deriving stock (Show, Eq, Generic) @@ -569,9 +566,6 @@ instance Arbitrary ModelMetadata where <*> arbitrary <*> arbitrary <*> arbitrary - -- For the sake of simplicity, just set this field - -- unconditionally to `Nothing` for now - <*> pure Nothing instance ToADTArbitrary ModelMetadata where toADTArbitrarySingleton _ = @@ -593,12 +587,6 @@ instance FromJSON ModelMetadata where <*> o .:? "datasets" .!= mempty <*> o .:? "metrics" .!= mempty <*> o .:? "base_model" - <*> (thumbnailP =<< o .:? "thumbnail") - where - thumbnailP :: Maybe Object -> Parser (Maybe (Text, URIRef Absolute)) - thumbnailP = \case - Nothing -> pure Nothing - Just o -> fmap Just $ (,) <$> o .: "description" <*> o .: "url" instance ToJSON ModelMetadata where toJSON = From 7709a37d13f7f12aeff6603a60da266db0493354 Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Tue, 9 Jul 2024 11:31:26 +0700 Subject: [PATCH 7/8] Use custom `Gen UTCTime` --- .../src/Inferno/ML/Server/Types.hs | 290 +++++++++++------- 1 file changed, 187 insertions(+), 103 deletions(-) diff --git a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs index 41021c3..9825992 100644 --- a/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs +++ b/inferno-ml-server-types/src/Inferno/ML/Server/Types.hs @@ -40,6 +40,7 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text.Encoding import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.UUID (UUID) import Data.Vector (Vector) import qualified Data.Vector as Vector @@ -94,7 +95,9 @@ import Test.QuickCheck Gen, Positive (getPositive), choose, + chooseInt, listOf, + oneof, suchThat, vectorOf, ) @@ -108,7 +111,6 @@ import Test.QuickCheck.Arbitrary.ADT ), genericArbitrary, ) -import Test.QuickCheck.Instances.Time () import Test.QuickCheck.Instances.UUID () import Test.QuickCheck.Instances.Vector () import Text.Read (readMaybe) @@ -218,14 +220,6 @@ data InferenceScript uid gid = InferenceScript deriving stock (Show, Eq, Generic) deriving anyclass (ToADTArbitrary) -instance - ( Arbitrary uid, - Arbitrary gid - ) => - Arbitrary (InferenceScript uid gid) - where - arbitrary = genericArbitrary - -- Newtype just for `FromRow`/`ToRow` instances. It would be possible to just -- add the instances to `inferno-types`, but then there would be a dependency -- on `postgresql-simple` @@ -265,6 +259,14 @@ instance <$> fmap wrappedTo (field @VCObjectHashRow) <*> fmap getAeson field +instance + ( Arbitrary uid, + Arbitrary gid + ) => + Arbitrary (InferenceScript uid gid) + where + arbitrary = genericArbitrary + -- | Row of the model table, parameterized by the user and group type. This -- table contains metadata for models that should not change between different -- versions, e.g. model name and permissions. A second table, 'ModelVersion', @@ -290,16 +292,6 @@ data Model uid gid = Model terminated :: Maybe UTCTime } deriving stock (Show, Eq, Generic) - deriving anyclass (ToADTArbitrary) - -instance - ( Ord gid, - Arbitrary gid, - Arbitrary uid - ) => - Arbitrary (Model uid gid) - where - arbitrary = genericArbitrary instance NFData (Model uid gid) where rnf = rwhnf @@ -384,6 +376,36 @@ instance "terminated" .= view (the @"terminated") m ] +-- Not derived generically in order to use special `Gen UTCTime` +instance + ( Ord gid, + Arbitrary gid, + Arbitrary uid + ) => + Arbitrary (Model uid gid) + where + arbitrary = + Model + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> genMUtc + +-- Can't be derived because there is (intentially) no `Arbitrary UTCTime` in scope +instance + (Arbitrary uid, Arbitrary gid, Ord gid) => + ToADTArbitrary (Model uid gid) + where + toADTArbitrarySingleton _ = + ADTArbitrarySingleton "Inferno.ML.Server.Types" "Model" + . ConstructorArbitraryPair "Model" + <$> arbitrary + + toADTArbitrary _ = + ADTArbitrary "Inferno.ML.Server.Types" "Model" + <$> sequence [ConstructorArbitraryPair "Model" <$> arbitrary] + -- | Represents rows of the model version tables; each row is linked to its -- 'Model' parent and also contains the actual contents of the model. This -- is parameterized by the user and group types as well as the type of the @@ -407,10 +429,7 @@ data ModelVersion uid gid c = ModelVersion } deriving stock (Show, Eq, Generic) -- NOTE: This may require an orphan instance for the `c` type variable - deriving anyclass (NFData, ToADTArbitrary) - -instance Arbitrary c => Arbitrary (ModelVersion uid gid c) where - arbitrary = genericArbitrary + deriving anyclass (NFData) instance ( FromField uid, @@ -484,6 +503,28 @@ instance unOid :: Oid -> Word32 unOid (Oid (CUInt x)) = x +-- Not derived generically in order to use special `Gen UTCTime` +instance Arbitrary c => Arbitrary (ModelVersion uid gid c) where + arbitrary = + ModelVersion + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> genMUtc + +-- Can't be derived because there is (intentially) no `Arbitrary UTCTime` in scope +instance (Arbitrary c) => ToADTArbitrary (ModelVersion uid gid c) where + toADTArbitrarySingleton _ = + ADTArbitrarySingleton "Inferno.ML.Server.Types" "ModelVersion" + . ConstructorArbitraryPair "ModelVersion" + <$> arbitrary + + toADTArbitrary _ = + ADTArbitrary "Inferno.ML.Server.Types" "ModelVersion" + <$> sequence [ConstructorArbitraryPair "ModelVersion" <$> arbitrary] + -- | Permissions for reading or writing a model data ModelPermissions = -- | The model can be read e.g. for inference @@ -493,9 +534,6 @@ data ModelPermissions deriving stock (Show, Eq, Generic) deriving anyclass (NFData, ToADTArbitrary) -instance Arbitrary ModelPermissions where - arbitrary = genericArbitrary - instance FromJSON ModelPermissions where parseJSON = withText "ModelPermissions" $ \case "read" -> pure ReadModel @@ -508,6 +546,9 @@ instance ToJSON ModelPermissions where ReadModel -> "read" WriteModel -> "write" +instance Arbitrary ModelPermissions where + arbitrary = genericArbitrary + -- | Full description and metadata of the model data ModelCard = ModelCard { -- | High-level, structured overview of model details and summary @@ -536,9 +577,6 @@ data ModelDescription = ModelDescription deriving stock (Show, Eq, Generic) deriving anyclass (ToJSON, NFData, ToADTArbitrary) -instance Arbitrary ModelDescription where - arbitrary = genericArbitrary - {- ORMOLU_DISABLE -} instance FromJSON ModelDescription where parseJSON = withObject "ModelDescription" $ \o -> @@ -550,6 +588,9 @@ instance FromJSON ModelDescription where <*> o .:? "evaluation" .!= mempty {- ORMOLU_ENABLE -} +instance Arbitrary ModelDescription where + arbitrary = genericArbitrary + -- | Metadata for the model, inspired by Hugging Face model card format data ModelMetadata = ModelMetadata { categories :: Vector Int, @@ -559,6 +600,25 @@ data ModelMetadata = ModelMetadata } deriving stock (Show, Eq, Generic) +instance NFData ModelMetadata where + rnf = rwhnf + +instance FromJSON ModelMetadata where + parseJSON = withObject "ModelMetadata" $ \o -> + ModelMetadata + <$> o .:? "categories" .!= mempty + <*> o .:? "datasets" .!= mempty + <*> o .:? "metrics" .!= mempty + <*> o .:? "base-model" + +instance ToJSON ModelMetadata where + toJSON = + genericToJSON + defaultOptions + { fieldLabelModifier = camelTo2 '-', + omitNothingFields = True + } + instance Arbitrary ModelMetadata where arbitrary = ModelMetadata @@ -577,25 +637,6 @@ instance ToADTArbitrary ModelMetadata where ADTArbitrary "Inferno.ML.Server.Types" "ModelMetadata" <$> sequence [ConstructorArbitraryPair "ModelMetadata" <$> arbitrary] -instance NFData ModelMetadata where - rnf = rwhnf - -instance FromJSON ModelMetadata where - parseJSON = withObject "ModelMetadata" $ \o -> - ModelMetadata - <$> o .:? "categories" .!= mempty - <*> o .:? "datasets" .!= mempty - <*> o .:? "metrics" .!= mempty - <*> o .:? "base_model" - -instance ToJSON ModelMetadata where - toJSON = - genericToJSON - defaultOptions - { fieldLabelModifier = camelTo2 '_', - omitNothingFields = True - } - -- | Similar to the @Version@ type from base, but allows for a leading @v@ and -- guarantees that there is at least one digit. Digits must be separated by @.@; -- multiple tags are allowed, separated by @-@ @@ -608,22 +649,6 @@ data Version deriving stock (Show, Eq, Generic) deriving anyclass (NFData, ToADTArbitrary) -instance Arbitrary Version where - arbitrary = - Version - <$> genDigits - -- This can't be some arbitrary text, otherwise JSON parsing will fail - <*> genTags - where - genDigits :: Gen (NonEmpty Int) - genDigits = fmap (fmap abs) $ arbitrary `suchThat` ((<= 5) . length) - - genTags :: Gen [Text] - genTags = listOf asciiTextGen `suchThat` ((<= 5) . length) - where - asciiTextGen :: Gen Text - asciiTextGen = fmap Text.pack . vectorOf 5 $ chr <$> choose (97, 122) - -- Compares based on digits, not on tag instance Ord Version where compare = comparing . view $ typed @(NonEmpty Int) @@ -647,6 +672,22 @@ instance FromField Version where instance ToField Version where toField = Escape . Text.Encoding.encodeUtf8 . showVersion +instance Arbitrary Version where + arbitrary = + Version + <$> genDigits + -- This can't be some arbitrary text, otherwise JSON parsing will fail + <*> genTags + where + genDigits :: Gen (NonEmpty Int) + genDigits = fmap (fmap abs) $ arbitrary `suchThat` ((<= 5) . length) + + genTags :: Gen [Text] + genTags = listOf asciiTextGen `suchThat` ((<= 5) . length) + where + asciiTextGen :: Gen Text + asciiTextGen = fmap Text.pack . vectorOf 5 $ chr <$> choose (97, 122) + versionP :: Attoparsec.Parser Version versionP = do void . optional $ Attoparsec.char 'v' @@ -708,16 +749,7 @@ data InferenceParam uid gid p s = InferenceParam user :: uid } deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, ToJSON, ToADTArbitrary) - -instance - ( Arbitrary s, - Arbitrary p, - Arbitrary uid - ) => - Arbitrary (InferenceParam uid gid p s) - where - arbitrary = genericArbitrary + deriving anyclass (NFData, ToJSON) {- ORMOLU_DISABLE -} instance @@ -775,6 +807,40 @@ instance ip ^. the @"user" & toField ] +-- Not derived generically in order to use special `Gen UTCTime` +instance + ( Arbitrary s, + Arbitrary p, + Arbitrary uid + ) => + Arbitrary (InferenceParam uid gid p s) + where + arbitrary = + InferenceParam + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> genMUtc + <*> arbitrary + +-- Can't be derived because there is (intentially) no `Arbitrary UTCTime` in scope +instance + ( Arbitrary s, + Arbitrary p, + Arbitrary uid + ) => + ToADTArbitrary (InferenceParam uid gid p s) + where + toADTArbitrarySingleton _ = + ADTArbitrarySingleton "Inferno.ML.Server.Types" "InferenceParam" + . ConstructorArbitraryPair "InferenceParam" + <$> arbitrary + + toADTArbitrary _ = + ADTArbitrary "Inferno.ML.Server.Types" "InferenceParam" + <$> sequence [ConstructorArbitraryPair "InferenceParam" <$> arbitrary] + -- | An 'InferenceParam' together with all of the model versions that are -- linked to it indirectly via its script. This is provided for convenience data InferenceParamWithModels uid gid p s = InferenceParamWithModels @@ -805,9 +871,6 @@ data ScriptInputType deriving stock (Show, Eq, Generic) deriving anyclass (NFData, ToADTArbitrary) -instance Arbitrary ScriptInputType where - arbitrary = genericArbitrary - instance FromJSON ScriptInputType where parseJSON = withText "ScriptInputType" $ \case "r" -> pure Readable @@ -822,6 +885,9 @@ instance ToJSON ScriptInputType where Writable -> "w" ReadableWritable -> "rw" +instance Arbitrary ScriptInputType where + arbitrary = genericArbitrary + -- | Information about execution time and resource usage. This is saved by -- @inferno-ml-server@ after script evaluation completes and can be queried -- later by using the same job identifier that was provided to the @/inference@ @@ -846,10 +912,7 @@ data EvaluationInfo uid gid p = EvaluationInfo cpu :: Word64 } deriving stock (Show, Eq, Generic) - deriving anyclass (FromJSON, ToJSON, ToADTArbitrary) - -instance Arbitrary (EvaluationInfo uid gid p) where - arbitrary = genericArbitrary + deriving anyclass (FromJSON, ToJSON) instance FromRow (EvaluationInfo uid gid p) where fromRow = @@ -871,6 +934,17 @@ instance ToRow (EvaluationInfo uid gid p) where ei ^. the @"cpu" & toField ] +-- Not derived generically in order to use special `Gen UTCTime` +instance Arbitrary (EvaluationInfo uid gid p) where + arbitrary = + EvaluationInfo + <$> arbitrary + <*> arbitrary + <*> genUtc + <*> genUtc + <*> arbitrary + <*> arbitrary + -- | A user, parameterized by the user and group types data User uid gid = User { id :: uid, @@ -894,28 +968,6 @@ newtype IPv4 = IPv4 Data.IP.IPv4 deriving stock (Generic) deriving newtype (Show, Eq, Ord, Read) -instance Arbitrary IPv4 where - arbitrary = genFromOctects - -instance ToADTArbitrary IPv4 where - toADTArbitrarySingleton _ = - ADTArbitrarySingleton "Inferno.ML.Server.Types" "IPv4" - . ConstructorArbitraryPair "IPv4" - <$> arbitrary - - toADTArbitrary _ = - ADTArbitrary "Inferno.ML.Server.Types" "IPv4" - <$> sequence [ConstructorArbitraryPair "IPv4" <$> arbitrary] - -genFromOctects :: Gen IPv4 -genFromOctects = - toIPv4 - <$> ( (,,,) <$> octetGen <*> octetGen <*> octetGen <*> octetGen - ) - -octetGen :: Gen Int -octetGen = choose (0, 255) - instance NFData IPv4 where rnf = rwhnf @@ -941,6 +993,28 @@ instance FromField IPv4 where instance ToField IPv4 where toField = Escape . ByteString.Char8.pack . show +instance Arbitrary IPv4 where + arbitrary = genFromOctects + +instance ToADTArbitrary IPv4 where + toADTArbitrarySingleton _ = + ADTArbitrarySingleton "Inferno.ML.Server.Types" "IPv4" + . ConstructorArbitraryPair "IPv4" + <$> arbitrary + + toADTArbitrary _ = + ADTArbitrary "Inferno.ML.Server.Types" "IPv4" + <$> sequence [ConstructorArbitraryPair "IPv4" <$> arbitrary] + +genFromOctects :: Gen IPv4 +genFromOctects = + toIPv4 + <$> ( (,,,) <$> octetGen <*> octetGen <*> octetGen <*> octetGen + ) + +octetGen :: Gen Int +octetGen = choose (0, 255) + toIPv4 :: (Int, Int, Int, Int) -> IPv4 toIPv4 (a, b, c, d) = IPv4 $ Data.IP.toIPv4 [a, b, c, d] @@ -1061,3 +1135,13 @@ maybeConversion f fld = maybe (returnError UnexpectedNull fld mempty) $ maybe (returnError ConversionFailed fld mempty) pure . f + +genMUtc :: Gen (Maybe UTCTime) +genMUtc = oneof [Just <$> genUtc, pure Nothing] + +-- This provides a reasonable timestamp rounded to the second, instead of +-- having fractional seconds as when using the `Arbitrary UTCTime` instance +-- from `Test.QuickCheck.Instances.Time` +genUtc :: Gen UTCTime +genUtc = + posixSecondsToUTCTime . realToFrac <$> chooseInt (1420000000, 1720000000) From fd26ef76875049d145c363d40d7628a92aa9300f Mon Sep 17 00:00:00 2001 From: Rory Tyler Hayford Date: Tue, 9 Jul 2024 13:35:12 +0700 Subject: [PATCH 8/8] Version bump, changelog --- inferno-ml-server-types/CHANGELOG.md | 4 ++++ inferno-ml-server-types/inferno-ml-server-types.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/inferno-ml-server-types/CHANGELOG.md b/inferno-ml-server-types/CHANGELOG.md index 93d9a49..4750a63 100644 --- a/inferno-ml-server-types/CHANGELOG.md +++ b/inferno-ml-server-types/CHANGELOG.md @@ -1,6 +1,10 @@ # Revision History for inferno-ml-server-types *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.9.0 +* Add `Arbitrary`/`ToADTArbitrary` instances for most types +* Simplify `ModelMetadata` + ## 0.8.0 * Store model IDs in script metadata mapped to model name * Remove model IDs from `InferenceParam` diff --git a/inferno-ml-server-types/inferno-ml-server-types.cabal b/inferno-ml-server-types/inferno-ml-server-types.cabal index c1094a0..3701aa5 100644 --- a/inferno-ml-server-types/inferno-ml-server-types.cabal +++ b/inferno-ml-server-types/inferno-ml-server-types.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: inferno-ml-server-types -version: 0.8.0 +version: 0.9.0 synopsis: Types for Inferno ML server description: Types for Inferno ML server homepage: https://github.com/plow-technologies/inferno.git#readme