diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2021 Renaissance Learning Inc + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,416 @@ +# Scientist + +Haskell port of +[`github/scientist`](https://github.com/github/scientist#readme). + +## Usage + +The following extensions are recommended: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +``` + + + +Most usage will only require the top-level library: + +```haskell +import Scientist +``` + + + +1. Define a new `Experiment m c a b` with, + + ```haskell + ex0 :: Functor m => Experiment m c a b + ex0 = newExperiment "some name" theOriginalCode + ``` + +1. The type variables capture the following details: + + - `m`: Some Monad to operate in, e.g. `IO`. + - `c`: Any context value you attach with `setExperimentContext`. It will then + be available in the `Result c a b` you publish. + - `a`: The result type of your original (aka "control") code, this is what is + always returned and so is the return type of `experimentRun`. + - `b`: The result type of your experimental (aka "candidate") code. It + probably won't differ (and must not to use a comparison like `(==)`), but + it can (provided you implement a comparison between `a` and `b`). + +1. Configure the Experiment as desired + + ```haskell + ex1 :: (Functor m, Eq a) => Experiment m c a a + ex1 = + setExperimentPublish publish0 + $ setExperimentCompare experimentCompareEq + $ setExperimentTry theExperimentalCode + $ newExperiment "some name" theOriginalCode + + -- Increment Statsd, Log, store in Redis, whatever + publish0 :: Result c a b -> m () + publish0 = undefined + ``` + +1. Run the experiment + + ```haskell + run0 :: (MonadUnliftIO m, Eq a) => m a + run0 = + experimentRun + $ setExperimentPublish publish0 + $ setExperimentCompare experimentCompareEq + $ setExperimentTry theExperimentalCode + $ newExperiment "some name" theOriginalCode + ``` + +1. Explore things like `setExperimentIgnore`, `setExperimentEnabled`, etc. + +--- + +The rest of this README matches section-by-section to the ported project and +shows only the differences in syntax for those features. Please follow the +header links for additional details, motivation, etc. + +## [How do I science?](https://github.com/github/scientist#how-do-i-science) + + + +```haskell +myWidgetAllows :: MonadUnliftIO m => Model -> User -> m Bool +myWidgetAllows model user = do + experimentRun + $ setExperimentTry + (userCanRead user model) -- new way + $ newExperiment "widget-permissions" + (modelCheckUserValid model user) -- old way +``` + +## [Making science useful](https://github.com/github/scientist#making-science-useful) + +```haskell +run1 :: MonadUnliftIO m => m a +run1 = + experimentRun + $ setExperimentEnabled (pure True) + $ setExperimentOnException onScientistException + $ setExperimentPublish (liftIO . putStrLn . formatResult) + $ setExperimentTry theExperimentalCode + $ newExperiment "some name" theOriginalCode + +onScientistException :: MonadIO m => SomeException -> m () +onScientistException ex = do + liftIO $ putStrLn "..." + + -- To re-raise + throwIO ex + +formatResult :: Result c a b -> String +formatResult = undefined +``` + +### [Controlling comparison](https://github.com/github/scientist#controlling-comparison) + + + +```haskell +run2 :: MonadUnliftIO m => m [User] +run2 = + experimentRun + $ setExperimentCompare (experimentCompareOn $ map userLogin) + $ setExperimentTry userServiceFetch + $ newExperiment "users" fetchAllUsers +``` + +When using `experimentCompareOn`, `By`, or `Eq`, if a candidate branch raises an +exception, that will never compare equally. + +### [Adding context](https://github.com/github/scientist#adding-context) + +See `setExperimentContext`. + +### [Expensive setup](https://github.com/github/scientist#expensive-setup) + +Just do it ahead of time. + + + +```haskell +run3 :: MonadUnliftIO m => m a +run3 = do + x <- expensiveSetup + + experimentRun + $ setExperimentTry (theExperimentalCodeWith x) + $ newExperiment "expensive" (theOriginalCodeWith x) +``` + +### [Keeping it clean](https://github.com/github/scientist#keeping-it-clean) + +Not supported at this time. Format the value(s) as necessary when publishing. + +### [Ignoring mismatches](https://github.com/github/scientist#ignoring-mismatches) + +See `setExperimentIgnore`. + +### [Enabling/disabling experiments](https://github.com/github/scientist#enablingdisabling-experiments) + +See `setExperimentRunIf`. + +### [Ramping up experiments](https://github.com/github/scientist#ramping-up-experiments) + +```haskell +run4 :: MonadUnliftIO m => m a +run4 = + experimentRun + $ setExperimentEnabled (experimentEnabledPercent 30) + $ setExperimentTry theExperimentalCode + $ newExperiment "some name" theOriginalCode +``` + +### [Publishing results](https://github.com/github/scientist#publishing-results) + + + +```haskell +run5 :: MonadUnliftIO m => m User +run5 = + experimentRun + $ setExperimentPublish publish1 + $ setExperimentTry theExperimentalCode + $ newExperiment "some name" theOriginalCode + +publish1 :: MonadIO m => Result MyContext User User -> m () +publish1 result = do + -- Details are present unless it's a ResultSkipped, which we'll ignore + for_ (resultDetails result) $ \details -> do + let eName = resultDetailsExperimentName details + + -- Store the timing for the control value, + statsdTiming ("science." <> eName <> ".control") + $ resultControlDuration + $ resultDetailsControl details + + -- for the candidate (only the first, see "Breaking the rules" below, + statsdTiming ("science." <> eName <> ".candidate") + $ resultCandidateDuration + $ resultDetailsCandidate details + + -- and counts for match/ignore/mismatch: + case result of + ResultSkipped{} -> pure () + ResultMatched{} -> do + statsdIncrement $ "science." <> eName <> ".matched" + ResultIgnored{} -> do + statsdIncrement $ "science." <> eName <> ".ignored" + ResultMismatched{} -> do + statsdIncrement $ "science." <> eName <> ".mismatched" + -- Finally, store mismatches in redis so they can be retrieved and + -- examined later on, for debugging and research. + storeMismatchData details + +storeMismatchData :: Monad m => ResultDetails MyContext User User -> m () +storeMismatchData details = do + let + eName = resultDetailsExperimentName details + eContext = resultDetailsExperimentContext details + + payload = MyPayload + { name = eName + , context = eContext + , control = controlObservationPayload $ resultDetailsControl details + , candidate = candidateObservationPayload $ resultDetailsCandidate details + , execution_order = resultDetailsExecutionOrder details + } + + key = "science." <> eName <> ".mismatch" + + redisLpush key $ toJSON payload + redisLtrim key 0 1000 + +controlObservationPayload :: ResultControl User -> Value +controlObservationPayload rc = + object ["value" .= cleanValue (resultControlValue rc)] + +candidateObservationPayload :: ResultCandidate User -> Value +candidateObservationPayload rc = case resultCandidateValue rc of + Left ex -> object ["exception" .= displayException ex] + Right user -> object ["value" .= cleanValue user] + +-- See "Keeping it clean" above +cleanValue :: User -> Text +cleanValue = userLogin +``` + +See `Result`, `ResultDetails`, `ResultControl` and `ResultCandidate` for all the +available data you can publish. + +### [Testing](https://github.com/github/scientist#testing) + +**TODO**: `raise_on_mismatches` + +#### [Custom mismatch errors](https://github.com/github/scientist#custom-mismatch-errors) + +**TODO**: `raise_with` + +### [Handling errors](https://github.com/github/scientist#handling-errors) + +#### [In candidate code](https://github.com/github/scientist#in-candidate-code) + +Candidate code is wrapped in `tryAny`, resulting in `Either SomeException` +values in the result candidates list. We use the [safer][blog] +`UnliftIO.Exception` module. + +[blog]: https://www.fpcomplete.com/haskell/tutorial/exceptions/ + +#### [In a Scientist callback](https://github.com/github/scientist#in-a-scientist-callback) + +See `setExperimentOnException`. + +## [Breaking the rules](https://github.com/github/scientist#breaking-the-rules) + +### [Ignoring results entirely](https://github.com/github/scientist#ignoring-results-entirely) + +```haskell +nope0 :: Experiment m c a b -> Experiment m c a b +nope0 = setExperimentIgnore (\_ _ -> True) +``` + +Or, more efficiently: + +```haskell +nope1 :: Experiment m c a b -> Experiment m c a b +nope1 = setExperimentCompare (\_ _ -> True) +``` + +### [Trying more than one thing](https://github.com/github/scientist#trying-more-than-one-thing) + +If you call `setExperimentTry` more than once, it will append (not overwrite) +candidate branches. If any candidate is deemed ignored or a mismatch, the +overall result will be. + +`setExperimentTryNamed` can be used to give branches explicit names (otherwise, +they are "control", "candidate", "candidate-{n}"). These names are visible in +`ResultControl`, `ResultCandidate`, and `resultDetailsExecutionOrder`. + +### [No control, just candidates](https://github.com/github/scientist#no-control-just-candidates) + +Not supported. + +Supporting the lack of a Control branch in the types would ultimately lead to a +runtime error if you attempt to run such an `Experiment` without having and +naming a Candidate to use instead, or severely complicate the types to account +for that safely. In our opinion, this feature is not worth either of those. + + + +--- + +[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md) diff --git a/library/Scientist.hs b/library/Scientist.hs new file mode 100644 --- /dev/null +++ b/library/Scientist.hs @@ -0,0 +1,14 @@ +module Scientist + ( module X + ) where + +import Scientist.Experiment as X +import Scientist.Experiment.Run as X +import Scientist.Result as X + ( Result(..) + , ResultCandidate(..) + , ResultControl(..) + , ResultDetails(..) + , resultDetails + , resultDetailsCandidate + ) diff --git a/library/Scientist/Candidate.hs b/library/Scientist/Candidate.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Candidate.hs @@ -0,0 +1,7 @@ +module Scientist.Candidate + ( Candidate(..) + ) where + +newtype Candidate a = Candidate + { unCandidate :: a + } diff --git a/library/Scientist/Control.hs b/library/Scientist/Control.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Control.hs @@ -0,0 +1,7 @@ +module Scientist.Control + ( Control(..) + ) where + +newtype Control a = Control + { unControl :: a + } diff --git a/library/Scientist/Duration.hs b/library/Scientist/Duration.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Duration.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Scientist.Duration + ( Duration + , measureDuration + , durationToSeconds + ) where + +import Prelude + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Fixed (Fixed(..), Nano, showFixed) +import qualified System.Clock as Clock + +-- | Time elapsed in seconds up to nanosecond precision +-- +-- >> 1.005 +-- 1.005s +newtype Duration = Duration + { _unDuration :: Nano + } + deriving stock (Eq) + deriving newtype (Enum, Ord, Num, Real, Fractional, RealFrac) + +instance Show Duration where + show (Duration x) = showFixed True x <> "s" + +measureDuration :: MonadIO m => m a -> m (a, Duration) +measureDuration f = do + begin <- liftIO getTime + (,) <$> f <*> liftIO + (fromNanoSecs . Clock.toNanoSecs . subtract begin <$> getTime) + where getTime = Clock.getTime Clock.Monotonic + +-- | Convert from duration to seconds +-- +-- >> toSecs 0.000001 +-- 0.000001 +durationToSeconds :: Duration -> Double +durationToSeconds = realToFrac + +-- | Convert to duration from nanoseconds +-- +-- >> fromNanoSecs 1000 +-- 0.000001s +fromNanoSecs :: Integer -> Duration +fromNanoSecs = Duration . MkFixed diff --git a/library/Scientist/Experiment.hs b/library/Scientist/Experiment.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Experiment.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Scientist.Experiment + ( Experiment + + -- * Construction + , newExperiment + + -- * Modifiying values + , setExperimentTry + , setExperimentTryNamed + , setExperimentEnabled + , setExperimentOnException + , setExperimentCompare + , setExperimentContext + , setExperimentIgnore + , setExperimentRunIf + , setExperimentPublish + + -- * Common modifying values + , experimentCompareEq + , experimentCompareOn + , experimentCompareBy + , experimentEnabledPercent + + -- * Accessing values + , getExperimentName + , getExperimentUse + , getExperimentTries + , getExperimentEnabled + , getExperimentOnException + , getExperimentCompare + , getExperimentContext + , getExperimentIgnore + , getExperimentRunIf + , getExperimentPublish + ) where + +import Prelude + +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Random (evalRandIO, getRandomR) +import Data.Function (on) +import Data.List.NonEmpty +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import Scientist.Candidate +import Scientist.Control +import Scientist.NamedCandidate +import Scientist.Result +import UnliftIO.Exception (SomeException, throwIO) + +data Experiment m c a b = Experiment + { experimentName :: Text + , experimentUse :: m (Control a) + , experimentTries :: Maybe (NonEmpty (NamedCandidate m b)) + , experimentEnabled :: Maybe (m Bool) + , experimentOnException :: Maybe (SomeException -> m ()) + , experimentCompare + :: Maybe (Control a -> Either SomeException (Candidate b) -> Bool) + , experimentContext :: Maybe c + , experimentIgnore + :: Maybe (Control a -> Either SomeException (Candidate b) -> Bool) + , experimentRunIf :: Maybe Bool + , experimentPublish :: Maybe (Result c a b -> m ()) + , experimentCandidateCount :: Int + } + +newExperiment :: Functor m => Text -> m a -> Experiment m c a b +newExperiment name f = Experiment + { experimentName = name + , experimentUse = Control <$> f + , experimentTries = Nothing + , experimentEnabled = Nothing + , experimentOnException = Nothing + , experimentCompare = Nothing + , experimentContext = Nothing + , experimentIgnore = Nothing + , experimentRunIf = Nothing + , experimentPublish = Nothing + , experimentCandidateCount = 0 + } + +-- | A new, candidate code path +-- +-- If called multiple times, adds multiple candidate paths. +-- +-- By default, there are no candidate paths and running the experiment will +-- return 'ResultSkipped'. +-- +setExperimentTry + :: Functor m => m b -> Experiment m c a b -> Experiment m c a b +setExperimentTry = setExperimentTryInternal Nothing + +setExperimentTryNamed + :: Functor m => Text -> m b -> Experiment m c a b -> Experiment m c a b +setExperimentTryNamed = setExperimentTryInternal . Just + +setExperimentTryInternal + :: Functor m => Maybe Text -> m b -> Experiment m c a b -> Experiment m c a b +setExperimentTryInternal mName f ex = ex + { experimentTries = Just updated + , experimentCandidateCount = updatedCount + } + where + thisTry = pure $ namedCandidate thisName $ Candidate <$> f + thisName = fromMaybe inferName mName + inferName = case currentCount of + 0 -> "candidate" + n -> pack $ "candidate-" <> show n + + current = experimentTries ex + updated = maybe thisTry (<> thisTry) current + + currentCount = experimentCandidateCount ex + updatedCount = currentCount + 1 + +-- | If the candidate paths should be executed +-- +-- See 'experimentEnabledPercent' for an example. +-- +-- By default, candidate paths are always run. +-- +setExperimentEnabled :: m Bool -> Experiment m c a b -> Experiment m c a b +setExperimentEnabled f ex = ex { experimentEnabled = Just f } + +-- | How to handle an exception evaluating or publishing +-- +-- By default, the exception is re-thrown. +-- +setExperimentOnException + :: (SomeException -> m ()) -> Experiment m c a b -> Experiment m c a b +setExperimentOnException f ex = ex { experimentOnException = Just f } + +-- | Decide if a given result is a match. +-- +-- See 'experimentCompareEq' and 'experimentCompareBy'. +-- +-- By default, all comparisons fail. +-- +setExperimentCompare + :: (Control a -> Either SomeException (Candidate b) -> Bool) + -> Experiment m c a b + -> Experiment m c a b +setExperimentCompare f ex = ex { experimentCompare = Just f } + +-- | Decide if a given result should be ignored +-- +-- By default, no results are ignored. +-- +setExperimentIgnore + :: (Control a -> Either SomeException (Candidate b) -> Bool) + -> Experiment m c a b + -> Experiment m c a b +setExperimentIgnore f ex = ex { experimentIgnore = Just f } + +-- | Decide if the experiment should run at all +-- +-- By default, experiments are run. +-- +setExperimentRunIf :: Bool -> Experiment m c a b -> Experiment m c a b +setExperimentRunIf b ex = ex { experimentRunIf = Just b } + +-- | How to publish results +-- +-- By default, results are not published. +-- +setExperimentPublish + :: (Result c a b -> m ()) -> Experiment m c a b -> Experiment m c a b +setExperimentPublish f ex = ex { experimentPublish = Just f } + +getExperimentName :: Experiment m c a b -> Text +getExperimentName = experimentName + +getExperimentUse :: Experiment m c a b -> m (Control a) +getExperimentUse = experimentUse + +getExperimentTries + :: Experiment m c a b -> Maybe (NonEmpty (NamedCandidate m b)) +getExperimentTries = experimentTries + +getExperimentEnabled :: Applicative m => Experiment m c a b -> m Bool +getExperimentEnabled = fromMaybe (pure True) . experimentEnabled + +getExperimentOnException + :: MonadIO m => Experiment m c a b -> SomeException -> m () +getExperimentOnException = fromMaybe throwIO . experimentOnException + +getExperimentCompare + :: Experiment m c a b + -> (Control a -> Either SomeException (Candidate b) -> Bool) +getExperimentCompare = fromMaybe (\_ _ -> False) . experimentCompare + +setExperimentContext :: c -> Experiment m c a b -> Experiment m c a b +setExperimentContext x ex = ex { experimentContext = Just x } + +getExperimentContext :: Experiment m c a b -> Maybe c +getExperimentContext = experimentContext + +getExperimentIgnore + :: Experiment m c a b + -> (Control a -> Either SomeException (Candidate b) -> Bool) +getExperimentIgnore = fromMaybe (\_ _ -> False) . experimentIgnore + +getExperimentRunIf :: Experiment m c a b -> Bool +getExperimentRunIf = fromMaybe True . experimentRunIf + +getExperimentPublish + :: Applicative m => Experiment m c a b -> (Result c a b -> m ()) +getExperimentPublish = fromMaybe (const $ pure ()) . experimentPublish + +-- | Compare non-exception candidates with the control by '(==)' +-- +-- Exception candidates fail comparison. +-- +experimentCompareEq + :: Eq a => Control a -> Either SomeException (Candidate a) -> Bool +experimentCompareEq = experimentCompareBy (==) + +-- | Compare by equality on some function +-- +-- Exception candidates fail comparison. +-- +experimentCompareOn + :: Eq b => (a -> b) -> Control a -> Either SomeException (Candidate a) -> Bool +experimentCompareOn f = experimentCompareBy ((==) `on` f) + +-- | Compare by some function +-- +-- Exception candidates fail comparison. +-- +experimentCompareBy + :: (a -> b -> Bool) -> Control a -> Either SomeException (Candidate b) -> Bool +experimentCompareBy f (Control a) = \case + Left _ -> False + Right (Candidate b) -> f a b + +-- | Enable the experiment in the given percentage of runs +experimentEnabledPercent :: MonadIO m => Int -> m Bool +experimentEnabledPercent n + | n <= 0 = pure False + | n >= 100 = pure True + | otherwise = liftIO $ evalRandIO $ (<= n) <$> getRandomR (0, 100) diff --git a/library/Scientist/Experiment/Run.hs b/library/Scientist/Experiment/Run.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Experiment/Run.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Scientist.Experiment.Run + ( experimentRun + , experimentRunInternal + ) where + +import Prelude + +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) +import Data.Bifunctor (second) +import Data.Bitraversable (bimapM) +import Data.Either (partitionEithers) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Scientist.Control +import Scientist.Duration +import Scientist.Experiment +import Scientist.NamedCandidate +import Scientist.Result +import Scientist.Result.Evaluate +import System.Random.Shuffle (shuffleM) +import UnliftIO.Exception (handleAny, throwString) + +experimentRun :: MonadUnliftIO m => Experiment m c a b -> m a +experimentRun = fmap resultValue . experimentRunInternal + +-- | 'experimentRun' but returning the full 'Result' +-- +-- Used for testing. +-- +experimentRunInternal + :: MonadUnliftIO m => Experiment m c a b -> m (Result c a b) +experimentRunInternal ex = do + enabled <- isExperimentEnabled ex + + let + getName = \case + Left{} -> "control" + Right nc -> namedCandidateName nc + + case getExperimentTries ex of + Just candidates | enabled -> do + (controlResult, candidateResults, order) <- runRandomized + control + candidates + runControl + runCandidate + getName + + let result = evaluateResult ex controlResult candidateResults order + + result <$ handleAny + (getExperimentOnException ex) + (getExperimentPublish ex result) + + _ -> ResultSkipped <$> control + where control = getExperimentUse ex + +isExperimentEnabled :: Applicative m => Experiment m c a b -> m Bool +isExperimentEnabled ex + | not (getExperimentRunIf ex) = pure False + | otherwise = getExperimentEnabled ex + +runControl :: MonadIO m => m (Control a) -> m (ResultControl a) +runControl control = do + (Control a, d) <- measureDuration control + pure ResultControl + { resultControlName = "control" + , resultControlValue = a + , resultControlDuration = d + } + +runCandidate :: MonadUnliftIO m => NamedCandidate m b -> m (ResultCandidate b) +runCandidate nc = do + (b, d) <- measureDuration $ runNamedCandidate nc + pure $ ResultCandidate + { resultCandidateName = namedCandidateName nc + , resultCandidateValue = b + , resultCandidateDuration = d + } + +runRandomized + :: MonadIO m + => a + -> NonEmpty b + -> (a -> m a') -- ^ How to run the @a@ + -> (b -> m b') -- ^ How to run each @b@ + -> (Either a b -> Text) + -- ^ How to identify each item in the reported order + -> m (a', NonEmpty b', [Text]) +runRandomized a bs runA runB toName = do + inputs <- liftIO $ shuffleM $ Left a : map Right (NE.toList bs) + outputs <- traverse (bimapM runA runB) inputs + + let + order = map toName inputs + partitioned = partitionEithers outputs + + case second NE.nonEmpty partitioned of + ([a'], Just bs') -> pure (a', bs', order) + _ -> + -- Justification for this being "impossible": + -- + -- - We cannot produce an a or b out of thin air + -- - We were given an a and NonEmpty b + -- - We cannot forget to use a without an unused warning + -- - We cannot forget to use bs without an unused warning + -- - We're doing no filtering anywhere + -- + -- Therefore, there's no way to not get 1 Left and 1+ Rights here. + -- + throwString + $ "runRandomized did not produce 1 Left and 1+ Rights, but " + <> show (length $ fst partitioned) + <> " Left(s), and " + <> show (length $ snd partitioned) + <> " Rights(s)" diff --git a/library/Scientist/NamedCandidate.hs b/library/Scientist/NamedCandidate.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/NamedCandidate.hs @@ -0,0 +1,25 @@ +module Scientist.NamedCandidate + ( NamedCandidate + , namedCandidate + , namedCandidateName + , runNamedCandidate + ) where + +import Prelude + +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Text (Text) +import Scientist.Candidate +import UnliftIO.Exception (SomeException, tryAny) + +data NamedCandidate m a = NamedCandidate Text (m (Candidate a)) + +namedCandidate :: Text -> m (Candidate a) -> NamedCandidate m a +namedCandidate = NamedCandidate + +namedCandidateName :: NamedCandidate m a -> Text +namedCandidateName (NamedCandidate x _) = x + +runNamedCandidate + :: MonadUnliftIO m => NamedCandidate m a -> m (Either SomeException a) +runNamedCandidate (NamedCandidate _ f) = tryAny $ unCandidate <$> f diff --git a/library/Scientist/Result.hs b/library/Scientist/Result.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Result.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module Scientist.Result + ( Result(..) + , resultValue + , resultDetails + , ResultDetails(..) + , resultDetailsCandidate + , ResultControl(..) + , ResultCandidate(..) + ) where + +import Prelude + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Scientist.Control +import Scientist.Duration +import UnliftIO.Exception (SomeException) + +data Result c a b + = ResultSkipped (Control a) + | ResultMatched (ResultDetails c a b) + | ResultIgnored (ResultDetails c a b) + | ResultMismatched (ResultDetails c a b) + +resultValue :: Result c a b -> a +resultValue = \case + ResultSkipped (Control a) -> a + ResultMatched rd -> resultDetailsControlValue rd + ResultIgnored rd -> resultDetailsControlValue rd + ResultMismatched rd -> resultDetailsControlValue rd + +resultDetails :: Result c a b -> Maybe (ResultDetails c a b) +resultDetails = \case + ResultSkipped{} -> Nothing + ResultMatched rd -> Just rd + ResultIgnored rd -> Just rd + ResultMismatched rd -> Just rd + +data ResultDetails c a b = ResultDetails + { resultDetailsExperimentName :: Text + , resultDetailsExperimentContext :: Maybe c + , resultDetailsControl :: ResultControl a + , resultDetailsCandidates :: NonEmpty (ResultCandidate b) + , resultDetailsExecutionOrder :: [Text] + } + +resultDetailsControlValue :: ResultDetails c a b -> a +resultDetailsControlValue = resultControlValue . resultDetailsControl + +resultDetailsCandidate :: ResultDetails c a b -> ResultCandidate b +resultDetailsCandidate = NE.head . resultDetailsCandidates + +data ResultControl a = ResultControl + { resultControlName :: Text + , resultControlValue :: a + , resultControlDuration :: Duration + } + +data ResultCandidate a = ResultCandidate + { resultCandidateName :: Text + , resultCandidateValue :: Either SomeException a + , resultCandidateDuration :: Duration + } diff --git a/library/Scientist/Result/Evaluate.hs b/library/Scientist/Result/Evaluate.hs new file mode 100644 --- /dev/null +++ b/library/Scientist/Result/Evaluate.hs @@ -0,0 +1,41 @@ +module Scientist.Result.Evaluate + ( evaluateResult + ) where + +import Prelude + +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Scientist.Candidate +import Scientist.Control +import Scientist.Experiment +import Scientist.Result + +evaluateResult + :: Experiment m c a b + -> ResultControl a + -> NonEmpty (ResultCandidate b) + -> [Text] + -> Result c a b +evaluateResult ex control candidates order + | any (ignore control) candidates = ResultIgnored details + | all (match control) candidates = ResultMatched details + | otherwise = ResultMismatched details + where + ignore a b = getExperimentIgnore + ex + (Control $ resultControlValue a) + (Candidate <$> resultCandidateValue b) + + match a b = getExperimentCompare + ex + (Control $ resultControlValue a) + (Candidate <$> resultCandidateValue b) + + details = ResultDetails + { resultDetailsExperimentName = getExperimentName ex + , resultDetailsExperimentContext = getExperimentContext ex + , resultDetailsControl = control + , resultDetailsCandidates = candidates + , resultDetailsExecutionOrder = order + } diff --git a/scientist.cabal b/scientist.cabal new file mode 100644 --- /dev/null +++ b/scientist.cabal @@ -0,0 +1,101 @@ +cabal-version: 1.12 +name: scientist +version: 0.0.0.0 +license: MIT +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/scientist-hs#readme +bug-reports: https://github.com/freckle/scientist-hs/issues +synopsis: A Haskell library for carefully refactoring critical paths. +description: Please see README.md +category: Utils +build-type: Simple + +source-repository head + type: git + location: https://github.com/freckle/scientist-hs + +library + exposed-modules: + Scientist + Scientist.Candidate + Scientist.Control + Scientist.Duration + Scientist.Experiment + Scientist.Experiment.Run + Scientist.NamedCandidate + Scientist.Result + Scientist.Result.Evaluate + + hs-source-dirs: library + other-modules: Paths_scientist + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe + + build-depends: + MonadRandom >=0.5.1.1, + base >4 && <5, + clock >=0.7.2, + random-shuffle >=0.0.4, + text >=1.2.3.1, + unliftio >=0.2.9.0, + unliftio-core >=0.1.2.0 + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + other-modules: Paths_scientist + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe -pgmL + markdown-unlit + + build-depends: + base >4 && <5, + markdown-unlit >=0.5.0, + scientist -any, + text >=1.2.3.1, + unliftio >=0.2.9.0, + unliftio-core >=0.1.2.0 + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + other-modules: + Scientist.Experiment.RunSpec + Scientist.ExperimentSpec + Scientist.Test + Paths_scientist + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe + + build-depends: + base >4 && <5, + hspec >=2.5.5, + scientist -any, + unliftio >=0.2.9.0 + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module diff --git a/tests/Scientist/Experiment/RunSpec.hs b/tests/Scientist/Experiment/RunSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Scientist/Experiment/RunSpec.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Scientist.Experiment.RunSpec + ( spec + ) where + +import Scientist.Test + +import Data.Either (partitionEithers) +import qualified Data.List.NonEmpty as NE +import Scientist.Candidate +import Scientist.Control +import Scientist.Duration +import Scientist.Experiment +import Scientist.Experiment.Run +import Scientist.Result +import UnliftIO.Concurrent +import UnliftIO.Exception (fromException, throwString) + +data ExampleResult = A | B | C + deriving stock (Eq, Show) + +spec :: Spec +spec = do + describe "experimentRun" $ do + it "is ResultSkipped based on runIf" $ do + result <- + experimentRunInternal + $ setExperimentRunIf False + $ setExperimentTry (pure A) + $ newExperiment "test" (pure A) + + expectSkippedWith result A + + it "is ResultSkipped based on enabled" $ do + result <- + experimentRunInternal + $ setExperimentEnabled (pure False) + $ setExperimentTry (pure A) + $ newExperiment "test" (pure A) + + expectSkippedWith result A + + it "is ResultSkipped when no Candidates present" $ do + result <- experimentRunInternal $ newExperiment "test" (pure A) + + expectSkippedWith result A + + it "is ResultMatched if all candidates match" $ do + result <- + experimentRunInternal + $ setExperimentCompare experimentCompareEq + $ setExperimentTry (pure A) + $ setExperimentTry (pure A) + $ newExperiment "test" (A <$ threadDelay (100 * 1000)) + + expectMatched result $ \rd -> do + resultDetailsExperimentName rd `shouldBe` "test" + + let control = resultDetailsControl rd + resultControlValue control `shouldBe` A + resultControlDuration control `shouldSatisfy` isDurationNear 0.100 + + let + (failed, succeeded) = + partitionEithers + $ map resultCandidateValue + $ NE.toList + $ resultDetailsCandidates rd + + succeeded `shouldMatchList` [A, A] + length failed `shouldBe` 0 + + it "is ResultIgnored if any candidates are ignored" $ do + let + ignoreB _ = \case + Right (Candidate B) -> True + _ -> False + + result <- + experimentRunInternal + $ setExperimentIgnore ignoreB + $ setExperimentTry (pure C) + $ setExperimentTry (pure B) + $ newExperiment "test" (pure A) + + expectIgnored result $ \rd -> do + resultDetailsExperimentName rd `shouldBe` "test" + + let control = resultDetailsControl rd + resultControlValue control `shouldBe` A + + let + (failed, succeeded) = + partitionEithers + $ map resultCandidateValue + $ NE.toList + $ resultDetailsCandidates rd + + succeeded `shouldMatchList` [B, C] + length failed `shouldBe` 0 + + it "is ResultMismatched if any candidates mismatched" $ do + result <- + experimentRunInternal + $ setExperimentCompare experimentCompareEq + $ setExperimentTry (pure B) + $ setExperimentTry (pure A) + $ newExperiment "test" (pure A) + + expectMismatched result $ \rd -> do + resultDetailsExperimentName rd `shouldBe` "test" + + let control = resultDetailsControl rd + resultControlValue control `shouldBe` A + + let + (failed, succeeded) = + partitionEithers + $ map resultCandidateValue + $ NE.toList + $ resultDetailsCandidates rd + + succeeded `shouldMatchList` [A, B] + length failed `shouldBe` 0 + + it "rescues exceptions in the Candidate branch" $ do + result <- + experimentRunInternal + $ setExperimentTry (throwString "boom") + $ newExperiment "test" (pure A) + + expectMismatched result $ \rd -> do + resultDetailsExperimentName rd `shouldBe` "test" + + let + control = resultDetailsControl rd + mCandidateException = + either fromException (const Nothing) + $ resultCandidateValue + $ NE.head + $ resultDetailsCandidates rd + + resultControlValue control `shouldBe` A + mCandidateException `shouldSatisfyMaybe` isStringException "boom" + + it "does not rescue exceptions in the Control branch" $ do + experimentRunInternal (newExperiment "test" (throwString "boom")) + `shouldThrowString` "boom" + + it "does not rescue exceptions in publishing" $ do + experimentRunInternal + (setExperimentPublish (\_ -> throwString "boom") + $ setExperimentTry (pure B) + $ newExperiment "test" (pure A) + ) + `shouldThrowString` "boom" + + it "can be configured to rescue exceptions in publishing" $ do + result <- + experimentRunInternal + $ setExperimentOnException (\_ -> pure ()) + $ setExperimentPublish (\_ -> throwString "boom") + $ setExperimentTry (pure B) + $ newExperiment "test" (pure A) + + expectMismatched result $ \_ -> pure () + + it "supports implicitly named candidates" $ do + result <- + experimentRunInternal + $ setExperimentCompare experimentCompareEq + $ setExperimentTry (pure A) + $ setExperimentTry (pure A) + $ setExperimentTry (pure A) + $ newExperiment "test" (pure A) + + expectMatched result $ \rd -> do + resultControlName (resultDetailsControl rd) `shouldBe` "control" + + map resultCandidateName (NE.toList $ resultDetailsCandidates rd) + `shouldMatchList` ["candidate", "candidate-1", "candidate-2"] + + it "supports explicitly named candidates" $ do + result <- + experimentRunInternal + $ setExperimentCompare experimentCompareEq + $ setExperimentTryNamed "who" (pure A) + $ setExperimentTryNamed "what" (pure A) + $ setExperimentTryNamed "when" (pure A) + $ newExperiment "test" (pure A) + + expectMatched result $ \rd -> do + resultControlName (resultDetailsControl rd) `shouldBe` "control" + + map resultCandidateName (NE.toList $ resultDetailsCandidates rd) + `shouldMatchList` ["who", "what", "when"] + +expectSkippedWith :: (Eq a, Show a) => Result c a b -> a -> IO () +expectSkippedWith result a = + expectSkipped result $ \(Control b) -> b `shouldBe` a + +expectSkipped :: Result c a b -> (Control a -> IO ()) -> IO () +expectSkipped result f = case result of + ResultSkipped x -> f x + _ -> expectationFailure "Expected result to be Skipped" + +expectMatched :: Result c a b -> (ResultDetails c a b -> IO ()) -> IO () +expectMatched result f = case result of + ResultMatched rd -> f rd + _ -> expectationFailure "Expected result to be Matched" + +expectIgnored :: Result c a b -> (ResultDetails c a b -> IO ()) -> IO () +expectIgnored result f = case result of + ResultIgnored rd -> f rd + _ -> expectationFailure "Expected result to be Ignored" + +expectMismatched :: Result c a b -> (ResultDetails c a b -> IO ()) -> IO () +expectMismatched result f = case result of + ResultMismatched rd -> f rd + _ -> expectationFailure "Expected result to be Mismatched" + +isDurationNear :: Duration -> Duration -> Bool +isDurationNear x = isWithinOf x 0.050 diff --git a/tests/Scientist/ExperimentSpec.hs b/tests/Scientist/ExperimentSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Scientist/ExperimentSpec.hs @@ -0,0 +1,16 @@ +module Scientist.ExperimentSpec + ( spec + ) where + +import Scientist.Test + +import Control.Monad (replicateM) +import Scientist.Experiment + +spec :: Spec +spec = do + describe "experimentEnabledPercent" $ do + it "returns True the given percent of the time" $ do + results <- replicateM 10000 $ experimentEnabledPercent 23 + + length (filter id results) `shouldSatisfy` isWithinOf 500 2300 diff --git a/tests/Scientist/Test.hs b/tests/Scientist/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Scientist/Test.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} + +module Scientist.Test + ( module X + , module Scientist.Test + ) where + +import Prelude as X + +import Test.Hspec as X +import UnliftIO.Exception (StringException(..)) + +shouldSatisfyMaybe + :: (HasCallStack, Show a) => Maybe a -> (a -> Bool) -> Expectation +x `shouldSatisfyMaybe` f = x `shouldSatisfy` maybe False f + +infix 1 `shouldSatisfyMaybe` + +isWithinOf :: (Num a, Ord a) => a -> a -> a -> Bool +isWithinOf tolerance desired = \case + n | n >= desired + tolerance -> False + n | n <= desired - tolerance -> False + _ -> True + +shouldThrowString :: HasCallStack => IO a -> String -> Expectation +f `shouldThrowString` msg = f `shouldThrow` isStringException msg + +infix 1 `shouldThrowString` + +isStringException :: String -> StringException -> Bool +isStringException a = \case + StringException b _cs -> b == a diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}