Direct.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Roboservant.Direct
  ( fuzz',
    Config (..),
    -- TODO come up with something smarter than exporting all this, we should
    -- have some nice error-display functions
    RoboservantException (..),
    FuzzState (..),
    FuzzOp (..),
    FailureType (..),
    Report (..),
  )
where

import Control.Exception.Lifted
  ( Exception,
    Handler (Handler),
    SomeAsyncException,
    SomeException,
    catch,
    catches,
    handle,
    throw,
  )
import Control.Monad.State.Strict
  ( MonadIO (..),
    MonadState (get),
    StateT (runStateT),
    modify',
  )
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.Dependent.Map as DM
import Data.Dynamic (Dynamic (..))
import qualified Data.IntSet as IntSet
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
import qualified Data.Vinyl.Functor as V
import GHC.Generics ((:*:) (..))
import Roboservant.Types
  ( ApiOffset (..),
    Argument (..),
    InteractionError(..),
    Provenance (..),
    ReifiedApi,
    ReifiedEndpoint (..),
    Stash (..),
    StashValue (..),
    TypedF,
  )
import Roboservant.Types.Config

import System.Random (Random (randomR), StdGen, mkStdGen)
import qualified Type.Reflection as R

data RoboservantException
  = RoboservantException
      { failureReason :: FailureType,
        serverException :: Maybe SomeException,
        fuzzState :: FuzzState
      }
  deriving (Show)

instance Exception RoboservantException

data FailureType
  = ServerCrashed
  | CheckerFailed
  | NoPossibleMoves
  | InsufficientCoverage Double
  deriving (Show, Eq)

data FuzzOp
  = FuzzOp
      { apiOffset :: ApiOffset,
        provenance :: [Provenance]
      }
  deriving (Show, Eq)

data FuzzState
  = FuzzState
      { path :: [FuzzOp],
        stash :: Stash,
        currentRng :: StdGen
      }
  deriving (Show)

data EndpointOption
  = forall as.
    (V.RecordToList as, V.RMap as) =>
    EndpointOption
      { eoCall :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))),
        eoArgs :: V.Rec (TypedF StashValue) as
      }

data StopReason
  = TimedOut
  | HitMaxIterations
  deriving (Show, Eq)

data Report
  = Report
      { textual :: String,
        rsException :: RoboservantException
      }
  deriving (Show)



-- fuzzClient :: Client api -> Config -> IO (Maybe Report)
-- fuzzClient = undefined



fuzz' ::
  ReifiedApi ->
  Config ->
  IO (Maybe Report)
fuzz' reifiedApi Config {..} = handle (pure . Just . formatException) $ do
  let path = []
      stash = addToStash seed mempty
      currentRng = mkStdGen rngSeed
  deadline :: UTCTime <- addUTCTime (realToFrac $ maxRuntime * 1000000) <$> getCurrentTime
  (stopreason, _fs) <-
    runStateT
      (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
      FuzzState {..}
  logInfo $ show stopreason
  pure Nothing
  where
    -- something less terrible later
    formatException :: RoboservantException -> Report
    formatException r@(RoboservantException failureType exception _state) =
      Report
        (unlines [show failureType, show exception])
        r
    displayDiagnostics FuzzState {..} = liftIO $
      logInfo $ unlines $
      ["api endpoints covered"]
        <> (map show . Set.toList . Set.fromList $ map apiOffset path)
        <> ["", "types in stash"]
        <> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
    --        <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
    --        $ \_k v ->
    --               (show . NEL.length $ getStashValue v))

    evaluateCoverage f@FuzzState {..}
      | coverage > coverageThreshold = pure ()
      | otherwise = do
        displayDiagnostics f
        throw $ RoboservantException (InsufficientCoverage coverage) Nothing f
      where
        hitRoutes = fromIntegral . Set.size . Set.fromList $ map apiOffset path
        totalRoutes = fromIntegral routeCount
        coverage = hitRoutes / totalRoutes
    untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
    untilDone (0, _) _ = pure HitMaxIterations
    untilDone (n, deadline) action = do
      now <- liftIO getCurrentTime
      if now > deadline
        then pure TimedOut
        else do
          _ <- action
          untilDone (n -1, deadline) action

    routeCount = length reifiedApi
    elementOrFail ::
      (MonadState FuzzState m, MonadIO m) =>
      [a] ->
      m a
    elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get
    elementOrFail l = do
      st <- get
      let (index, newGen) = randomR (0, length l - 1) (currentRng st)
      modify' $ \st' -> st' {currentRng = newGen}
      pure (l !! index)
    withOp ::
      (MonadState FuzzState m, MonadIO m) =>
      ( forall as.
        (V.RecordToList as, V.RMap as) =>
        FuzzOp ->
        V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
        V.Rec (TypedF V.Identity) as ->
        m r
      ) ->
      m r
    withOp callback = do
      -- choose a call to make, from the endpoints with fillable arguments.
      (offset, EndpointOption {..}) <- elementOrFail . options =<< get
      r <-
        V.rtraverse
          ( \(tr :*: StashValue svs _) ->
              elementOrFail $
                zipWith
                  (\i xy -> V.Const i :*: tr :*: xy)
                  [0 ..]
                  (NEL.toList svs)
          )
          eoArgs
      let pathSegment =
            FuzzOp offset $
              recordToList'
                (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
                r
          argValues =
            V.rmap
              (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
              r
      modify' (\f -> f {path = path f <> [pathSegment]})
      callback pathSegment eoCall argValues
      where
        options :: FuzzState -> [(ApiOffset, EndpointOption)]
        options FuzzState {..} =
          mapMaybe
            ( \(offset, ReifiedEndpoint {..}) -> do
                args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
                pure (offset, EndpointOption reEndpointFunc args)
            )
            reifiedApi
    execute ::
      (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
      FuzzOp ->
      V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic, Int)))) ->
      V.Rec (TypedF V.Identity) as ->
      m ()
    execute fuzzop func args = do
      (liftIO . logInfo . show . (fuzzop,) . stash) =<< get
      liftIO (V.runcurry' func argVals) >>= \case
        Left (e::InteractionError) ->
          if fatalError e
          then throw e
          else pure ()
        Right (dyn :: NEL.NonEmpty (Dynamic, Int)) ->
          modify'
          ( \fs@FuzzState {..} ->
              fs {stash = addToStash (NEL.toList dyn) stash}
          )
      where
        argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
    -- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
    go ::
      (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
      m ()
    go = withOp $ \op func args -> do
      catches
        (execute op func args)
        [ Handler (\(e :: SomeAsyncException) -> throw e),
          Handler
            ( \(e :: SomeException) -> 
                throw . RoboservantException ServerCrashed (Just e) =<< get
            )
        ]
      catch
        (liftIO healthCheck)
        (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)

addToStash ::
  [(Dynamic, Int)] ->
  Stash ->
  Stash
addToStash result stash =
  foldr
    ( \(Dynamic tr x, hashed) (Stash dict) ->
        Stash $
          DM.insertWith
            renumber
            tr
            (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| []) (IntSet.singleton hashed))
            dict
    )
    stash
    result
  where
    renumber ::
      StashValue a ->
      StashValue a ->
      StashValue a
    renumber (StashValue singleDyn singleHash) orig@(StashValue l intSet)
      | not $ IntSet.null (singleHash `IntSet.intersection` intSet) = orig
      | otherwise =
        StashValue
          ( case NEL.toList singleDyn of
              [([Provenance tr _], dyn)] ->
                l <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
              _ -> error "should be impossible"
          )
          (IntSet.union singleHash intSet)

-- why isn't this in vinyl?
recordToList' ::
  (V.RecordToList as, V.RMap as) =>
  (forall x. f x -> a) ->
  V.Rec f as ->
  [a]
recordToList' f = V.recordToList . V.rmap (V.Const . f)