never executed always true always false

    1 {-# LANGUAGE InstanceSigs #-}
    2 {-# LANGUAGE OverloadedStrings #-}
    3 
    4 {- |
    5 Module      : NITTA.Synthesis.MlBackend.Api
    6 Description : ML backend API client (DTOs, request wrappers)
    7 Copyright   : (c) Ilya Burakov, 2023
    8 License     : BSD3
    9 Maintainer  : aleksandr.penskoi@gmail.com
   10 Stability   : experimental
   11 -}
   12 module NITTA.Synthesis.MlBackend.Client (
   13     ScoringInput (..),
   14     ScoringTarget (..),
   15     predictScoresIO,
   16 ) where
   17 
   18 import Data.Aeson
   19 import Data.String.ToString
   20 import Data.Text.Encoding qualified as T
   21 import GHC.Generics
   22 import NITTA.Synthesis.Types hiding (scores)
   23 import NITTA.UIBackend.ViewHelper (NodeView, VarValTimeJSON)
   24 import Network.HTTP.Client.Conduit
   25 import Network.HTTP.Simple
   26 
   27 data ScoringTarget = ScoringTargetSid Sid | ScoringTargetAll
   28 
   29 instance ToJSON ScoringTarget where
   30     toJSON (ScoringTargetSid sid) = toJSON sid
   31     toJSON ScoringTargetAll = toJSON ("all" :: String)
   32 
   33 data ScoringInput tag v x t = ScoringInput
   34     { scoringTarget :: ScoringTarget
   35     , nodes :: [NodeView tag v x t]
   36     }
   37     deriving (Generic)
   38 
   39 instance (VarValTimeJSON v x t, ToJSON tag) => ToJSON (ScoringInput tag v x t)
   40 
   41 newtype PostScoreRequestBody tag v x t = PostScoreRequestBody
   42     { inputs :: [ScoringInput tag v x t]
   43     }
   44     deriving (Generic)
   45 
   46 instance (VarValTimeJSON v x t, ToJSON tag) => ToJSON (PostScoreRequestBody tag v x t)
   47 
   48 newtype MlBackendResponse d = MlBackendResponse
   49     { responseData :: d
   50     }
   51     deriving (Show, Generic)
   52 
   53 instance FromJSON d => FromJSON (MlBackendResponse d) where
   54     parseJSON = withObject "MlBackendResponse" $ \obj ->
   55         MlBackendResponse <$> obj .: "data" -- we are using the parameter's FromJSON
   56 
   57 instance ToJSON d => ToJSON (MlBackendResponse d) where
   58     toJSON :: MlBackendResponse d -> Value
   59     toJSON (MlBackendResponse{responseData}) = object ["data" .= responseData]
   60 
   61 newtype PostScoreResponseData = PostScoreResponseData
   62     {scores :: [[Float]]}
   63     deriving (Show, Generic)
   64 
   65 -- TODO: GeneralizedNewtypeDeriving vs DeriveAnyClass conflict? declaring instance manually for now
   66 instance ToJSON PostScoreResponseData
   67 instance FromJSON PostScoreResponseData
   68 
   69 getDefaultRequestIO baseUrl = do
   70     parseRequest (toString baseUrl)
   71 
   72 getScoreRequestIO baseUrl modelName scoringInputs =
   73     let path = T.encodeUtf8 $ "/models/" <> modelName <> "/score"
   74         body = PostScoreRequestBody{inputs = scoringInputs}
   75      in do
   76             setRequestMethod "POST"
   77                 . setRequestPath path
   78                 . setRequestBodyJSON body
   79                 <$> getDefaultRequestIO baseUrl
   80 
   81 predictScoresIO modelName baseUrl inputs = do
   82     request <- getScoreRequestIO baseUrl modelName inputs
   83     response <- httpJSON request
   84     return $ scores $ responseData $ getResponseBody response