diff --git a/datarobot.cabal b/datarobot.cabal --- a/datarobot.cabal +++ b/datarobot.cabal @@ -1,9 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: d659e0f40eb6ebe5c04a98ee4a259744bfffb63a3269437ce8661118f03926d4 name: datarobot -version: 0.1.1 +version: 1.0.0 synopsis: Client for DataRobot API description: Client for DataRobot API homepage: https://github.com/orbital/datarobot-haskell#readme @@ -31,9 +33,11 @@ DataRobot.Predict DataRobot.PredictResponse DataRobot.Types + other-modules: + Paths_datarobot build-depends: - base >=4.7 && <5 - , aeson + aeson + , base >=4.7 && <5 , bytestring , exceptions , microlens @@ -54,9 +58,10 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 - , aeson + aeson + , base , bytestring + , datarobot , exceptions , microlens , network-uri @@ -67,6 +72,6 @@ , unordered-containers , vector , wreq - , base - , datarobot + other-modules: + Paths_datarobot default-language: Haskell2010 diff --git a/src/DataRobot.hs b/src/DataRobot.hs --- a/src/DataRobot.hs +++ b/src/DataRobot.hs @@ -16,8 +16,7 @@ , Fields , PredictError(..) , PredictResult(..) - , responseResult - , classProbability + , predictionValue diff --git a/src/DataRobot/Predict.hs b/src/DataRobot/Predict.hs --- a/src/DataRobot/Predict.hs +++ b/src/DataRobot/Predict.hs @@ -11,14 +11,14 @@ import Lens.Micro ((?~), (.~)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Catch (MonadThrow) -import Data.Aeson (Value(..)) +import Data.Aeson (Value(..), encode) import Data.Function ((&)) import qualified Data.HashMap.Strict as HM import qualified Data.Vector as V import Data.String.Conversions (cs) import DataRobot.Types -import DataRobot.API (parseResponse, endpoint) +import DataRobot.API (endpoint) import DataRobot.PredictResponse import Network.URI (URI(..)) @@ -34,8 +34,7 @@ url = predictURI (baseURLPredict c) pid mid body = Array $ V.singleton $ Object $ HM.fromList o r <- liftIO $ Wreq.postWith opts url body - pr <- parseResponse r - pure $ responseResult pr + pure $ parseResponse r httpOptions :: Credentials -> Wreq.Options diff --git a/src/DataRobot/PredictResponse.hs b/src/DataRobot/PredictResponse.hs --- a/src/DataRobot/PredictResponse.hs +++ b/src/DataRobot/PredictResponse.hs @@ -4,22 +4,32 @@ module DataRobot.PredictResponse ( PredictError(..) , PredictResult(..) - , responseResult - , classProbability + , PredictionValue(..) + , parseResponse + , predictionValue ) where - -import Control.Applicative ((<|>)) import Control.Monad.Catch (Exception) -import Data.Aeson (FromJSON(..), ToJSON, Value) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) +import Data.Aeson (FromJSON(..), ToJSON, Value(..), decode, defaultOptions, genericParseJSON, withObject, (.:), eitherDecode) +import Data.Aeson.Types (Options(..), typeMismatch) +import Data.List (find) +import Data.Maybe (fromMaybe, maybe) import Data.Text (Text) +import Data.String.Conversions (cs) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Safe (headMay) +import Lens.Micro ((^.)) +import Network.Wreq (Response, responseBody, responseHeader) +import Data.ByteString.Lazy (ByteString) + +underscorePrefixOptions :: Options +underscorePrefixOptions = + defaultOptions { fieldLabelModifier = dropWhile (== '_') } + +type Code = Int + data PredictError = APIError Code Text | MissingPrediction @@ -28,67 +38,92 @@ instance Exception PredictError -newtype PredictResponse = PredictResponse (Either PredictFailure PredictSuccess ) - deriving (Show, Eq) +-- Datarobot successful response +data ResponseSuccess = ResponseSuccess + { _data :: [Prediction] + } deriving (Eq, Show, Generic) -instance FromJSON PredictResponse where - parseJSON v = PredictResponse <$> - ((Right <$> parseJSON v) <|> (Left <$> parseJSON v)) +instance FromJSON ResponseSuccess where + parseJSON = genericParseJSON underscorePrefixOptions -type Code = Int -data PredictFailure = PredictFailure - { code :: Code - , status :: Text +-- Datarobot failure response +data ResponseFailure = ResponseFailure + { _message :: Text } deriving (Show, Eq, Generic) -instance FromJSON PredictFailure +instance FromJSON ResponseFailure where + parseJSON = genericParseJSON underscorePrefixOptions -data PredictSuccess = PredictSuccess - { predictions :: [Prediction] - , execution_time :: Float - , model_id :: Text - -- , task :: Text - } deriving (Show, Eq, Generic) -instance FromJSON PredictSuccess +-- A single prediction value +data PredictionValue = PredictionValue + { label :: Text + , value :: Float + } deriving (Eq, Show, Generic) +instance ToJSON PredictionValue +instance FromJSON PredictionValue where + parseJSON = withObject "prediction_value" $ \o -> do + value' <- o .: "value" + label' <- labelText =<< o .: "label" + return $ PredictionValue label' value' + where + -- Always treat the label as text even though the JSON also allows numbers + -- This makes key-based lookup easier on the API consumer + labelText (Number n) = pure $ (cs .show) n + labelText (String s) = pure s + labelText invalid = typeMismatch "label" invalid + + +-- Combination of prediction values and prediction label data Prediction = Prediction - { prediction :: Value - , class_probabilities :: Maybe (HashMap Text Float) - } deriving (Show, Eq, Generic) + { _prediction :: Value -- label or float + , _predictionValues :: Maybe [PredictionValue] + } deriving (Eq, Show, Generic) -instance FromJSON Prediction +instance FromJSON Prediction where + parseJSON = genericParseJSON underscorePrefixOptions -- | Result from the prediction - data PredictResult = PredictResult - { prediction :: Value + { prediction :: Value , predictionTimeMs :: Float - , modelId :: Text - , classProbabilities :: Maybe (HashMap Text Float) + , predictionValues :: Maybe [PredictionValue] } deriving (Show, Eq, Generic) -instance ToJSON PredictResult -responseResult :: PredictResponse -> Either PredictError PredictResult -responseResult (PredictResponse (Right ps)) = - fromMaybe (Left MissingPrediction) $ do - p <- headMay (predictions ps) - return $ Right $ PredictResult - { prediction = prediction (p :: Prediction) - , predictionTimeMs = execution_time ps - , modelId = model_id ps - , classProbabilities = class_probabilities p - } -responseResult (PredictResponse (Left pf)) = - Left $ APIError (code pf) (status pf) +-- Create a result for a successful response +responseSuccess :: Float -> ResponseSuccess -> Either PredictError PredictResult +responseSuccess et rs = + maybe (Left MissingPrediction) Right $ do + p <- headMay (_data rs) + pure PredictResult + { prediction = _prediction p + , predictionValues = _predictionValues p + , predictionTimeMs = et + } +-- Create a result for a failed response +responseFailure :: Text -> Either PredictError PredictResult +responseFailure e = Left $ APIError 422 e -classProbability :: Text -> PredictResult -> Maybe Float -classProbability c r = do - cps <- classProbabilities r - HM.lookup c cps +-- Parse the entire prediction response +-- This is needed because some of the data is delivered in the body and some is delivered via headers +parseResponse :: Response ByteString -> Either PredictError PredictResult +parseResponse r = do + either (responseFailure . cs) (responseSuccess tm) $ eitherDecode b + where + b = r ^. responseBody + et = r ^. responseHeader "X-DataRobot-Execution-Time" + tm = fromMaybe 0.0 $ decode (cs et) + +-- Find a prediction value probability from a given label +predictionValue :: Text -> PredictResult -> Maybe Float +predictionValue c r = do + ps <- predictionValues r + pd <- find ((== c) . label) ps + pure $ value pd