Query.hs

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict              #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
module Experimenter.Result.Query
    ( loadExperiments
    , loadExperimentResults
    , loadExperimentsResults
    , loadPreparationInputWhere
    , loadPreparationMeasuresWhere
    , loadPreparationAggregateWhere
    , loadReplicationWarmUpInputWhere
    , loadReplicationWarmUpMeasuresWhere
    , loadReplicationWarmUpAggregateWhere
    , loadReplicationInputWhere
    , loadReplicationMeasuresWhere
    , loadReparationAggregateWhere
    , loadResDataEndState
    , loadResDataStartState
    , loadParamSetup
    , deserialise
    , mDeserialise
    , setParams
    , fromRandGen
    , toRandGen
    , serialiseSeed
    , deserialiseSeed
    , StartStateType (..)
    , EndStateType (..)
    , setResDataStartState
    , setResDataEndState
    ) where

import           Conduit                     as C
import           Control.DeepSeq
import           Control.Lens                (view)
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.Trans.Maybe
import           Data.ByteString             (ByteString)
import qualified Data.ByteString             as B
import qualified Data.Conduit.List           as CL
import           Data.Either                 (isLeft)
import           Data.Function               (on)
import qualified Data.List                   as L
import           Data.Maybe                  (fromMaybe)
import           Data.Serialize              as S (Serialize, get, put, runGet, runPut)
import qualified Data.Text                   as T
import           Data.Time                   (getCurrentTime)
import           Data.Vector.Serialize       ()
import qualified Data.Vector.Unboxed         as V
import           Data.Word                   (Word32)
import qualified Database.Esqueleto          as E
import           Database.Persist            as P
import           Database.Persist.Postgresql (SqlBackend)
import           Database.Persist.Sql        (transactionSave)
import           Prelude                     hiding (exp)
import           System.Random.MWC

import           Experimenter.Availability
import           Experimenter.DB
import           Experimenter.Experiment
import           Experimenter.Input
import           Experimenter.Measure
import           Experimenter.Models
import           Experimenter.Parameter
import           Experimenter.Result.Type
import           Experimenter.Setting
import           Experimenter.StepResult
import           Experimenter.Util


data EndStateType
  = EndStatePrep !(Key PrepResultData)
  | EndStateWarmUp !(Key WarmUpResultData)
  | EndStateRep !(Key RepResultData)


data StartStateType
  = StartStatePrep !(Key PrepResultData)
  | StartStateWarmUp !(Key WarmUpResultData)
  | StartStateRep !(Key RepResultData)


loadExperimentsResults :: (ExperimentDef a) => ExperimentSetting -> InputState a -> a -> Key Exps -> DB (ExpM a) (Maybe (Experiments a))
loadExperimentsResults setup initInpSt initSt key =
  runMaybeT $ do
    e <- MaybeT $ P.get key
    exps <- lift (L.sortBy (compare `on` view experimentNumber) <$> loadExperimentList key)
    expInfoParams <- lift (map entityVal <$> selectList [ExpsInfoParamExps ==. key] [])
    eSetup <- lift (fromMaybe (error "Setup not found. Your DB is corrupted!") <$> getBy (UniqueExpsSetup key))
    infoParms <- lift (mapM fromInfoParam expInfoParams)
    return $
      Experiments
        key
        (view expsName e)
        (view expsStartTime e)
        (view expsEndTime e)
        (entityVal eSetup)
        (parameters initSt)
        (concat infoParms)
        initSt
        initInpSt
        exps
  where
    infoParams = view experimentInfoParameters setup
    fromInfoParam (ExpsInfoParam _ n bs) =
      case L.find ((== n) . infoParameterName) infoParams of
        Nothing -> do
          $(logDebug) $ "Could not find parameter " <> n <> " in settings while loading values from the DB. It will not be reported therefore!"
          return []
        Just (ExperimentInfoParameter _ v) -> return [ExperimentInfoParameter n (fromEitherDef v $ S.runGet S.get bs)]
    fromEitherDef _ (Right x) = x
    fromEitherDef d (Left _)  = d


loadExperiments :: (ExperimentDef a) => ExperimentSetting -> InputState a -> a -> DB (ExpM a) (Experiments a)
loadExperiments setup initInpSt initSt = do
  eExp <- getOrCreateExps setup initInpSt initSt
  let e = entityVal eExp
  exps <- L.sortBy (compare `on` view experimentNumber) <$> loadExperimentList (entityKey eExp)
  eSetup <- fromMaybe (error "Setup not found. Your DB is corrupted!") <$> getBy (UniqueExpsSetup (entityKey eExp))
  return $!!
    Experiments
      (entityKey eExp)
      (view expsName e)
      (view expsStartTime e)
      (view expsEndTime e)
      (entityVal eSetup)
      (parameters initSt)
      (view experimentInfoParameters setup)
      initSt
      initInpSt
      exps


loadExperimentList :: (ExperimentDef a) => Key Exps -> DB (ExpM a) [Experiment a]
loadExperimentList expsKey = selectList [ExpExps ==. expsKey] [] >>= mapM mkExperiment
    where mkExperiment (Entity k exp) = do
            paramSetting <- loadParamSetup k
            Experiment k (view expNumber exp) (view expStartTime exp) (view expEndTime exp) paramSetting <$> loadExperimentResults k


mDeserialise :: (MonadIO m, MonadLogger m ,Serialize a) => T.Text -> Maybe ByteString -> m (Maybe (Maybe a))
mDeserialise n mBs = sequence (deserialise n <$> mBs)


deserialise :: (MonadIO m, MonadLogger m, Serialize a) => T.Text -> ByteString -> m (Maybe a)
deserialise n bs =
  let !res = runGet S.get bs
   in case res of
        Left err -> do
          $(logError) $ "Could not deserialise " <> n <> "! Discarding saved experiment result. Data length: " <> tshow (B.length bs) <> ". Error Message: " <> tshow err
          return Nothing
        Right r -> return $! Just r


loadExperimentResults :: (ExperimentDef a) => Key Exp -> DB (ExpM a) [ExperimentResult a]
loadExperimentResults kExp = do
  xs <- selectList [ExpResultExp ==. kExp] [Asc ExpResultRepetition]
  mapM loadExperimentResult xs


loadResDataEndState ::
     forall a. (ExperimentDef a)
  => Key Exp
  -> EndStateType
  -> DB (ExpM a) (Maybe a)
loadResDataEndState expId endSt = do
  !parts <-
    fmap force $!
    case endSt of
      EndStatePrep k -> fmap (view prepEndStatePartData . entityVal) <$> selectList [PrepEndStatePartResultData ==. k] [Asc PrepEndStatePartNumber]
      EndStateWarmUp k -> fmap (view warmUpEndStatePartData . entityVal) <$> selectList [WarmUpEndStatePartResultData ==. k] [Asc WarmUpEndStatePartNumber]
      EndStateRep k -> fmap (view repEndStatePartData . entityVal) <$> selectList [RepEndStatePartResultData ==. k] [Asc RepEndStatePartNumber]
  !res <-
    if null parts
      then return Nothing
      else do
        !mSer <- deserialise (T.pack "end state") (B.concat parts)
        lift $! lift $! lift $! maybe (return Nothing) (fmap Just . deserialisable) mSer
  force <$!> traverse (setParams expId) res

loadResDataStartState :: (ExperimentDef a) => Key Exp -> StartStateType -> DB (ExpM a) a
loadResDataStartState expId startSt = do
  !parts <-
    fmap force $!
    case startSt of
      StartStatePrep k -> fmap (view prepStartStatePartData . entityVal) <$> selectList [PrepStartStatePartResultData ==. k] [Asc PrepStartStatePartNumber]
      StartStateWarmUp k -> fmap (view warmUpStartStatePartData . entityVal) <$> selectList [WarmUpStartStatePartResultData ==. k] [Asc WarmUpStartStatePartNumber]
      StartStateRep k -> fmap (view repStartStatePartData . entityVal) <$> selectList [RepStartStatePartResultData ==. k] [Asc RepStartStatePartNumber]
  !res <-
    if null parts
      then error "Could not get start state"
      else do
        !ser <- fromMaybe (error "Could not deserialise start state ") <$> deserialise "prep start state" (B.concat parts)
        lift $! lift $! lift $! deserialisable ser
  force <$!> setParams expId res


setResDataEndState :: (MonadIO m) => EndStateType -> Maybe ByteString -> ReaderT SqlBackend m ()
setResDataEndState (EndStatePrep k) (Just bs) = do
  -- liftIO $ B.writeFile "/tmp/EndState" bs
  let parts = splitState bs
  mapM_ (\(nr, part) -> upsert (PrepEndStatePart k nr part) [PrepEndStatePartData =. part]) (zip [0..] parts)
  deleteWhere [PrepEndStatePartResultData ==. k, PrepEndStatePartNumber >=. length parts]
setResDataEndState (EndStateWarmUp k) (Just bs) = do
  let parts = splitState bs
  mapM_ (\(nr, part) -> upsert (WarmUpEndStatePart k nr part) [WarmUpEndStatePartData =. part]) (zip [0..] parts)
  deleteWhere [WarmUpEndStatePartResultData ==. k, WarmUpEndStatePartNumber >=. length parts]
setResDataEndState (EndStateRep k) (Just bs) = do
  let parts = splitState bs
  mapM_ (\(nr, part) -> upsert (RepEndStatePart k nr part) [RepEndStatePartData =. part]) (zip [0..] parts)
  deleteWhere [RepEndStatePartResultData ==. k, RepEndStatePartNumber >=. length parts]
setResDataEndState (EndStatePrep k) Nothing = deleteWhere [PrepEndStatePartResultData ==. k]
setResDataEndState (EndStateWarmUp k) Nothing = deleteWhere [WarmUpEndStatePartResultData ==. k]
setResDataEndState (EndStateRep k) Nothing = deleteWhere [RepEndStatePartResultData ==. k]


setResDataStartState :: (MonadIO m) => StartStateType -> ByteString -> ReaderT SqlBackend m ()
setResDataStartState (StartStatePrep k) bs = do
  let parts = splitState bs
  mapM_ (\(nr, part) -> upsert (PrepStartStatePart k nr part) [PrepStartStatePartData =. part]) (zip [0..] parts)
  deleteWhere [PrepStartStatePartResultData ==. k, PrepStartStatePartNumber >=. length parts]
setResDataStartState (StartStateWarmUp k) bs = do
  let parts = splitState bs
  mapM_ (\(nr, part) -> upsert (WarmUpStartStatePart k nr part) [WarmUpStartStatePartData =. part]) (zip [0..] parts)
  deleteWhere [WarmUpStartStatePartResultData ==. k, WarmUpStartStatePartNumber >=. length parts]
setResDataStartState (StartStateRep k) bs = do
  let parts = splitState bs
  mapM_ (\(nr, part) -> upsert (RepStartStatePart k nr part) [RepStartStatePartData =. part]) (zip [0..] parts)
  deleteWhere [RepStartStatePartResultData ==. k, RepStartStatePartNumber >=. length parts]


splitState :: ByteString -> [ByteString]
splitState bs
  | B.null bs = []
  | otherwise = B.take splitLength bs : splitState (B.drop splitLength bs)
  where
    splitLength = 128000000     -- 128MB as ByteString is composed of Word8 (8-bit unsigned integer = 1 byte) elements


setParams :: (MonadIO m, MonadLogger m, ExperimentDef a) => Key Exp -> a -> ReaderT SqlBackend m a
setParams expId st = do
  paramSettings <- loadParamSetup expId
  foldM setParams' st paramSettings
  where setParams' !state !(ParameterSetting n bs _ _) =
           case L.find (\(ParameterSetup name _ _ _ _ _ _) -> name == n) paramSetup of
             Nothing -> do
               $(logError) $ "Could not find parameter with name " <> n <> " in the current parameter setting. Thus it cannot be modified!"
               return state
             Just (ParameterSetup _ setter _ _ _ _ _) ->
               case runGet S.get bs of
                 Left err -> error $ "Could not read value of parameter " <> T.unpack n <> ". Aborting! Serializtion error was: " ++ err
                 Right val -> do
                   $(logInfo) $ "Loaded parameter '" <> n <> "' value: " <> tshow val
                   return $ setter val state
        paramSetup = parameters st

loadExperimentResult :: forall a . (ExperimentDef a) => Entity ExpResult -> DB (ExpM a) (ExperimentResult a)
loadExperimentResult (Entity k (ExpResult expId rep mPrepResDataId)) = do
  !mEPrepResData <- fmap join $ sequence $ P.getEntity <$> mPrepResDataId
  !prepRes <-
    case mEPrepResData of
      Nothing -> return Nothing
      Just (Entity resDataKey (PrepResultData startT endT startRandGenBS endRandGenBS startInpStBS endInpStBS)) -> do
        let !startSt = AvailableOnDemand (loadResDataStartState expId (StartStatePrep resDataKey))
        let !endSt = AvailableOnDemand (loadResDataEndState expId (EndStatePrep resDataKey))
        !mStartInpSt <- deserialise "prep start input state" startInpStBS
        !mEndInpSt <- mDeserialise "prep end input state" endInpStBS
        !inpCount <- loadPreparationInputCount resDataKey
        !resultCount <- loadPrepartionMeasuresCount resDataKey
        !startRandG <- toRandGen startRandGenBS
        !endRandG <- maybe (return Nothing) (fmap Just . toRandGen) endRandGenBS
        let !inputVals = AvailableListOnDemand (inpCount, loadPreparationInputWhere resDataKey)
        let !res = AvailableListOnDemand (resultCount, loadPreparationMeasuresWhere resDataKey)
        return $!! ResultData (ResultDataPrep resDataKey) startT endT startRandG endRandG inputVals res startSt endSt <$> mStartInpSt <*> mEndInpSt
  !evalRes <- loadReplicationResults expId k
  return $!! ExperimentResult k rep prepRes evalRes


serialiseSeed :: Seed -> ByteString
serialiseSeed seed = S.runPut $ S.put (fromSeed seed :: V.Vector Word32)

deserialiseSeed :: ByteString -> Seed
deserialiseSeed bs = toSeed (fromRight $ S.runGet S.get bs :: V.Vector Word32)
  where fromRight (Right s) = s
        fromRight (Left err) = error $ "Could not deserialise random generator. Error Message: " <> err

fromRandGen :: (MonadIO m) => GenIO -> m ByteString
fromRandGen ran = do
  vec <- liftIO (fromSeed <$> save ran)
  return $ S.runPut (S.put vec)


toRandGen :: (MonadIO m) => ByteString -> m GenIO
toRandGen bs =
  case S.runGet S.get bs of
    Left err -> error $ "Could not deserialise random generator. Error Message: " <> err
    Right (vec :: V.Vector Word32) -> liftIO (restore $ toSeed vec)


loadParamSetup :: (MonadIO m) => Key Exp -> ReaderT SqlBackend m [ParameterSetting a1]
loadParamSetup kExp =
  L.sortBy (compare `on` view parameterSettingName) . map (mkParameterSetting' . entityVal) <$>
  E.select (E.from $ \pm -> E.where_ (pm E.^. ParamSettingExp E.==. E.val kExp) >> return pm)
  where
    mkParameterSetting' (ParamSetting _ n v b design) = ParameterSetting n v b (toEnum design)

-- fromCount :: [E.Value Int] -> Int
-- fromCount = fromMaybe 0 . listToMaybe . fmap (\(E.Value v) -> v)

loadPreparationInputCount  :: (MonadIO m) => Key PrepResultData -> ReaderT SqlBackend m Int
loadPreparationInputCount kExpRes = count [PrepInputPrepResultData ==. kExpRes]

loadPreparationInputWhere :: (MonadIO m, ExperimentDef a) => Key PrepResultData -> AvailabilityListWhere -> ConduitM () (Input a) (DB m) ()
loadPreparationInputWhere kExpRes (PrepInputWhere where') = do
  let src =
        E.selectSource $
        E.from $ \(prepI, prepIV) -> do
          E.where_ (prepI E.^. PrepInputId E.==. prepIV E.^. PrepInputValuePrepInput)
          E.where_ (prepI E.^. PrepInputPrepResultData E.==. E.val kExpRes)
          where' prepI prepIV
          return (prepI, prepIV)
  src C..| C.mapMC mkInput C..| sequenceC []
  -- sequence <$> mapM mkInput res
  where
    mkInput :: (MonadIO m, MonadLogger m, ExperimentDef a) => (Entity PrepInput, Entity PrepInputValue) -> m (Maybe (Input a))
    mkInput (Entity _ (PrepInput _ p), Entity _ (PrepInputValue _ v)) = do
      v' <- deserialise "prep input value" v
      return $ Input p <$> v'
loadPreparationInputWhere kExpRes GetAll = loadPreparationInputWhere kExpRes (PrepInputWhere (\_ _ -> return ()))
loadPreparationInputWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepInputWhere was expected"


sequenceC :: Monad m => [Maybe o] -> ConduitT (Maybe o) o m ()
sequenceC xs = do
      mx <- await
      case mx of
        Nothing -> CL.sourceList (fromMaybe [] $ sequence $ reverse xs)
        Just x  -> sequenceC (x:xs)


loadPrepartionMeasuresCount :: (MonadIO m) => Key PrepResultData -> DB m Int
loadPrepartionMeasuresCount kExpRes = count [PrepMeasurePrepResultData ==. kExpRes]

-- loadPrepartionMeasures :: (MonadIO m) => Key PrepResultData -> ConduitT () Measure (DB m) ()
-- loadPrepartionMeasures = loadPrepartionMeasuresWith (\_ _ -> return ())

loadPreparationMeasuresWhere :: (MonadIO m) => Key PrepResultData -> AvailabilityListWhere -> ConduitT () Measure (DB m) ()
loadPreparationMeasuresWhere kExpRes (PrepMeasureWhere where') = do
  let src =
        E.selectSource $
        E.from $ \(prepM, prepRS) -> do
          E.where_ (prepM E.^. PrepMeasureId E.==. prepRS E.^. PrepResultStepMeasure)
          E.where_ (prepM E.^. PrepMeasurePrepResultData E.==. E.val kExpRes)
          where' prepM prepRS
          E.orderBy [E.asc (prepM E.^. PrepMeasurePeriod)]
          return (prepM, prepRS)
  src C..| C.mapC mkMeasure C..| CL.groupBy ((==) `on` view measurePeriod) C..| C.mapC combineMeasures
  -- return $ map combineMeasures $ L.groupBy ((==) `on` view measurePeriod) $ map mkMeasure res
  where
    mkMeasure (Entity _ (PrepMeasure _ p), Entity _ (PrepResultStep _ n x y)) = Measure p [StepResult n x y]
    combineMeasures xs@(Measure p _:_) = Measure p (concatMap (view measureResults) xs)
    combineMeasures _                  = error "not possible"
loadPreparationMeasuresWhere kExpRes GetAll = loadPreparationMeasuresWhere kExpRes (PrepMeasureWhere (\_ _ -> return ()))
loadPreparationMeasuresWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepMeasuresWhere was expected"


loadPreparationAggregateWhere :: (MonadIO m) => Key PrepResultData -> AggregateFunction -> AvailabilityListWhere -> DB m Double
loadPreparationAggregateWhere kExpRes agg (PrepMeasureWhere where') =
  fmap (fromMaybe 0 . E.unValue . head) $
  E.select $
  E.from $ \(prepM, prepRS) -> do
    E.where_ (prepM E.^. PrepMeasureId E.==. prepRS E.^. PrepResultStepMeasure)
    E.where_ (prepM E.^. PrepMeasurePrepResultData E.==. E.val kExpRes)
    where' prepM prepRS
    return (agg $ prepRS E.^. PrepResultStepYValue)
loadPreparationAggregateWhere kExpRes agg GetAll = loadPreparationAggregateWhere kExpRes agg (PrepMeasureWhere (\_ _ -> return ()))
loadPreparationAggregateWhere _ _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where loadPreparationAggregateWhere was expected"


loadReplicationResults :: (ExperimentDef a) => Key Exp -> Key ExpResult -> DB (ExpM a) [ReplicationResult a]
loadReplicationResults expId kExpRes = do
  xs <- selectList [RepResultExpResult ==. kExpRes] [Asc RepResultRepNr]
  mapM (loadReplicationResult expId) xs


loadReplicationResult :: (ExperimentDef a) => Key Exp -> Entity RepResult -> DB (ExpM a) (ReplicationResult a)
loadReplicationResult expId (Entity k (RepResult _ repNr mWmUpResId mRepResId)) = do
  !mWmUpRes <- fmap join $ sequence $ P.getEntity <$> mWmUpResId
  !mRepRes <- fmap join $ sequence $ P.getEntity <$> mRepResId
  !wmUp <-
    case mWmUpRes of
      Nothing    -> return Nothing
      Just eWmUp -> mkWmUp eWmUp
  !rep <-
    case mRepRes of
      Nothing   -> return Nothing
      Just eRep -> mkRep eRep
  return $!! ReplicationResult k repNr wmUp rep
  where
    mkWmUp (Entity wmUpResKey wmUpRes) = do
      let wmUpStartTime = view warmUpResultDataStartTime wmUpRes
      let wmUpEndTime = view warmUpResultDataEndTime wmUpRes
      !wmUpStartRandGen <- toRandGen (view warmUpResultDataStartRandGen wmUpRes)
      !wmUpEndRandGen <- maybe (return Nothing) (fmap Just . toRandGen) (view warmUpResultDataEndRandGen wmUpRes)
      let !wmUpStartSt = AvailableOnDemand (loadResDataStartState expId (StartStateWarmUp wmUpResKey))
      let !wmUpEndSt = AvailableOnDemand (loadResDataEndState expId (EndStateWarmUp wmUpResKey))
      !mWmUpStartInpSt <- deserialise "warm up start input state" (view warmUpResultDataStartInputState wmUpRes)
      !mWmUpEndInpSt <- mDeserialise "warm up end input state" (view warmUpResultDataEndInputState wmUpRes)
      !wmUpInpValsCount <- loadReplicationWarmUpInputCount wmUpResKey
      !wmUpMeasuresCount <- loadReplicationWarmUpMeasuresCount wmUpResKey
      let !wmUpInpVals = AvailableListOnDemand (wmUpInpValsCount, loadReplicationWarmUpInputWhere wmUpResKey)
          !wmUpMeasures = AvailableListOnDemand (wmUpMeasuresCount, loadReplicationWarmUpMeasuresWhere wmUpResKey)
      return $!
        ResultData (ResultDataWarmUp wmUpResKey) wmUpStartTime wmUpEndTime wmUpStartRandGen wmUpEndRandGen wmUpInpVals wmUpMeasures wmUpStartSt wmUpEndSt <$> mWmUpStartInpSt <*>
        mWmUpEndInpSt
    mkRep (Entity repResKey repRes) = do
      let repStartTime = view repResultDataStartTime repRes
      let repEndTime = view repResultDataEndTime repRes
      !repStartRandGen <- toRandGen (view repResultDataStartRandGen repRes)
      !repEndRandGen <- maybe (return Nothing) (fmap Just . toRandGen) (view repResultDataEndRandGen repRes)
      !mRepStartInpSt <- deserialise "rep start input state" (view repResultDataStartInputState repRes)
      !mRepEndInpSt <- mDeserialise "rep end input state" (view repResultDataEndInputState repRes)
      !repInpValsCount <- loadReplicationInputCount repResKey
      !repMeasuresCount <- loadReplicationMeasuresCount repResKey
      let !repInpVals = AvailableListOnDemand (repInpValsCount, loadReplicationInputWhere repResKey)
          !repMeasures = AvailableListOnDemand (repMeasuresCount, loadReplicationMeasuresWhere repResKey)
      let !repStartSt = AvailableOnDemand (loadResDataStartState expId (StartStateRep repResKey))
      let !repEndSt = AvailableOnDemand (loadResDataEndState expId (EndStateRep repResKey))
      return $!
        ResultData (ResultDataRep repResKey) repStartTime repEndTime repStartRandGen repEndRandGen repInpVals repMeasures repStartSt repEndSt <$> mRepStartInpSt <*> mRepEndInpSt


loadReplicationWarmUpInputCount :: (MonadIO m) => Key WarmUpResultData -> ReaderT SqlBackend m Int
loadReplicationWarmUpInputCount kExpRes = count [WarmUpInputRepResult ==. kExpRes]


loadReplicationWarmUpInputWhere :: (ExperimentDef a, MonadIO m) => Key WarmUpResultData -> AvailabilityListWhere -> ConduitT () (Input a) (DB m) ()
loadReplicationWarmUpInputWhere kExpRes (WarmUpInputWhere where') = do
  let src =
       E.selectSource $
       E.from $ \(warmUpI, warmUpIV) -> do
         E.where_ (warmUpI E.^. WarmUpInputId E.==. warmUpIV E.^. WarmUpInputValueWarmUpInput)
         E.where_ (warmUpI E.^. WarmUpInputRepResult E.==. E.val kExpRes)
         where' warmUpI warmUpIV
         return (warmUpI, warmUpIV)
  src C..| C.mapMC mkInput C..| sequenceC []
  -- sequence <$> mapM mkInput res
  where
    mkInput (Entity _ (WarmUpInput _ p), Entity _ (WarmUpInputValue _ v)) = do
      v' <- deserialise "warm up input value" v
      return $ Input p <$> v'
loadReplicationWarmUpInputWhere kExpRes GetAll = loadReplicationWarmUpInputWhere kExpRes (WarmUpInputWhere (\_ _ -> return ()))
loadReplicationWarmUpInputWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepInputWhere was expected"


loadReplicationWarmUpMeasuresCount :: (MonadIO m) => Key WarmUpResultData -> ReaderT SqlBackend m Int
loadReplicationWarmUpMeasuresCount kExpRes = count [WarmUpMeasureRepResult ==. kExpRes]

loadReplicationWarmUpMeasuresWhere :: (MonadIO m) => Key WarmUpResultData -> AvailabilityListWhere -> ConduitM () Measure (DB m) ()
loadReplicationWarmUpMeasuresWhere kExpRes (WarmUpMeasureWhere where') = do
  let src =
        E.selectSource $
        E.from $ \(warmUpM, warmUpRS) -> do
          E.where_ (warmUpM E.^. WarmUpMeasureId E.==. warmUpRS E.^. WarmUpResultStepMeasure)
          E.where_ (warmUpM E.^. WarmUpMeasureRepResult E.==. E.val kExpRes)
          where' warmUpM warmUpRS
          E.orderBy [E.asc (warmUpM E.^. WarmUpMeasurePeriod)]
          return (warmUpM, warmUpRS)
  src C..| C.mapC mkMeasure C..| CL.groupBy ((==) `on` view measurePeriod) C..| C.mapC combineMeasures
  where
    mkMeasure (Entity _ (WarmUpMeasure _ p), Entity _ (WarmUpResultStep _ n x y)) = Measure p [StepResult n x y]
    combineMeasures xs@(Measure p _:_) = Measure p (concatMap (view measureResults) xs)
    combineMeasures _                  = error "not possible"
loadReplicationWarmUpMeasuresWhere kExpRes GetAll = loadReplicationWarmUpMeasuresWhere kExpRes (WarmUpMeasureWhere (\_ _ -> return ()))
loadReplicationWarmUpMeasuresWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepMeasuresWhere was expected"

loadReplicationWarmUpAggregateWhere :: (MonadIO m) => Key WarmUpResultData -> AggregateFunction -> AvailabilityListWhere -> DB m Double
loadReplicationWarmUpAggregateWhere kExpRes agg (WarmUpMeasureWhere where') =
  fmap (fromMaybe 0 . E.unValue . head) $
  E.select $
  E.from $ \(warmUpM, warmUpRS) -> do
    E.where_ (warmUpM E.^. WarmUpMeasureId E.==. warmUpRS E.^. WarmUpResultStepMeasure)
    E.where_ (warmUpM E.^. WarmUpMeasureRepResult E.==. E.val kExpRes)
    where' warmUpM warmUpRS
    return (agg $ warmUpRS E.^. WarmUpResultStepYValue)
loadReplicationWarmUpAggregateWhere kExpRes agg GetAll = loadReplicationWarmUpAggregateWhere kExpRes agg (WarmUpMeasureWhere (\_ _ -> return ()))
loadReplicationWarmUpAggregateWhere _ _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where loadReplicationWarmUpAggregateWhere was expected"


loadReplicationInputCount :: (MonadIO m) => Key RepResultData -> ReaderT SqlBackend m Int
loadReplicationInputCount kExpRes = count [RepInputRepResult ==. kExpRes]

loadReplicationInputWhere :: (ExperimentDef a, MonadIO m) => Key RepResultData -> AvailabilityListWhere -> ConduitT () (Input a) (DB m) ()
loadReplicationInputWhere kExpRes (RepInputWhere where') = do
  let src =
       E.selectSource $
       E.from $ \(repI, repIV) -> do
         E.where_ (repI E.^. RepInputId E.==. repIV E.^. RepInputValueRepInput)
         E.where_ (repI E.^. RepInputRepResult E.==. E.val kExpRes)
         where' repI repIV
         return (repI, repIV)
  src C..| C.mapMC mkInput C..| sequenceC []
  -- sequence <$> mapM mkInput res
  where
    mkInput (Entity _ (RepInput _ p), Entity _ (RepInputValue _ v)) = do
      v' <- deserialise "eval input value" v
      return $ Input p <$> v'
loadReplicationInputWhere kExpRes GetAll = loadReplicationInputWhere kExpRes (RepInputWhere (\_ _ -> return ()))
loadReplicationInputWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where RepInputWhere was expected"


loadReplicationMeasuresCount :: (MonadIO m) => Key RepResultData -> ReaderT SqlBackend m Int
loadReplicationMeasuresCount kExpRes = count [RepMeasureRepResult ==. kExpRes]


loadReplicationMeasuresWhere :: (MonadIO m) => Key RepResultData -> AvailabilityListWhere -> ConduitT () Measure (DB m) ()
loadReplicationMeasuresWhere kExpRes (RepMeasureWhere where') = do
  let src =
        E.selectSource $
        E.from $ \(repM, repRS) -> do
          E.where_ (repM E.^. RepMeasureId E.==. repRS E.^. RepResultStepMeasure)
          E.where_ (repM E.^. RepMeasureRepResult E.==. E.val kExpRes)
          where' repM repRS
          E.orderBy [E.asc (repM E.^. RepMeasurePeriod)]
          return (repM, repRS)
  src C..| C.mapC mkMeasure C..| CL.groupBy ((==) `on` view measurePeriod) C..| C.mapC combineMeasures
  where
    mkMeasure (Entity _ (RepMeasure _ p), Entity _ (RepResultStep _ n x y)) = Measure p [StepResult n x y]
    combineMeasures xs@(Measure p _:_) = Measure p (concatMap (view measureResults) xs)
    combineMeasures _                  = error "not possible"
loadReplicationMeasuresWhere kExpRes GetAll = loadReplicationMeasuresWhere kExpRes (RepMeasureWhere (\_ _ -> return ()))
loadReplicationMeasuresWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where RepMeasuresWhere was expected"


loadReparationAggregateWhere :: (MonadIO m) => Key RepResultData -> AggregateFunction -> AvailabilityListWhere -> DB m Double
loadReparationAggregateWhere kExpRes agg (RepMeasureWhere where') =
  fmap (fromMaybe 0 . E.unValue . head) $
  E.select $
  E.from $ \(repM, repRS) -> do
    E.where_ (repM E.^. RepMeasureId E.==. repRS E.^. RepResultStepMeasure)
    E.where_ (repM E.^. RepMeasureRepResult E.==. E.val kExpRes)
    where' repM repRS
    return (agg $ repRS E.^. RepResultStepYValue)
loadReparationAggregateWhere kExpRes agg GetAll = loadReparationAggregateWhere kExpRes agg (RepMeasureWhere (\_ _ -> return ()))
loadReparationAggregateWhere _ _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where RepAggregateWhere was expected"


getOrCreateExps :: forall a . (ExperimentDef a) => ExperimentSetting -> InputState a -> a -> DB (ExpM a) (Entity Exps)
getOrCreateExps setup initInpSt initSt = do
  let name = view experimentBaseName setup
  expsList <- selectList [ExpsName ==. name] []
  expsInfoParams <- map (map entityVal) <$> mapM (\(Entity e _) -> selectList [ExpsInfoParamExps ==. e] []) expsList
  let expsList' = map fst $ filter ((\xs -> length infoParams >= length xs && all matchesExpsInfoParam xs) . snd) (zip expsList expsInfoParams)
  when (null expsList') $ $(logInfo) "No experiment with same Experiment Info Parameters found!"
  exps <-
    filterM
      (\(Entity _ (Exps _ _ _ s iS)) -> do
         serSt <- lift $ lift $ lift $ sequence $ deserialisable <$> runGet S.get s
         let other = (,) <$> serSt <*> runGet S.get iS
         when (isLeft other) $ $(logInfo) "Could not deserialise experiment with same name"
         return $ fromEither False (equalExperiments (initSt, initInpSt) <$> other))
      expsList'
  when (not (null expsList') && null exps) $ $(logInfo) "Found experiments with same name, but the are different or not deserialisable!"
  params <- mapM (\e -> selectList [ParamExps ==. entityKey e] [Asc ParamName]) exps
  let mkParamTpl (Param _ n _ _) = n
  let ~myParams = L.sort $ map (mkParamTpl . convertParameterSetup (entityKey (head exps))) (parameters initSt)
  case L.find ((== myParams) . L.sort . map (mkParamTpl . entityVal) . snd) (zip exps params) of
    Nothing -> do
      $(logInfo) "Starting new experiment..."
      time <- liftIO getCurrentTime
      !serInitSt <- lift $ lift $ lift $ serialisable initSt
      eExp <- insertEntity $ Exps name time Nothing (runPut $ put serInitSt) (runPut $ put initInpSt)
      void transactionSave
      void $ insert $ mkExpSetup eExp
      mapM_ (insertInfoParam (entityKey eExp)) infoParams
      mapM_ (insertParam (entityKey eExp)) (parameters initSt)
      return eExp
    Just (eExp, _) -> do
      $(logInfo) "Found experiment with same name and parameter settings. Continuing experiment ..."
      expInfoParams <- map entityVal <$> selectList [ExpsInfoParamExps ==. entityKey eExp] []
      mapM_ (insertInfoParam (entityKey eExp)) (filter ((`notElem` map (view expsInfoParamName) expInfoParams) . infoParameterName) infoParams)
      putMany [mkExpSetup eExp]
      return eExp
  where
    mkExpSetup eExp =
      ExpsSetup
        (entityKey eExp)
        (max 1 $ view experimentRepetitions setup)
        (max 0 $ view preparationSteps setup)
        (max 0 $ view evaluationWarmUpSteps setup)
        (max 0 $ view evaluationSteps setup)
        (max 1 $ view evaluationReplications setup)
        (max 1 <$> view evaluationMaxStepsBetweenSaves setup)
    insertInfoParam k (ExperimentInfoParameter n v) = insert $ ExpsInfoParam k n (S.runPut $ S.put v)
    insertParam :: Key Exps -> ParameterSetup a -> DB (ExpM a) (Key Param)
    insertParam eExp (ParameterSetup n _ _ _ (Just (minVal, maxVal)) _ _) = insert $ Param eExp n (Just $ runPut $ put minVal) (Just $ runPut $ put maxVal)
    insertParam eExp (ParameterSetup n _ _ _ Nothing _ _) = insert $ Param eExp n Nothing Nothing
    infoParams = view experimentInfoParameters setup
    matchesExpsInfoParam (ExpsInfoParam _ n bs) =
      case L.find ((== n) . infoParameterName) infoParams of
        Nothing -> False
        Just (ExperimentInfoParameter _ p) -> fromEither False ((p ==) <$> S.runGet S.get bs)