script-monad (empty) → 0.0.1
raw patch · 18 files changed
+3872/−0 lines, 18 filesdep +QuickCheckdep +aesondep +aeson-prettysetup-changed
Dependencies added: QuickCheck, aeson, aeson-pretty, base, bytestring, http-client, http-types, lens, lens-aeson, script-monad, tasty, tasty-hunit, tasty-quickcheck, text, time, unordered-containers, vector, wreq
Files
- ChangeLog.md +12/−0
- LICENSE +29/−0
- README.md +8/−0
- Setup.hs +2/−0
- app/Main.hs +4/−0
- script-monad.cabal +89/−0
- src/Control/Monad/Script.hs +474/−0
- src/Control/Monad/Script/Http.hs +1003/−0
- src/Data/Aeson/Extras.hs +56/−0
- src/Data/MockIO.hs +210/−0
- src/Data/MockIO/FileSystem.hs +174/−0
- src/Network/HTTP/Client/Extras.hs +143/−0
- test/Control/Monad/Script/Http/Test.hs +545/−0
- test/Control/Monad/Script/Test.hs +561/−0
- test/Data/MockIO/FileSystem/Test.hs +127/−0
- test/Data/MockIO/Test.hs +376/−0
- test/Data/MockIO/Test/Server.hs +29/−0
- test/Main.hs +30/−0
+ ChangeLog.md view
@@ -0,0 +1,12 @@+# Changelog for script-monad++## Unreleased changes++(none)++## 0.0.1++* New+ * Script and ScriptT: Hand-rolled stack of error, reader, writer, state, and prompt+ * Http and HttpT: Monad transformer for HTTP sessions with batteries included+ * MockIO: Fake IO monad for testing
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, Nathan Bloomfield+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,8 @@+script-monad+============++[](https://travis-ci.org/nbloomf/script-monad)++Haskell library providing an unrolled stack of reader, writer, state, error, and prompt monads. Handy for designing extensible and testable DSLs.++As an example, also provides a basic monad transformer for HTTP interactions.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ script-monad.cabal view
@@ -0,0 +1,89 @@+name: script-monad+version: 0.0.1+description: Please see the README on GitHub at <https://github.com/nbloomf/script-monad#readme>+homepage: https://github.com/nbloomf/script-monad#readme+bug-reports: https://github.com/nbloomf/script-monad/issues+author: Nathan Bloomfield+maintainer: nbloomf@gmail.com+copyright: 2018 Automattic, Inc.+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+category: Control.Monad+synopsis: Transformer stack of error, reader, writer, state, and prompt monads++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/nbloomf/script-monad++library+ default-language: Haskell2010+ hs-source-dirs: src++ build-depends:+ base >=4.7 && <5++ , aeson >=1.2.4.0 && <1.3+ , aeson-pretty >=0.8.5 && <0.9+ , bytestring >=0.10.8.2 && <0.11+ , http-client >=0.5.10 && <0.6+ , http-types >=0.12.1 && <0.13+ , lens >=4.16 && <4.17+ , lens-aeson >=1.0.2 && <1.1+ , QuickCheck >=2.10.1 && <2.11+ , text >=1.2.3.0 && <1.3+ , time >=1.8.0.2 && <1.9+ , unordered-containers >=0.2.9.0 && <0.3+ , vector >=0.12.0.1 && <0.13+ , wreq >=0.5.2 && <0.6++ exposed-modules:+ Control.Monad.Script+ , Control.Monad.Script.Http+ , Data.MockIO+ , Data.MockIO.FileSystem++ other-modules:+ Data.Aeson.Extras+ , Network.HTTP.Client.Extras++++executable script-monad-exe+ default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , script-monad++++test-suite script-monad-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ base >=4.7 && <5+ , script-monad++ , bytestring >=0.10.8.2 && <0.11+ , tasty >=1.0.1.1 && <1.1+ , tasty-hunit >=0.10.0.1 && <0.11+ , tasty-quickcheck >=0.9.2 && <1.0++ other-modules:+ Control.Monad.Script.Test+ , Control.Monad.Script.Http.Test+ , Data.MockIO.Test+ , Data.MockIO.Test.Server+ , Data.MockIO.FileSystem.Test
+ src/Control/Monad/Script.hs view
@@ -0,0 +1,474 @@+{- |+Module : Control.Monad.Script+Description : An unrolled stack of Reader, Writer, Error, State, and Prompt.+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++`Script` is an unrolled stack of reader, writer, state, error, and prompt monads, meant as a basis for building more specific DSLs. Also comes in monad transformer flavor with `ScriptT`.++The addition of prompt to the monad team makes it straightforward to build effectful computations which defer the actual effects (and effect types) to an evaluator function that is both precisely controlled and easily extended. This allows us to build testable and composable API layers.++The name 'Script' is meant to evoke the script of a play. In the theater sense a script is not a list of /instructions/ so much as a list of /suggestions/, and every cast gives a unique interpretation. Similarly a 'Script' is a pure value that gets an effectful interpretation from a user-supplied evaluator.+-}++{-# LANGUAGE Rank2Types, TupleSections, ScopedTypeVariables #-}+module Control.Monad.Script (+ -- * Script+ Script+ , execScript+ , execScriptM++ -- * ScriptT+ , ScriptT()+ , execScriptT+ , execScriptTM+ , lift++ -- * Error+ , except+ , triage+ , throw+ , catch++ -- * Reader+ , ask+ , local+ , transport+ , reader++ -- * Writer+ , tell+ , listen+ , pass+ , censor++ -- * State+ , get+ , put+ , modify+ , modify'+ , gets++ -- * Prompt+ , prompt++ -- * Testing+ , checkScript+ , checkScriptM+ , checkScriptT+ , checkScriptTM+) where++++import Control.Monad+ ( ap, join )+import Data.Functor.Classes+ ()+import Data.Functor.Identity+ ( Identity(..) )+import Data.Monoid+ ()+import Data.Typeable+ ( Typeable )+import Test.QuickCheck+ ( Property, Gen, Arbitrary(..), CoArbitrary(..) )+import Test.QuickCheck.Monadic+ ( monadicIO, run, assert )++++++-- | Opaque transformer stack of error (@e@), reader (@r@), writer (@w@), state (@s@), and prompt (@p@) monads.+newtype ScriptT e r w s p m a = ScriptT+ { runScriptT+ :: (s,r)+ -> forall v.+ ((Either e a, s, w) -> m v)+ -> (forall u. p u -> (u -> m v) -> m v)+ -> m v+ } deriving Typeable++instance (Monoid w) => Monad (ScriptT e r w s p m) where+ return x = ScriptT $ \(s,_) -> \end _ -> end (Right x, s, mempty)++ x >>= f = ScriptT $ \(s0,r) -> \end cont -> do+ let+ g (z1,s1,w1) = case z1 of+ Right y -> do+ let h (z2,s2,w2) = end (z2, s2, mappend w1 w2)+ runScriptT (f y) (s1,r) h cont+ Left e -> end (Left e, s1, w1)+ runScriptT x (s0,r) g cont++instance (Monoid w) => Applicative (ScriptT e r w s p m) where+ pure = return+ (<*>) = ap++instance (Monoid w) => Functor (ScriptT e r w s p m) where+ fmap f x = x >>= (return . f)++++++-- | Opaque stack of error (@e@), reader (@r@), writer (@w@), state (@s@), and prompt (@p@) monads.+type Script e r w s p = ScriptT e r w s p Identity++++++-- | Execute a 'ScriptT' with a specified initial state, environment, and continuation.+execScriptTC+ :: s -- ^ Initial state+ -> r -- ^ Environment+ -> ((Either e a, s, w) -> m v)+ -> (forall u. p u -> (u -> m v) -> m v)+ -> ScriptT e r w s p m a+ -> m v+execScriptTC s r end cont x =+ runScriptT x (s,r) end cont++-- | Execute a 'ScriptT' with a specified initial state and environment, and with a pure evaluator.+execScriptT+ :: (Monad m)+ => s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> u) -- ^ Pure effect evaluator+ -> ScriptT e r w s p m t+ -> m (Either e t, s, w)+execScriptT s r eval =+ execScriptTC s r return (\p c -> c $ eval p)++-- | Turn a `ScriptT` with a pure evaluator into a `Property`; for testing with QuickCheck. Wraps `execScriptT`.+checkScriptT+ :: (Monad m)+ => s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> u) -- ^ Pure effect evaluator+ -> (m (Either e t, s, w) -> IO q) -- ^ Condense to `IO`+ -> (q -> Bool) -- ^ Result check+ -> ScriptT e r w s p m t+ -> Property+checkScriptT s r eval cond check script = monadicIO $ do+ let result = execScriptT s r eval script+ q <- run $ cond result+ assert $ check q++-- | Execute a 'ScriptT' with a specified inital state and environment, and with a monadic evaluator. In this case the inner monad @m@ will typically be a monad transformer over the effect monad @n@.+execScriptTM+ :: (Monad (m n), Monad n)+ => s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> n u) -- ^ Monadic effect evaluator+ -> (forall u. n u -> m n u) -- ^ Lift effects to the inner monad+ -> ScriptT e r w s p (m n) t+ -> m n (Either e t, s, w)+execScriptTM s r eval lift =+ execScriptTC s r return+ (\p c -> (lift $ eval p) >>= c)++-- | Turn a `ScriptT` with a monadic evaluator into a `Property`; for testing with QuickCheck. Wraps `execScriptTM`.+checkScriptTM+ :: (Monad (m eff), Monad eff)+ => s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> eff u) -- ^ Moandic effect evaluator+ -> (forall u. eff u -> m eff u) -- ^ Lift effects to the inner monad+ -> (m eff (Either e t, s, w) -> IO q) -- ^ Condense to `IO`+ -> (q -> Bool) -- ^ Result check+ -> ScriptT e r w s p (m eff) t+ -> Property+checkScriptTM s r eval lift cond check script = monadicIO $ do+ let result = execScriptTM s r eval lift script+ q <- run $ cond result+ assert $ check q++++-- | Execute a 'Script' with a specified initial state, environment, and continuation.+execScriptC+ :: s -- ^ Initial state+ -> r -- ^ Environment+ -> ((Either e a, s, w) -> v)+ -> (forall u. p u -> (u -> v) -> v)+ -> Script e r w s p a+ -> v+execScriptC s r end cont x =+ let cont' p c = Identity $ cont p (runIdentity . c) in+ runIdentity $ runScriptT x (s,r) (Identity . end) cont'++-- | Execute a 'Script' with a specified initial state and environment, and with a pure evaluator.+execScript+ :: s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> u) -- ^ Pure evaluator+ -> Script e r w s p t+ -> (Either e t, s, w)+execScript s r eval =+ execScriptC s r id (\p c -> c $ eval p)++-- | Turn a `Script` with a pure evaluator into a `Bool`; for testing with QuickCheck. Wraps `execScript`.+checkScript+ :: s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> u) -- ^ Pure evaluator+ -> ((Either e t, s, w) -> q) -- ^ Condense+ -> (q -> Bool) -- ^ Result check+ -> Script e r w s p t+ -> Bool+checkScript s r eval cond check script =+ check $ cond $ execScript s r eval script++-- | Execute a 'Script' with a specified inital state and environment, and with a monadic evaluator.+execScriptM+ :: (Monad eff)+ => s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> eff u) -- ^ Monadic evaluator+ -> Script e r w s p t+ -> eff (Either e t, s, w)+execScriptM s r eval =+ execScriptC s r return+ (\p c -> (eval p) >>= c)++-- | Turn a `Script` with a monadic evaluator into a `Property`; for testing with QuickCheck. Wraps `execScriptM`.+checkScriptM+ :: (Monad eff)+ => s -- ^ Initial state+ -> r -- ^ Environment+ -> (forall u. p u -> eff u) -- ^ Moandic effect evaluator+ -> (eff (Either e t, s, w) -> IO q) -- ^ Condense to `IO`+ -> (q -> Bool) -- ^ Result check+ -> Script e r w s p t+ -> Property+checkScriptM s r eval cond check script = monadicIO $ do+ let result = execScriptM s r eval script+ q <- run $ cond result+ assert $ check q++++-- | Retrieve the environment.+ask+ :: (Monoid w)+ => ScriptT e r w s p m r+ask = ScriptT $ \(s,r) -> \end _ ->+ end (Right r, s, mempty)++++-- | Run an action with a locally adjusted environment of the same type.+local+ :: (r -> r)+ -> ScriptT e r w s p m a+ -> ScriptT e r w s p m a+local = transport++++-- | Run an action with a locally adjusted environment of a possibly different type.+transport+ :: (r2 -> r1)+ -> ScriptT e r1 w s p m a+ -> ScriptT e r2 w s p m a+transport f x = ScriptT $ \(s,r) -> \end cont ->+ runScriptT x (s, f r) end cont++++-- | Retrieve the image of the environment under a given function.+reader+ :: (Monoid w)+ => (r -> a)+ -> ScriptT e r w s p m a+reader f = fmap f ask++++-- | Retrieve the current state.+get+ :: (Monoid w)+ => ScriptT e r w s p m s+get = ScriptT $ \(s,_) -> \end _ ->+ end (Right s, s, mempty)++++-- | Replace the state.+put+ :: (Monoid w)+ => s+ -> ScriptT e r w s p m ()+put s = ScriptT $ \(_,_) -> \end _ ->+ end (Right (), s, mempty)++++-- | Modify the current state lazily.+modify+ :: (Monoid w)+ => (s -> s)+ -> ScriptT e r w s p m ()+modify f = ScriptT $ \(s,_) -> \end _ ->+ end (Right (), f s, mempty)++++-- | Modify the current state strictly.+modify'+ :: (Monoid w)+ => (s -> s)+ -> ScriptT e r w s p m ()+modify' f = ScriptT $ \(s,_) -> \end _ ->+ end (Right (), f $! s, mempty)++++-- | Retrieve the image of the current state under a given function.+gets+ :: (Monoid w)+ => (s -> a)+ -> ScriptT e r w s p m a+gets f = ScriptT $ \(s,_) -> \end _ ->+ end (Right (f s), s, mempty)++++-- | Write to the log.+tell+ :: w+ -> ScriptT e r w s p m ()+tell w = ScriptT $ \(s,_) -> \end _ ->+ end (Right (), s, w)++++-- | Run an action and attach the log to the result.+listen+ :: ScriptT e r w s p m a+ -> ScriptT e r w s p m (a,w)+listen x = ScriptT $ \(r,s) -> \end cont ->+ runScriptT x (r,s)+ (\(y,s,w) -> end (fmap (,w) y, s, w)) cont++++-- | Run an action that returns a value and a log-adjusting function, and apply the function to the local log.+pass+ :: ScriptT e r w s p m (a, w -> w)+ -> ScriptT e r w s p m a+pass x = ScriptT $ \(r,s) -> \end cont ->+ let+ end' (z,s1,w) = case z of+ Right (y,f) -> end (Right y, s1, f w)+ Left e -> end (Left e, s1, w)+ in+ runScriptT x (r,s) end' cont++++-- | Run an action, applying a function to the local log.+censor+ :: (w -> w)+ -> ScriptT e r w s p m a+ -> ScriptT e r w s p m a+censor f x = pass $ ScriptT $ \(s,r) -> \end cont ->+ let+ end' (z,s1,w) = case z of+ Right y -> end (Right (y,f), s1, w)+ Left e -> end (Left e, s1, w)+ in+ runScriptT x (s,r) end' cont++++-- | Inject an 'Either' into a 'Script'.+except+ :: (Monoid w)+ => Either e a+ -> ScriptT e r w s p m a+except z = ScriptT $ \(s,_) -> \end _ ->+ end (z, s, mempty)++++-- | Run an action, applying a function to any error.+triage+ :: (Monoid w)+ => (e1 -> e2)+ -> ScriptT e1 r w s p m a+ -> ScriptT e2 r w s p m a+triage f x = ScriptT $ \(s,r) -> \end cont ->+ let+ end' (z,s1,w) = case z of+ Right y -> end (Right y, s1, w)+ Left e -> end (Left (f e), s1, w)+ in+ runScriptT x (s,r) end' cont++++-- | Raise an error.+throw+ :: (Monoid w)+ => e+ -> ScriptT e r w s p m a+throw e = ScriptT $ \(s,_) -> \end _ ->+ end (Left e, s, mempty)++++-- | Run an action, applying a handler in case of an error result.+catch+ :: ScriptT e r w s p m a+ -> (e -> ScriptT e r w s p m a)+ -> ScriptT e r w s p m a+catch x h = ScriptT $ \(s,r) -> \end cont ->+ let+ end' (z,s1,w) = case z of+ Right y -> end (Right y, s1, w)+ Left e -> runScriptT (h e) (s1,r) end cont+ in+ runScriptT x (s,r) end' cont++++-- | Inject an atomic effect.+prompt+ :: (Monoid w)+ => p a+ -> ScriptT e r w s p m a+prompt p = ScriptT $ \(s,_) -> \end cont ->+ cont p (\a -> end (Right a, s, mempty))++++-- | Lift a computation in the base monad.+lift+ :: (Monoid w, Monad m)+ => m a+ -> ScriptT e r w s p m a+lift x = ScriptT $ \(s,_) -> \end _ ->+ x >>= \a -> end (Right a, s, mempty)++++instance (Monad m, Monoid w, Arbitrary a, CoArbitrary a)+ => Arbitrary (ScriptT e r w s p m a) where+ arbitrary = do+ (a,b) <- arbitrary :: Gen (a,a)+ k <- arbitrary :: Gen Int+ if k`rem`2 == 0+ then return $ return a+ else do+ f <- arbitrary :: Gen (a -> ScriptT e r w s p m a)+ return $ f a >> lift (return b)++instance Show (ScriptT e r w s p m a) where+ show _ = "<Script>"
+ src/Control/Monad/Script/Http.hs view
@@ -0,0 +1,1003 @@+{- |+Module : Control.Monad.Script.Http+Description : A generic monad for expressing HTTP interactions.+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++A basic type and monad for describing HTTP interactions.+-}++{-# LANGUAGE GADTs, Rank2Types, RecordWildCards #-}+module Control.Monad.Script.Http (+ -- * Http+ Http()+ , execHttpM++ -- * HttpT+ , HttpT()+ , execHttpTM+ , liftHttpT++ -- * Error+ , throwError+ , throwJsonError+ , throwHttpException+ , throwIOException+ , catchError+ , catchJsonError+ , catchHttpException+ , catchIOException+ , printError+ , E()++ -- * Reader+ , ask+ , local+ , reader+ , R(..)+ , basicEnv+ , trivialEnv+ , LogOptions(..)+ , basicLogOptions+ , trivialLogOptions++ -- * Writer+ , logEntries+ , W()++ -- * State+ , gets+ , modify+ , S(..)+ , basicState++ -- * Prompt+ , prompt+ , P(..)+ , evalIO+ , evalMockIO++ -- * API+ , comment+ , wait+ , logEntry++ -- ** IO+ , Control.Monad.Script.Http.hPutStrLn+ , hPutStrLnBlocking++ -- ** HTTP calls+ , httpGet+ , httpSilentGet+ , httpPost+ , httpSilentPost+ , httpDelete+ , httpSilentDelete++ -- ** JSON+ , parseJson+ , lookupKeyJson+ , constructFromJson++ -- * Types+ , Url+ , JsonError(..)+ , HttpResponse(..)++ -- * Testing+ , checkHttpM+ , checkHttpTM+) where++import Prelude hiding (lookup)++import Control.Applicative+ ( Applicative(..), (<$>) )+import Control.Concurrent+ ( threadDelay )+import Control.Concurrent.MVar+ ( MVar, withMVar )+import Control.Exception+ ( IOException, Exception, try )+import Control.Monad+ ( Functor(..), Monad(..), ap )+import Control.Lens+ ( preview, (^.) )+import Data.Aeson+ ( Value(Object), Result(Success,Error), FromJSON, fromJSON, decode )+import Data.Aeson.Encode.Pretty+ ( encodePretty )+import Data.Aeson.Lens+ ( _Value )+import Data.ByteString.Lazy+ ( ByteString, fromStrict, readFile, writeFile )+import Data.ByteString.Lazy.Char8+ ( unpack, pack )+import Data.Functor.Identity+ ( Identity() )+import Data.HashMap.Strict+ ( lookup )+import Data.IORef+ ( IORef, newIORef, readIORef, writeIORef )+import Data.String+ ( fromString )+import Data.Text+ ( Text )+import Data.Time+ ( UTCTime )+import Data.Time.Clock.System+ ( getSystemTime, systemToUTCTime )+import Data.Typeable+ ( Typeable )+import Data.Monoid+ ( Monoid(..) )+import Network.HTTP.Client+ ( HttpException(..), CookieJar, HttpExceptionContent(StatusCodeException)+ , Response, responseCookieJar, responseBody+ , responseHeaders, responseVersion, responseStatus )+import Network.HTTP.Types+ ( HttpVersion, Status, ResponseHeaders )+import qualified Network.Wreq as Wreq+ ( Options, getWith, postWith, deleteWith, defaults, responseStatus, headers )+import qualified Network.Wreq.Session as S+ ( Session, newSession, getWith, postWith, deleteWith )+import System.IO+ ( Handle, hPutStrLn, hGetEcho, hSetEcho, hFlush+ , hFlush, hGetLine, hPutStr, hPutChar, stdout )+import System.IO.Error+ ( ioeGetFileName, ioeGetLocation, ioeGetErrorString )+import Test.QuickCheck+ ( Property, Arbitrary(..), Gen )++import qualified Control.Monad.Script as S+import Network.HTTP.Client.Extras+import Data.Aeson.Extras+import Data.MockIO+import Data.MockIO.FileSystem++++-- | An HTTP session returning an @a@, writing to a log of type @W e w@, reading from an environment of type @R e w r@, with state of type @S s@, throwing errors of type @E e@, performing effectful computations described by @P p a@, and with inner monad @m@.+newtype HttpT e r w s p m a = HttpT+ { httpT :: S.ScriptT (E e) (R e w r) (W e w) (S s) (P p) m a+ } deriving Typeable++-- | An HTTP session returning an @a@, writing to a log of type @W e w@, reading from an environment of type @R e w r@, with state of type @S s@, throwing errors of type @E e@, performing effectful computations described by @P p a@. `HttpT` over `Identity`.+type Http e r w s p a = HttpT e r w s p Identity a++instance Functor (HttpT e r w s p m) where+ fmap f = HttpT . fmap f . httpT++instance Applicative (HttpT e r w s p m) where+ pure = return+ (<*>) = ap++instance Monad (HttpT e r w s p m) where+ return = HttpT . return+ (HttpT x) >>= f = HttpT (x >>= (httpT . f))++++-- | Execute an `HttpT` session.+execHttpTM+ :: (Monad (m eff), Monad eff)+ => S s -- ^ Initial state+ -> R e w r -- ^ Environment+ -> (forall u. P p u -> eff u) -- ^ Effect evaluator+ -> (forall u. eff u -> m eff u) -- ^ Lift effects to the inner monad+ -> HttpT e r w s p (m eff) t+ -> m eff (Either (E e) t, S s, W e w)+execHttpTM s r p lift = S.execScriptTM s r p lift . httpT++-- | Turn an `HttpT` into a property; for testing with QuickCheck.+checkHttpTM+ :: (Monad (m eff), Monad eff)+ => S s -- ^ Initial state+ -> R e w r -- ^ Environment+ -> (forall u. P p u -> eff u) -- ^ Effect evaluator+ -> (forall u. eff u -> m eff u) -- ^ Lift effects to the inner monad+ -> (m eff (Either (E e) t, S s, W e w) -> IO q) -- ^ Condense to `IO`+ -> (q -> Bool) -- ^ Result check+ -> HttpT e r w s p (m eff) t+ -> Property+checkHttpTM s r eval lift cond check =+ S.checkScriptTM s r eval lift cond check . httpT++-- | Execute an `Http` session.+execHttpM+ :: (Monad eff)+ => S s -- ^ Initial state+ -> R e w r -- ^ Environment+ -> (forall u. P p u -> eff u) -- ^ Effect evaluator+ -> Http e r w s p t+ -> eff (Either (E e) t, S s, W e w)+execHttpM s r eval = S.execScriptM s r eval . httpT++-- | Turn an `Http` into a `Property`; for testing with QuickCheck.+checkHttpM+ :: (Monad eff)+ => S s -- ^ Initial state+ -> R e w r -- ^ Environment+ -> (forall u. P p u -> eff u) -- ^ Effect evaluator+ -> (eff (Either (E e) t, S s, W e w) -> IO q) -- ^ Condense to `IO`+ -> (q -> Bool) -- ^ Result check+ -> Http e r w s p t+ -> Property+checkHttpM s r eval cond check =+ S.checkScriptM s r eval cond check . httpT++++-- | Retrieve the environment.+ask+ :: HttpT e r w s p m (R e w r)+ask = HttpT S.ask++-- | Run an action with a locally adjusted environment of the same type.+local+ :: (R e w r -> R e w r)+ -> HttpT e r w s p m a+ -> HttpT e r w s p m a+local f = HttpT . S.local f . httpT++-- | Run an action with a locally adjusted environment of a possibly different type.+transport+ :: (R e w r2 -> R e w r1)+ -> HttpT e r1 w s p m a+ -> HttpT e r2 w s p m a+transport f = HttpT . S.transport f . httpT++-- | Retrieve the image of the environment under a given function.+reader+ :: (R e w r -> a)+ -> HttpT e r w s p m a+reader f = HttpT (S.reader f)++-- | Retrieve the current state.+get+ :: HttpT e r w s p m (S s)+get = HttpT S.get++-- | Replace the state.+put+ :: S s+ -> HttpT e r w s p m ()+put s = HttpT (S.put s)++-- | Modify the current state strictly.+modify+ :: (S s -> S s)+ -> HttpT e r w s p m ()+modify f = HttpT (S.modify' f)++-- | Retrieve the image of the current state under a given function.+gets+ :: (S s -> a)+ -> HttpT e r w s p m a+gets f = HttpT (S.gets f)++-- | Do not export; we want to only allow writes to the log via functions that call @logNow@.+tell+ :: W e w+ -> HttpT e r w s p m ()+tell w = HttpT (S.tell w)++-- | Run an action that returns a value and a log-adjusting function, and apply the function to the local log.+pass+ :: HttpT e r w s p m (a, W e w -> W e w)+ -> HttpT e r w s p m a+pass = HttpT . S.pass . httpT++-- | Run an action, applying a function to the local log.+censor+ :: (W e w -> W e w)+ -> HttpT e r w s p m a+ -> HttpT e r w s p m a+censor f = HttpT . S.censor f . httpT++-- | Inject an 'Either' into a 'Script'.+except+ :: Either (E e) a+ -> HttpT e r w s p m a+except e = HttpT (S.except e)++-- | Raise an error+throw+ :: E e+ -> HttpT e r w s p m a+throw e = HttpT (S.throw e)++-- | Run an action, applying a handler in case of an error result.+catch+ :: HttpT e r w s p m a -- ^ Computation that may raise an error+ -> (E e -> HttpT e r w s p m a) -- ^ Handler+ -> HttpT e r w s p m a+catch x f = HttpT (S.catch (httpT x) (httpT . f))++-- | Inject an atomic effect.+prompt+ :: P p a+ -> HttpT e r w s p m a+prompt p = HttpT (S.prompt p)++-- | Lift a value from the inner monad+liftHttpT+ :: (Monad m)+ => m a+ -> HttpT e r w s p m a+liftHttpT = HttpT . S.lift++++-- | Error type.+data E e+ = E_Http HttpException+ | E_IO IOException+ | E_Json JsonError+ | E e -- ^ Client-supplied error type.++-- | Pretty printer for errors+printError :: (e -> String) -> E e -> String+printError p err = case err of+ E_Http e -> unlines [ "HTTP Exception:", show e ]+ E_IO e -> unlines [ "IO Exception:", show e ]+ E_Json e -> unlines [ "JSON Error:", show e ]+ E e -> unlines [ "Error:", p e ]++-- | Also logs the exception.+throwHttpException+ :: HttpException+ -> HttpT e r w s p m a+throwHttpException e = do+ logNow $ errorMessage $ E_Http e+ throw $ E_Http e++-- | Re-throws other error types.+catchHttpException+ :: HttpT e r w s p m a+ -> (HttpException -> HttpT e r w s p m a) -- ^ Handler+ -> HttpT e r w s p m a+catchHttpException x handler = catch x $ \err ->+ case err of+ E_Http e -> handler e+ _ -> throw err++-- | Also logs the exception.+throwIOException+ :: IOException+ -> HttpT e r w s p m a+throwIOException e = do+ logNow $ errorMessage $ E_IO e+ throw $ E_IO e++-- | Re-throws other error types.+catchIOException+ :: HttpT e r w s p m a+ -> (IOException -> HttpT e r w s p m a) -- ^ Handler+ -> HttpT e r w s p m a+catchIOException x handler = catch x $ \err ->+ case err of+ E_IO e -> handler e+ _ -> throw err++-- | Also logs the exception.+throwJsonError+ :: JsonError+ -> HttpT e r w s p m a+throwJsonError e = do+ logNow $ errorMessage $ E_Json e+ throw $ E_Json e++-- | Re-throws other error types.+catchJsonError+ :: HttpT e r w s p m a+ -> (JsonError -> HttpT e r w s p m a) -- ^ Handler+ -> HttpT e r w s p m a+catchJsonError x handler = catch x $ \err ->+ case err of+ E_Json e -> handler e+ _ -> throw err++-- | Also logs the exception.+throwError+ :: e+ -> HttpT e r w s p m a+throwError e = do+ logNow $ errorMessage $ E e+ throw $ E e++-- | Re-throws other error types.+catchError+ :: HttpT e r w s p m a+ -> (e -> HttpT e r w s p m a) -- ^ Handler+ -> HttpT e r w s p m a+catchError x handler = catch x $ \err ->+ case err of+ E e -> handler e+ _ -> throw err++++-- | Generic session environment.+data R e w r = R+ { _logOptions :: LogOptions e w++ -- | Handle for printing logs+ , _logHandle :: Handle++ -- | Lock used to prevent race conditions when writing to the log.+ , _logLock :: Maybe (MVar ())++ -- | Identifier string for the session; used to help match log entries emitted by the same session.+ , _uid :: String++ -- | Function for elevating 'HttpException's to a client-supplied error type.+ , _httpErrorInject :: HttpException -> Maybe e ++ -- | Client-supplied environment type.+ , _env :: r+ }++-- | Environment constructor+basicEnv+ :: (Show e, Show w)+ => r -- ^ Client-supplied environment value.+ -> R e w r+basicEnv r = R+ { _httpErrorInject = const Nothing+ , _logOptions = basicLogOptions+ , _logHandle = stdout+ , _logLock = Nothing+ , _uid = ""+ , _env = r+ }++-- | Environment constructor+trivialEnv+ :: r -- ^ Client-supplied environment value.+ -> R e w r+trivialEnv r = R+ { _httpErrorInject = const Nothing+ , _logOptions = trivialLogOptions+ , _logHandle = stdout+ , _logLock = Nothing+ , _uid = ""+ , _env = r+ }++-- | Options for tweaking the logs.+data LogOptions e w = LogOptions+ { -- | Toggle color+ _logColor :: Bool++ -- | Toggle JSON pretty printing+ , _logJson :: Bool++ -- | Toggle to silence the logs+ , _logSilent :: Bool++ -- | Toggle for printing HTTP headers+ , _logHeaders :: Bool++ -- | Printer for log entries; first argument colorizes a string, and the tuple argument is (timestamp, uid, message).+ , _logEntryPrinter :: (String -> String) -> (String, String, String) -> String++ -- | Printer for client-supplied error type. The boolean toggles JSON pretty printing.+ , _printUserError :: Bool -> e -> String++ -- | Printer for client-supplied log type. the boolean toggles JSON pretty printing.+ , _printUserLog :: Bool -> w -> String+ }++-- | Noisy, in color, without parsing JSON responses, and using `Show` instances for user-supplied error and log types.+basicLogOptions :: (Show e, Show w) => LogOptions e w+basicLogOptions = LogOptions+ { _logColor = True+ , _logJson = False+ , _logSilent = False+ , _logHeaders = True+ , _logEntryPrinter = basicLogEntryPrinter+ , _printUserError = \_ e -> show e+ , _printUserLog = \_ w -> show w+ }++-- | Noisy, in color, without parsing JSON responses, and using trivial printers for user-supplied error and log types. For testing.+trivialLogOptions :: LogOptions e w+trivialLogOptions = LogOptions+ { _logColor = True+ , _logJson = False+ , _logSilent = False+ , _logHeaders = True+ , _logEntryPrinter = basicLogEntryPrinter+ , _printUserError = \_ _ -> "ERROR"+ , _printUserLog = \_ _ -> "LOG"+ }++basicLogEntryPrinter+ :: (String -> String)+ -> (String, String, String)+ -> String+basicLogEntryPrinter colorize (timestamp, uid, msg) =+ unwords $ filter (/= "")+ [ colorize timestamp, uid, msg ]++++-- | Log type+data W e w = W [(UTCTime, Log e w)]++instance Monoid (W e w) where+ mempty = W []+ mappend (W a1) (W a2) = W (a1 ++ a2)++-- | Log entry type+data Log e w+ = L_Comment String+ | L_Request HttpVerb Url Wreq.Options (Maybe ByteString)+ | L_SilentRequest+ | L_Response HttpResponse+ | L_SilentResponse+ | L_Pause Int+ | L_HttpError HttpException+ | L_IOError IOException+ | L_JsonError JsonError++ -- | Client-supplied error type+ | L_Error e++ -- | Client-supplied log entry type+ | L_Log w+ deriving Show++-- | Used in the logs.+data HttpVerb+ = DELETE | GET | POST+ deriving (Eq, Show)++++-- | Convert errors to log entries+errorMessage :: E e -> Log e w+errorMessage e = case e of+ E_Http err -> L_HttpError err+ E_IO err -> L_IOError err+ E_Json err -> L_JsonError err+ E e -> L_Error e++-- | Used to specify colors for user-supplied log entries.+data Color+ = Red | Blue | Green | Yellow | Magenta++inColor :: Color -> String -> String+inColor c msg = case c of+ Red -> "\x1b[1;31m" ++ msg ++ "\x1b[0;39;49m"+ Blue -> "\x1b[1;34m" ++ msg ++ "\x1b[0;39;49m"+ Green -> "\x1b[1;32m" ++ msg ++ "\x1b[0;39;49m"+ Yellow -> "\x1b[1;33m" ++ msg ++ "\x1b[0;39;49m"+ Magenta -> "\x1b[1;35m" ++ msg ++ "\x1b[0;39;49m"++printEntryWith+ :: Bool -- ^ Json+ -> Bool -- ^ Headers+ -> (Bool -> e -> String)+ -> (Bool -> w -> String)+ -> Log e w+ -> (Color, String)+printEntryWith asJson showHeaders printError printLog entry = case entry of+ L_Comment msg -> (Green, msg)++ L_Request verb url opt payload ->+ let+ head = case (asJson, showHeaders) of+ (True, True) -> unpack $ encodePretty $ jsonResponseHeaders $ opt ^. Wreq.headers+ (False, True) -> show $ opt ^. Wreq.headers+ (_, False) -> ""++ body = case (asJson, payload) of+ (True, Just p) -> case decode p of+ Nothing -> "JSON parse error:\n" ++ unpack p+ Just v -> unpack $ encodePretty (v :: Value)+ (False, Just p) -> unpack p+ (_, Nothing) -> ""++ in+ (Blue, unlines $ filter (/= "") [unwords ["Request", show verb, url], head, body])++ L_SilentRequest -> (Blue, "Silent Request")++ L_Response response ->+ let+ head = case (asJson, showHeaders) of+ (True, True) -> unpack $ encodePretty $ jsonResponseHeaders $ _responseHeaders response+ (False, True) -> show $ _responseHeaders response+ (_, False) -> ""++ body = case asJson of+ True -> unpack $ encodePretty $ preview _Value $ _responseBody response+ False -> show response++ in+ (Blue, unlines $ filter (/= "") ["Response", head, body])++ L_SilentResponse -> (Blue, "Silent Response")++ L_Pause k -> (Magenta, "Wait for " ++ show k ++ "μs")++ L_HttpError e -> if asJson+ then+ let+ unpackHttpError :: HttpException -> Maybe (String, String)+ unpackHttpError err = case err of+ HttpExceptionRequest _ (StatusCodeException s r) -> do+ json <- decode $ fromStrict r+ let status = s ^. Wreq.responseStatus + return (show status, unpack $ encodePretty (json :: Value))+ _ -> Nothing+ in+ case unpackHttpError e of+ Nothing -> (Red, show e)+ Just (code, json) -> (Red, unlines [ unwords [ "HTTP Error Response", code], json ])++ else (Red, show e)++ L_IOError e -> (Red, unwords [ show $ ioeGetFileName e, ioeGetLocation e, ioeGetErrorString e ])++ L_JsonError e -> (Red, "JSON Error: " ++ show e)++ L_Error e -> (Red, unwords [ "ERROR", printError asJson e ])++ L_Log w -> (Yellow, unwords [ "INFO", printLog asJson w ])++-- | Render a log entry+printLogWith+ :: LogOptions e w+ -> ((String -> String) -> (String, String, String) -> String)+ -> (UTCTime, String, Log e w)+ -> Maybe String+printLogWith opt@LogOptions{..} printer (timestamp, uid, entry) =+ if _logSilent+ then Nothing+ else do+ let+ time :: String+ time = take 19 $ show timestamp++ color :: Color -> String -> String+ color c = if _logColor then inColor c else id++ (c,msg) = printEntryWith _logJson _logHeaders _printUserError _printUserLog entry++ Just $ printer (color c) (time, uid, msg)++-- | Extract the user-defined log entries.+logEntries :: W e w -> [w]+logEntries (W xs) = entries xs+ where+ entries [] = []+ entries ((_,w):ws) = case w of+ L_Log u -> u : entries ws+ _ -> entries ws++++-- | State type+data S s = S+ { _httpOptions :: Wreq.Options+ , _httpSession :: Maybe S.Session+ , _userState :: s+ }++-- | State constructor+basicState :: s -> S s+basicState s = S+ { _httpOptions = Wreq.defaults+ , _httpSession = Nothing+ , _userState = s+ }++++-- | Atomic effects+data P p a where+ HPutStrLn+ :: Handle -> String+ -> P p (Either IOException ())+ HPutStrLnBlocking+ :: MVar () -> Handle -> String+ -> P p (Either IOException ())++ GetSystemTime :: P p UTCTime+ ThreadDelay :: Int -> P p ()++ HttpGet+ :: Wreq.Options -> Maybe S.Session -> Url+ -> P p (Either HttpException HttpResponse)+ HttpPost+ :: Wreq.Options -> Maybe S.Session -> Url+ -> ByteString -> P p (Either HttpException HttpResponse)+ HttpDelete+ :: Wreq.Options -> Maybe S.Session -> Url+ -> P p (Either HttpException HttpResponse)++ P :: p a -> P p a++-- | Basic evaluator for interpreting atomic 'Http' effects in 'IO'.+evalIO+ :: (p a -> IO a) -- ^ Evaluator for user effects+ -> P p a+ -> IO a+evalIO eval x = case x of+ HPutStrLn handle string -> try $ do+ System.IO.hPutStrLn handle string+ hFlush handle++ HPutStrLnBlocking lock handle str -> try $ do+ withMVar lock (\() -> System.IO.hPutStrLn handle str)+ hFlush handle++ GetSystemTime -> fmap systemToUTCTime getSystemTime++ ThreadDelay k -> threadDelay k++ HttpGet opts s url -> case s of+ Nothing -> try $ readHttpResponse <$> Wreq.getWith opts url+ Just sn -> try $ readHttpResponse <$> S.getWith opts sn url++ HttpPost opts s url msg -> case s of+ Nothing -> try $ readHttpResponse <$> Wreq.postWith opts url msg+ Just sn -> try $ readHttpResponse <$> S.postWith opts sn url msg++ HttpDelete opts s url -> case s of+ Nothing -> try $ readHttpResponse <$> Wreq.deleteWith opts url+ Just sn -> try $ readHttpResponse <$> S.deleteWith opts sn url++ P act -> eval act++-- | Basic evaluator for interpreting atomic 'Http' effects in 'MockIO'.+evalMockIO+ :: (p a -> MockIO s a)+ -> P p a+ -> MockIO s a+evalMockIO eval x = case x of+ HPutStrLn handle str -> do+ incrementTimer 1+ fmap Right $ modifyMockWorld $ \w -> w+ { _files = appendLines (Right handle) (lines str) $ _files w }++ HPutStrLnBlocking _ handle str -> do+ incrementTimer 1+ fmap Right $ modifyMockWorld $ \w -> w+ { _files = appendLines (Right handle) (lines str) $ _files w }++ GetSystemTime -> do+ incrementTimer 1+ MockWorld{..} <- getMockWorld+ return _time++ ThreadDelay k -> incrementTimer k++ HttpGet _ _ url -> do+ incrementTimer 1+ MockWorld{..} <- getMockWorld+ let (r,t) = unMockNetwork (_httpGet url) _serverState+ modifyMockWorld $ \w -> w { _serverState = t }+ return r++ HttpPost _ _ url payload -> do+ incrementTimer 1+ MockWorld{..} <- getMockWorld+ let (r,t) = unMockNetwork (_httpPost url payload) _serverState+ modifyMockWorld $ \w -> w { _serverState = t }+ return r++ HttpDelete _ _ url -> do+ incrementTimer 1+ MockWorld{..} <- getMockWorld+ let (r,t) = unMockNetwork (_httpDelete url) _serverState+ modifyMockWorld $ \w -> w { _serverState = t }+ return r++ P p -> do+ incrementTimer 1+ eval p++++-- | All log statements should go through @logNow@.+logNow+ :: Log e w+ -> HttpT e r w s p m ()+logNow msg = do+ time <- prompt GetSystemTime+ printer <- reader (_logEntryPrinter . _logOptions)+ R{..} <- ask+ case printLogWith _logOptions printer (time,_uid,msg) of+ Nothing -> return ()+ Just str -> case _logLock of+ Just lock -> hPutStrLnBlocking lock _logHandle str+ Nothing -> Control.Monad.Script.Http.hPutStrLn _logHandle str+ tell $ W [(time, msg)]++-- | Write a comment to the log+comment+ :: String+ -> HttpT e r w s p m ()+comment msg = logNow $ L_Comment msg++-- | Pause the thread+wait+ :: Int -- ^ milliseconds+ -> HttpT e r w s p m ()+wait k = do+ logNow $ L_Pause k+ prompt $ ThreadDelay k++-- | Write an entry to the log+logEntry+ :: w+ -> HttpT e r w s p m ()+logEntry = logNow . L_Log++++-- | Write a line to a handle+hPutStrLn+ :: Handle+ -> String+ -> HttpT e r w s p m ()+hPutStrLn h str = do+ result <- prompt $ HPutStrLn h str+ case result of+ Right () -> return ()+ Left e -> throwIOException e++-- | Write a line to a handle, using the given `MVar` as a lock+hPutStrLnBlocking+ :: MVar ()+ -> Handle+ -> String+ -> HttpT e r w s p m ()+hPutStrLnBlocking lock h str = do+ result <- prompt $ HPutStrLnBlocking lock h str+ case result of+ Right () -> return ()+ Left e -> throwIOException e++++-- | Run a @GET@ request+httpGet+ :: Url+ -> HttpT e r w s p m HttpResponse+httpGet url = do+ R{..} <- ask+ S{..} <- get+ logNow $ L_Request GET url _httpOptions Nothing+ result <- prompt $ HttpGet _httpOptions _httpSession url+ case result of+ Right response -> do+ logNow $ L_Response response+ return response+ Left err -> case _httpErrorInject err of+ Just z -> throwError z+ Nothing -> throwHttpException err++-- | Run a @GET@ request, but do not write the request or response to the logs.+httpSilentGet+ :: Url+ -> HttpT e r w s p m HttpResponse+httpSilentGet url = do+ R{..} <- ask+ S{..} <- get+ logNow L_SilentRequest+ result <- prompt $ HttpGet _httpOptions _httpSession url+ case result of+ Right response -> do+ logNow L_SilentResponse+ return response+ Left err -> case _httpErrorInject err of+ Just z -> throwError z+ Nothing -> throwHttpException err++-- | Run a @POST@ request+httpPost+ :: Url+ -> ByteString -- ^ Payload+ -> HttpT e r w s p m HttpResponse+httpPost url payload = do+ R{..} <- ask+ S{..} <- get+ logNow $ L_Request POST url _httpOptions (Just payload)+ result <- prompt $ HttpPost _httpOptions _httpSession url payload+ case result of+ Right response -> do+ logNow $ L_Response response+ return response+ Left err -> case _httpErrorInject err of+ Just z -> throwError z+ Nothing -> throwHttpException err++-- | Run a @POST@ request, but do not write the request or response to the logs.+httpSilentPost+ :: Url+ -> ByteString -- ^ Payload+ -> HttpT e r w s p m HttpResponse+httpSilentPost url payload = do+ R{..} <- ask+ S{..} <- get+ logNow L_SilentRequest+ result <- prompt $ HttpPost _httpOptions _httpSession url payload+ case result of+ Right response -> do+ logNow L_SilentResponse+ return response+ Left err -> case _httpErrorInject err of+ Just z -> throwError z+ Nothing -> throwHttpException err++-- | Run a @DELETE@ request+httpDelete+ :: Url+ -> HttpT e r w s p m HttpResponse+httpDelete url = do+ R{..} <- ask+ S{..} <- get+ logNow $ L_Request DELETE url _httpOptions Nothing+ result <- prompt $ HttpDelete _httpOptions _httpSession url+ case result of+ Right response -> do+ logNow $ L_Response response+ return response+ Left err -> case _httpErrorInject err of+ Just z -> throwError z+ Nothing -> throwHttpException err++-- | Run a @DELETE@ request, but do not write the request or response to the logs.+httpSilentDelete+ :: Url+ -> HttpT e r w s p m HttpResponse+httpSilentDelete url = do+ R{..} <- ask+ S{..} <- get+ logNow L_SilentRequest+ result <- prompt $ HttpDelete _httpOptions _httpSession url+ case result of+ Right response -> do+ logNow L_SilentResponse+ return response+ Left err -> case _httpErrorInject err of+ Just z -> throwError z+ Nothing -> throwHttpException err++++-- | Parse a `ByteString` to a JSON `Value`.+parseJson+ :: ByteString+ -> HttpT e r w s p m Value+parseJson bytes = case preview _Value bytes of+ Just value -> return value+ Nothing -> throwJsonError $ JsonParseError bytes++-- | Object member lookup.+lookupKeyJson+ :: Text -- ^ Key name+ -> Value -- ^ JSON object+ -> HttpT e r w s p m Value+lookupKeyJson key v = case v of+ Object obj -> case lookup key obj of+ Nothing -> throwJsonError $ JsonKeyDoesNotExist key (Object obj)+ Just value -> return value+ _ -> throwJsonError $ JsonKeyLookupOffObject key v++-- | Decode a `A.Value` to some other type.+constructFromJson+ :: (FromJSON a)+ => Value+ -> HttpT e r w s p m a+constructFromJson value = case fromJSON value of+ Success x -> return x+ Error msg -> throwJsonError $ JsonConstructError msg
+ src/Data/Aeson/Extras.hs view
@@ -0,0 +1,56 @@+{- |+Module : Data.Aeson.Extras+Description : Some stuff not included in Data.Aeson.+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++JSON helpers.+-}++module Data.Aeson.Extras (+ JsonError(..)+) where++import Data.Aeson+ ( Value() )+import Data.ByteString.Lazy+ ( ByteString )+import Data.String+ ( fromString )+import Data.Text+ ( Text )+import Test.QuickCheck+ ( Arbitrary(..), Gen )++++-- | Represents the kinds of errors that can occur when parsing and decoding JSON.+data JsonError+ -- | A generic JSON error; try not to use this.+ = JsonError String+ -- | A failed parse.+ | JsonParseError ByteString+ -- | An attempt to look up the value of a key that does not exist on an object.+ | JsonKeyDoesNotExist Text Value+ -- | An attempt to look up the value of a key on something other than an object.+ | JsonKeyLookupOffObject Text Value+ -- | A failed attempt to convert a `Value` to some other type.+ | JsonConstructError String+ deriving (Eq, Show)++instance Arbitrary JsonError where+ arbitrary = do+ k <- arbitrary :: Gen Int+ case k `mod` 5 of+ 0 -> JsonError <$> arbitrary+ 1 -> JsonParseError <$> (fromString <$> arbitrary)+ 2 -> JsonKeyDoesNotExist <$>+ (fromString <$> arbitrary) <*>+ (fromString <$> arbitrary)+ 3 -> JsonKeyLookupOffObject <$>+ (fromString <$> arbitrary) <*>+ (fromString <$> arbitrary)+ _ -> JsonConstructError <$> arbitrary
+ src/Data/MockIO.hs view
@@ -0,0 +1,210 @@+{- |+Module : Data.MockIO+Description : A mock IO monad for testing.+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++A fake IO monad for testing.+-}++{-# LANGUAGE OverloadedStrings, GADTs, RecordWildCards, ScopedTypeVariables, Rank2Types #-}+module Data.MockIO (+ -- * MockIO+ MockIO(..)+ , getMockWorld+ , putMockWorld+ , modifyMockWorld+ , incrementTimer++ -- * MockWorld+ , MockWorld(..)+ , MockServer(..)+ , epoch+ , basicMockWorld++ -- * MockNetwork+ , MockNetwork(..)+ , errorMockNetwork+ , getMockServer+ , putMockServer+ , modifyMockServer++ -- * Responses+ , _200ok+ , _400badRequest+ , _404notFound+ , _405methodNotAllowed+ , _408requestTimeout+ , _500internalServerError+) where++++import Control.Exception+ ( Exception, SomeException, fromException )+import Control.Monad+ ( ap )+import Data.ByteString.Lazy+ ( ByteString, pack )+import Data.Time+ ( UTCTime(..), Day(..), diffTimeToPicoseconds )+import Data.Time.Clock+ ( addUTCTime )+import Network.HTTP.Client+ ( HttpException, createCookieJar )+import System.IO+ ( Handle )+import Test.QuickCheck+ ( Arbitrary(..), CoArbitrary(..), variant )++import Data.MockIO.FileSystem+import Network.HTTP.Client.Extras++++-- | A state monad over `MockWorld`.+data MockIO s a = MockIO+ { runMockIO :: MockWorld s -> (a, MockWorld s) }++instance Monad (MockIO s) where+ return x = MockIO $ \s -> (x,s)++ (MockIO x) >>= f = MockIO $ \s ->+ let (z,t) = x s in runMockIO (f z) t++instance Applicative (MockIO s) where+ pure = return+ (<*>) = ap++instance Functor (MockIO s) where+ fmap f x = x >>= (return . f)++instance Show (MockIO s a) where+ show _ = "<MockIO>"++instance (Arbitrary a) => Arbitrary (MockIO s a) where+ arbitrary = do+ a <- arbitrary+ return (return a)++-- | Retrieve the current `MockWorld`.+getMockWorld :: MockIO s (MockWorld s)+getMockWorld = MockIO $ \s -> (s,s)++-- | Replace the current `MockWorld`.+putMockWorld :: MockWorld s -> MockIO s ()+putMockWorld s = MockIO $ \_ -> ((),s)++-- | Mutate the current `MockWorld` strictly.+modifyMockWorld :: (MockWorld s -> MockWorld s) -> MockIO s ()+modifyMockWorld f = MockIO $ \s -> ((), f $! s)++-- | Bump the timer by a given number of microseconds.+incrementTimer :: Int -> MockIO s ()+incrementTimer k =+ modifyMockWorld $ \w -> w+ { _time = addUTCTime (fromIntegral k) $ _time w }++++-- | Just enough state to mock out a basic filesystem and HTTP server.+data MockWorld s = MockWorld+ { _files :: FileSystem (Either FilePath Handle)+ , _time :: UTCTime++ , _httpGet :: String -> MockNetwork s HttpResponse+ , _httpPost :: String -> ByteString -> MockNetwork s HttpResponse+ , _httpDelete :: String -> MockNetwork s HttpResponse++ , _serverState :: MockServer s+ }++-- | Type representing the internal state of an HTTP server.+newtype MockServer s = MockServer+ { unMockServer :: s+ } deriving (Eq, Show)++-- | 1970-01-01 00:00:00+epoch :: UTCTime+epoch = UTCTime (ModifiedJulianDay 0) 0++-- | Empty filesystem and trivial HTTP responses+basicMockWorld :: s -> MockWorld s+basicMockWorld s = MockWorld+ { _files = emptyFileSystem+ , _time = epoch++ , _httpGet = \_ -> return $ _200ok "ok"+ , _httpPost = \_ _ -> return $ _200ok "ok"+ , _httpDelete = \_ -> return $ _200ok "ok"++ , _serverState = MockServer s+ }++instance (Eq s) => Eq (MockWorld s) where+ w1 == w2 = (_files w1 == _files w2)+ && (_serverState w1 == _serverState w2)++instance (Show s) => Show (MockWorld s) where+ show w = unlines+ [ "Filesystem:", "===========", show $ _files w+ , "Timestamp:", "==========", show $ _time w+ , "Server State:", "=============", show $ _serverState w+ ]++instance (Arbitrary s) => Arbitrary (MockWorld s) where+ arbitrary = basicMockWorld <$> arbitrary++instance (CoArbitrary s) => CoArbitrary (MockWorld s) where+ coarbitrary w =+ variant (diffTimeToPicoseconds $ utctDayTime $ _time w)++++-- | State monad representing network interaction.+data MockNetwork s a = MockNetwork+ { unMockNetwork :: MockServer s -> (Either HttpException a, MockServer s) }++instance Monad (MockNetwork s) where+ return x = MockNetwork $ \s -> (Right x, s)++ (MockNetwork x) >>= f = MockNetwork $ \s ->+ let (z,t) = x s in+ case z of+ Left e -> (Left e, t)+ Right a -> unMockNetwork (f a) t++instance Applicative (MockNetwork s) where+ pure = return+ (<*>) = ap++instance Functor (MockNetwork s) where+ fmap f x = x >>= (return . f)++instance Show (MockNetwork s a) where+ show _ = "<MockNetwork>"++instance (Arbitrary a) => Arbitrary (MockNetwork s a) where+ arbitrary = do+ a <- arbitrary+ return (return a)++-- | Throw an `HttpException`.+errorMockNetwork :: HttpException -> MockNetwork s a+errorMockNetwork e = MockNetwork $ \s -> (Left e, s)++-- | Retrieve the internal state of the fake HTTP server.+getMockServer :: MockNetwork s s+getMockServer = MockNetwork $ \s -> (Right $ unMockServer s,s)++-- | Replace the internal state of the fake HTTP server.+putMockServer :: s -> MockNetwork s ()+putMockServer s = MockNetwork $ \_ -> (Right (), MockServer s)++-- | Mutate the internal state of the fake HTTP server (strictly).+modifyMockServer :: (s -> s) -> MockNetwork s ()+modifyMockServer f = MockNetwork $ \s ->+ (Right (), MockServer . f . unMockServer $! s)
+ src/Data/MockIO/FileSystem.hs view
@@ -0,0 +1,174 @@+{- |+Module : Data.MockIO+Description : A mock IO monad for testing.+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++A fake filesystem for testing.+-}++{-# LANGUAGE ScopedTypeVariables #-}+module Data.MockIO.FileSystem (+ FileSystem(..)+ , File(..)+ , emptyFileSystem+ , fileExists+ , hasFile+ , deleteFile+ , getLines+ , writeLines+ , appendLines+ , readLine+) where++import Data.Maybe+import Data.List++import Test.QuickCheck+ ( Arbitrary(..), Positive(..), Gen, vectorOf )++++-- | Abstraction of a text file consisting of a "handle" and a list of lines.+data File a = File+ { _fileHandle :: a -- ^ File "handle"+ , _fileContents :: [String] -- ^ List of lines+ } deriving Eq++instance (Show a) => Show (File a) where+ show (File h lns) = unlines $+ [ ">>>>> " ++ show h ++ ":" ] ++ lns ++ ["<<<<<"]++++++-- | A mapping from "handles" of type @a@ to lists of lines.+data FileSystem a = FileSystem [File a]++instance (Eq a) => Eq (FileSystem a) where+ (FileSystem as) == (FileSystem bs) = and+ [ all (`elem` bs) as+ , all (`elem` as) bs+ ]++instance (Show a) => Show (FileSystem a) where+ show (FileSystem fs) = concatMap show fs++instance (Eq a, Arbitrary a) => Arbitrary (FileSystem a) where+ arbitrary = do+ Positive n <- arbitrary :: Gen (Positive Int)+ handles <- fmap nub $ vectorOf (n `mod` 20) arbitrary+ FileSystem <$> mapM (\k -> File k <$> arbitrary ) handles++-- | No files; populate with `writeLines` or `appendLines`.+emptyFileSystem :: FileSystem a+emptyFileSystem = FileSystem []++++++getFile :: (Eq a) => a -> FileSystem a -> Maybe (File a)+getFile h (FileSystem fs) = lookup fs+ where+ lookup zs = case zs of+ [] -> Nothing+ f:rest -> if h == _fileHandle f+ then Just f+ else lookup rest++putFile :: (Eq a) => File a -> FileSystem a -> FileSystem a+putFile f (FileSystem fs) = FileSystem $ putFile' fs+ where+ putFile' zs = case zs of+ [] -> [f]+ (g:rest) -> if _fileHandle f == _fileHandle g+ then f : rest+ else g : putFile' rest++-- | Detect whether a file with the given handle exists.+fileExists+ :: (Eq a)+ => a -- ^ File handle+ -> FileSystem a+ -> Bool+fileExists h = isJust . getFile h++-- | Detect whether a file with the given handle exists and has given contents.+hasFile+ :: (Eq a)+ => a -- ^ Handle+ -> [String] -- ^ Contents+ -> FileSystem a+ -> Bool+hasFile h lns fs = case getLines h fs of+ Nothing -> False+ Just ms -> ms == lns++-- | Retrieve the contents of a file, or nothing if the file does not exist.+getLines+ :: (Eq a)+ => a -- ^ Handle+ -> FileSystem a+ -> Maybe [String]+getLines h = fmap _fileContents . getFile h++-- | Overwrite the contents of a file.+writeLines+ :: (Eq a)+ => a -- ^ Handle+ -> [String] -- ^ Contents+ -> FileSystem a+ -> FileSystem a+writeLines a lns = putFile (File a lns)++-- | Append to a file.+appendLines+ :: (Eq a)+ => a -- ^ Handle+ -> [String] -- ^ Contents+ -> FileSystem a+ -> FileSystem a+appendLines h ls (FileSystem fs) = FileSystem $ appendLines' fs+ where+ appendLines' zs = case zs of+ [] -> [File h ls]+ (File u ms):rest -> if u == h+ then (File u (ms ++ ls)) : rest+ else (File u ms) : appendLines' rest++-- | Delete a file; if no such file exists, has no effect.+deleteFile+ :: (Eq a)+ => a -- ^ Handle+ -> FileSystem a+ -> FileSystem a+deleteFile h (FileSystem fs) = FileSystem $ deleteFile' fs+ where+ deleteFile' zs = case zs of+ [] -> []+ m:rest -> if h == _fileHandle m+ then rest+ else m : deleteFile' rest++-- | Read the first line of a file.+readLine+ :: (Eq a)+ => e -- ^ Handle not found error+ -> e -- ^ EOF error+ -> a -- ^ Handle+ -> FileSystem a+ -> Either e (String, FileSystem a)+readLine notFound eof k (FileSystem fs) = getline fs []+ where+ getline xs ys = case xs of+ [] -> Left notFound+ (File u x):rest -> if k == u+ then case x of+ [] -> Left eof+ w:ws -> Right (w, FileSystem $ [File k ws] ++ rest ++ ys)+ else getline rest ((File u x):ys)
+ src/Network/HTTP/Client/Extras.hs view
@@ -0,0 +1,143 @@+{- |+Module : Network.HTTP.Client.Extras+Description : Some stuff not included in Network.HTTP.Client+Copyright : 2018, Automattic, Inc.+License : BSD3+Maintainer : Nathan Bloomfield (nbloomf@gmail.com)+Stability : experimental+Portability : POSIX++HTTP helpers+-}++{-# LANGUAGE RecordWildCards #-}+module Network.HTTP.Client.Extras (+ Url+ , HttpResponse(..)+ , readHttpResponse+ , jsonResponseHeaders++ -- * Responses+ , _200ok+ , _400badRequest+ , _404notFound+ , _405methodNotAllowed+ , _408requestTimeout+ , _500internalServerError+) where++++import qualified Data.ByteString as SB+ ( ByteString, unpack )+import Data.ByteString.Lazy+ ( ByteString, unpack )+import Data.Vector+ ( fromList )+import Network.HTTP.Client+ ( HttpException(..), CookieJar, HttpExceptionContent(StatusCodeException)+ , Response, responseCookieJar, responseBody, createCookieJar+ , responseHeaders, responseVersion, responseStatus )+import Network.HTTP.Types+import Data.Aeson (Value(..), object, (.=))+import qualified Data.Text as T (Text, pack)+++-- | To make type signatures nicer+type Url = String++-- | Non-opaque HTTP response type.+data HttpResponse = HttpResponse+ { _responseStatus :: Status+ , _responseVersion :: HttpVersion+ , _responseHeaders :: ResponseHeaders+ , _responseBody :: ByteString+ , _responseCookieJar :: CookieJar+ } deriving (Eq, Show)++-- | Convert an opaque `Response ByteString` into an `HttpResponse`.+readHttpResponse :: Response ByteString -> HttpResponse+readHttpResponse r = HttpResponse+ { _responseStatus = responseStatus r+ , _responseVersion = responseVersion r+ , _responseHeaders = responseHeaders r+ , _responseBody = responseBody r+ , _responseCookieJar = responseCookieJar r+ }++++-- | Convert response headers to a JSON value; specifically a list of objects, one for each header.+jsonResponseHeaders :: ResponseHeaders -> Value+jsonResponseHeaders =+ Array . fromList . map (\(k,v) -> object [ (key k) .= (val v) ])+ where+ key = T.pack . concatMap esc . show+ val = T.pack . concatMap esc . show++ esc c = case c of+ '\\' -> "\\"+ '"' -> "\\\""+ _ -> [c]++++-- | Status 200; no headers+_200ok :: ByteString -> HttpResponse+_200ok body = HttpResponse+ { _responseStatus = status200+ , _responseVersion = http11+ , _responseHeaders = []+ , _responseBody = body+ , _responseCookieJar = createCookieJar []+ }++-- | Status 400; no headers+_400badRequest :: ByteString -> HttpResponse+_400badRequest body = HttpResponse+ { _responseStatus = status400+ , _responseVersion = http11+ , _responseHeaders = []+ , _responseBody = body+ , _responseCookieJar = createCookieJar []+ }++-- | Status 404; no headers+_404notFound :: ByteString -> HttpResponse+_404notFound body = HttpResponse+ { _responseStatus = status404+ , _responseVersion = http11+ , _responseHeaders = []+ , _responseBody = body+ , _responseCookieJar = createCookieJar []+ }++-- | Status 405; no headers+_405methodNotAllowed :: ByteString -> HttpResponse+_405methodNotAllowed body = HttpResponse+ { _responseStatus = status405+ , _responseVersion = http11+ , _responseHeaders = []+ , _responseBody = body+ , _responseCookieJar = createCookieJar []+ }++-- | Status 408; no headers+_408requestTimeout :: ByteString -> HttpResponse+_408requestTimeout body = HttpResponse+ { _responseStatus = status408+ , _responseVersion = http11+ , _responseHeaders = []+ , _responseBody = body+ , _responseCookieJar = createCookieJar []+ }++-- | Status 500; no headers+_500internalServerError :: ByteString -> HttpResponse+_500internalServerError body = HttpResponse+ { _responseStatus = status500+ , _responseVersion = http11+ , _responseHeaders = []+ , _responseBody = body+ , _responseCookieJar = createCookieJar []+ }
+ test/Control/Monad/Script/Http/Test.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards, Rank2Types, BangPatterns #-}+module Control.Monad.Script.Http.Test (+ tests+) where++import Control.Concurrent.MVar+import System.IO+import Data.Functor.Identity+ ( Identity(..) )+import Data.Proxy+import Data.String+import Data.ByteString.Lazy+ ( ByteString, pack )+import Data.Typeable+import Data.List (isSuffixOf)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Control.Monad.Script.Http+import Data.MockIO++import Data.MockIO.FileSystem+import Data.MockIO.Test.Server+++tests :: Int -> MVar () -> TestTree+tests num lock = testGroup "Http"+ [ localOption (QuickCheckTests $ 10 * num) $ testGroup "Mock IO"+ [ testGroup "Internal"+ [ testProperty "comment: return ()" $+ prop_comment_value pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "comment: state unchanged" $+ prop_comment_state pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "wait: return ()" $+ prop_wait_value pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "wait: state unchanged" $+ prop_wait_state pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "httpGet: return" $+ prop_httpGet pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "httpSilentGet: return" $+ prop_httpSilentGet pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "httpPost: return ()" $+ prop_httpPost pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "httpSilentPost: return ()" $+ prop_httpSilentPost pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "throwError: is caught" $+ prop_throwError pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "throwJsonError: is caught" $+ prop_throwJsonError pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "parseJson: valid" $+ prop_parseJson pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "lookupKeyJson: valid" $+ prop_lookupKeyJson pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ , testProperty "logEntries: value" $+ prop_logEntries_log pU pU pU pU (evalMockIO evalId) (toIO simpleMockWorld) undefined+ ]+ , testGroup "External"+ [ testProperty "comment: is logged" $+ prop_comment_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "comment: silent" $+ prop_comment_silent pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "wait: is logged" $+ prop_wait_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "wait: silent" $+ prop_wait_silent pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "httpGet: is logged" $+ prop_httpGet_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "httpGet: json" $+ prop_httpGet_json pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "httpGet: silent" $+ prop_httpGet_silent pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "httpSilentGet: is not logged" $+ prop_httpSilentGet_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "throwError: is logged" $+ prop_throwError_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ , testProperty "logEntry: is logged" $+ prop_logEntry_write pU pU pU pU (evalMockIO evalId) (toIOs simpleMockWorld) undefined+ ]+ ]+ , localOption (QuickCheckTests num) $ testGroup "Real IO"+ [ testGroup "Internal"+ [ real_internal_tests_for pU pU pU pU+ , real_internal_tests_for pI pI pI pI+ ]+ ]+ ]++real_internal_tests_for+ :: ( Eq s, Eq e, Eq w+ , Show s, Show r, Show e, Show w+ , Arbitrary s, Arbitrary r, Arbitrary e, Arbitrary w+ , Typeable e, Typeable r, Typeable w, Typeable s+ )+ => Proxy e -> Proxy r -> Proxy w -> Proxy s -> TestTree+real_internal_tests_for pe pr pw ps =+ let+ label =+ "e: " ++ show (typeRep pe) ++ "; " +++ "r: " ++ show (typeRep pr) ++ "; " +++ "w: " ++ show (typeRep pw) ++ "; " +++ "s: " ++ show (typeRep ps) ++ " "+ in+ testGroup label+ [ testProperty "comment: return ()" $+ prop_comment_value pe pr pw ps (evalIO evalId) id undefined+ , testProperty "comment: state unchanged" $+ prop_comment_state pe pr pw ps (evalIO evalId) id undefined+ , testProperty "wait: return ()" $+ prop_wait_value pe pr pw ps (evalIO evalId) id undefined+ , testProperty "wait: state unchanged" $+ prop_wait_state pe pr pw ps (evalIO evalId) id undefined+ , testProperty "httpGet: return" $+ prop_httpGet pe pr pw ps (evalIO evalId) id undefined+ , testProperty "httpSilentGet: return" $+ prop_httpSilentGet pe pr pw ps (evalIO evalId) id undefined+ , testProperty "httpPost: return ()" $+ prop_httpPost pe pr pw ps (evalIO evalId) id undefined+ , testProperty "httpSilentPost: return ()" $+ prop_httpSilentPost pe pr pw ps (evalIO evalId) id undefined+ , testProperty "throwError: is caught" $+ prop_throwError pe pr pw ps (evalIO evalId) id undefined+ , testProperty "throwJsonError: is caught" $+ prop_throwJsonError pe pr pw ps (evalIO evalId) id undefined+ , testProperty "parseJson: valid" $+ prop_parseJson pe pr pw ps (evalIO evalId) id undefined+ , testProperty "lookupKeyJson: valid" $+ prop_lookupKeyJson pe pr pw ps (evalIO evalId) id undefined+ , testProperty "logEntries: value" $+ prop_logEntries_log pe pr pw ps (evalIO evalId) id undefined+ ]+++pU :: Proxy ()+pU = Proxy++pI :: Proxy Int+pI = Proxy++toIO :: MockWorld s -> MockIO s a -> IO a+toIO u (MockIO x) = do+ let (a,_) = x u+ return a++toIOs :: MockWorld s -> MockIO s a -> IO (a, MockWorld s)+toIOs u (MockIO x) = do+ return $ x u++as :: a -> a -> a+as _ a = a++testEnv :: r -> R e w r+testEnv r = (trivialEnv r)+ { _logHandle = stdout+ , _logOptions = trivialLogOptions+ { _logSilent = True+ }+ }++jsonEnv :: r -> R e w r+jsonEnv r = (trivialEnv r)+ { _logHandle = stdout+ , _logOptions = trivialLogOptions+ { _logSilent = False+ , _logJson = True+ , _logColor = False+ }+ }++noisyEnv :: r -> R e w r+noisyEnv r = (trivialEnv r)+ { _logHandle = stdout+ , _logOptions = trivialLogOptions+ { _logSilent = False+ }+ }++prop_comment_value+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> String -> Property+prop_comment_value _ _ _ _ eval cond x s r msg =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ comment msg++prop_comment_state+ :: (Monad eff, Eq s)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> String -> Property+prop_comment_state _ _ _ _ eval cond x s r msg =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasState (== s)) $+ as x $ do+ comment msg++prop_comment_write+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> String -> Property+prop_comment_write _ _ _ _ eval cond x s r str =+ let msg = filter (/= '\n') str in+ checkHttpM (basicState s) (noisyEnv r) eval cond+ (hasWorld $ outputContains msg) $+ as x $ do+ comment msg++prop_comment_silent+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> String -> Property+prop_comment_silent _ _ _ _ eval cond x s r str =+ let msg = filter (/= '\n') str in+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasWorld outputIsEmpty) $+ as x $ do+ comment msg++hasWorld+ :: (MockWorld u -> Bool)+ -> (v, MockWorld u)+ -> Bool+hasWorld p (_,w) = p w++outputContains+ :: String+ -> MockWorld u+ -> Bool+outputContains str world =+ case getLines (Right stdout) $ _files world of+ Nothing -> False+ Just ls -> any (isSuffixOf str) ls++outputIsEmpty+ :: MockWorld u -> Bool+outputIsEmpty world =+ _files world == emptyFileSystem++prop_wait_value+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> Int -> Property+prop_wait_value _ _ _ _ eval cond x s r k =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ wait k++prop_wait_state+ :: (Monad eff, Eq s)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> Int -> Property+prop_wait_state _ _ _ _ eval cond x s r k =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasState (== s)) $+ as x $ do+ wait k++prop_wait_write+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> Int -> Property+prop_wait_write _ _ _ _ eval cond x s r k =+ checkHttpM (basicState s) (noisyEnv r) eval cond+ (hasWorld $ outputContains $ "Wait for " ++ show k ++ "μs") $+ as x $ do+ wait k++prop_wait_silent+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> Int -> Property+prop_wait_silent _ _ _ _ eval cond x s r k =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasWorld outputIsEmpty) $+ as x $ do+ wait k++prop_httpGet+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> Property+prop_httpGet _ _ _ _ eval cond x s r =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ httpGet "http://example.com"+ return ()++prop_httpGet_json+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> Property+prop_httpGet_json _ _ _ _ eval cond x s r =+ checkHttpM (basicState s) (jsonEnv r) eval cond+ (hasWorld $ outputContains "True") $+ as x $ do+ val1 <- httpGet "http://example.com/json"+ >>= (return . _responseBody)+ >>= parseJson+ val2 <- parseJson "{\"key\":\"value\"}"+ comment $ show $ val1 == val2+ return ()++prop_httpGet_write+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> Property+prop_httpGet_write _ _ _ _ eval cond x s r =+ checkHttpM (basicState s) (noisyEnv r) eval cond+ (hasWorld $ outputContains "GET http://example.com") $+ as x $ do+ httpGet "http://example.com"+ return ()++prop_httpGet_silent+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> Property+prop_httpGet_silent _ _ _ _ eval cond x s r =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasWorld outputIsEmpty) $+ as x $ do+ httpGet "http://example.com"+ return ()++prop_httpSilentGet+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> Property+prop_httpSilentGet _ _ _ _ eval cond x s r =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ httpSilentGet "http://example.com"+ return ()++prop_httpSilentGet_write+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> Property+prop_httpSilentGet_write _ _ _ _ eval cond x s r =+ checkHttpM (basicState s) (noisyEnv r) eval cond+ (hasWorld $ not . outputContains "http://example.com") $+ as x $ do+ httpSilentGet "http://example.com"+ return ()++prop_httpPost+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> String -> Property+prop_httpPost _ _ _ _ eval cond x s r payload =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ httpPost "http://example.com" (fromString payload)+ return ()++prop_httpSilentPost+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> String -> Property+prop_httpSilentPost _ _ _ _ eval cond x s r payload =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ httpSilentPost "http://example.com" (fromString payload)+ return ()++prop_throwError+ :: (Monad eff, Eq e)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p Int+ -> s -> r -> Int -> e -> Property+prop_throwError _ _ _ _ eval cond x s r k err =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== k)) $+ as x $ do+ catchError (throwError err)+ (\e -> if e == err then return k else return (k+1))++prop_logEntry_write+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> w -> Property+prop_logEntry_write _ _ _ _ eval cond x s r w =+ checkHttpM (basicState s) (noisyEnv r) eval cond+ (hasWorld $ outputContains "LOG") $+ as x $ do+ logEntry w+ return ()++prop_logEntries_log+ :: (Monad eff, Eq w)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> w -> w -> w -> Property+prop_logEntries_log _ _ _ _ eval cond x s r w1 w2 w3 =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasLog $ \w -> [w1,w2,w3] == logEntries w) $+ as x $ do+ logEntry w1+ comment "hey!"+ logEntry w2+ logEntry w3+ return ()++prop_throwError_write+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO ((Either (E e) t, S s, W e w), MockWorld u))+ -> Http e r w s p ()+ -> s -> r -> e -> Property+prop_throwError_write _ _ _ _ eval cond x s r e =+ checkHttpM (basicState s) (noisyEnv r) eval cond+ (hasWorld $ outputContains "ERROR") $+ as x $ do+ throwError e+ return ()++prop_throwJsonError+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p Int+ -> s -> r -> Int -> JsonError -> Property+prop_throwJsonError _ _ _ _ eval cond x s r k err =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== k)) $+ as x $ do+ catchJsonError (throwJsonError err)+ (\e -> if e == err then return k else return (k+1))++prop_parseJson+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p ()+ -> s -> r -> Int -> Property+prop_parseJson _ _ _ _ eval cond x s r k =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== ())) $+ as x $ do+ parseJson $ fromString $ "{ \"key\":" ++ show k ++ " }"+ return ()++prop_lookupKeyJson+ :: (Monad eff)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> (forall u. P p u -> eff u)+ -> (forall e s w t. eff (Either (E e) t, S s, W e w) -> IO (Either (E e) t, S s, W e w))+ -> Http e r w s p Int+ -> s -> r -> Int -> Property+prop_lookupKeyJson _ _ _ _ eval cond x s r k =+ checkHttpM (basicState s) (testEnv r) eval cond+ (hasValue (== k)) $+ as x $ do+ obj <- parseJson $ fromString $ "{ \"key\":" ++ show k ++ " }"+ lookupKeyJson "key" obj >>= constructFromJson++hasValue+ :: (t -> Bool)+ -> (Either (E e) t, S s, W e w)+ -> Bool+hasValue p (x,_,_) = case x of+ Left e -> False+ Right a -> p a++hasLog+ :: (W e w -> Bool)+ -> (Either (E e) t, S s, W e w)+ -> Bool+hasLog p (_,_,w) = p w++hasState+ :: (s -> Bool)+ -> (Either (E e) t, S s, W e w)+ -> Bool+hasState p (_,s,_) = p $ _userState s++data Id a = Id { unId :: a }++evalId :: (Monad m) => Id a -> m a+evalId (Id a) = return a
+ test/Control/Monad/Script/Test.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+module Control.Monad.Script.Test (+ tests+) where++import Data.Proxy+import Data.Functor.Classes+import Data.Functor.Identity+import Data.Typeable+import Text.Show.Functions++import Test.Tasty+import Test.Tasty.QuickCheck++import Control.Monad.Script++tests :: Int -> TestTree+tests num =+ localOption (QuickCheckTests $ 10 * num) $+ testGroup "Script"+ [ test_script_properties+ ]++++as :: a -> a -> a+as _ a = a++++scriptEq+ :: (Monad m, Eq a, Eq e, Eq s, Eq w, Eq1 m)+ => s+ -> r+ -> (forall u. p u -> u)+ -> ScriptT e r w s p m a+ -> ScriptT e r w s p m a+ -> Bool+scriptEq s r eval sc1 sc2 =+ liftEq (==)+ (execScriptT s r eval sc1)+ (execScriptT s r eval sc2)++++prop_right_identity_law+ :: (Monad m, Monoid w, Eq a, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> Proxy p -> Proxy a -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> ScriptT e r w s p m a -> Bool+prop_right_identity_law _ _ _ _ _ _ _ eval s r x =+ scriptEq s r eval (x >>= return) x++++prop_left_identity_law+ :: (Monad m, Monoid w, Eq b, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> a -> (a -> ScriptT e r w s p m b) -> Bool+prop_left_identity_law _ _ _ _ _ _ _ _ eval s r a f =+ scriptEq s r eval (return a >>= f) (f a)++++prop_associativity_law+ :: (Monad m, Monoid w, Eq c, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w -> Proxy s+ -> Proxy p -> Proxy a -> Proxy b -> Proxy c -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r+ -> ScriptT e r w s p m a+ -> (a -> ScriptT e r w s p m b)+ -> (b -> ScriptT e r w s p m c)+ -> Bool+prop_associativity_law _ _ _ _ _ _ _ _ _ eval s r x f g =+ scriptEq s r eval ((x >>= f) >>= g) (x >>= (\z -> f z >>= g))++++prop_applicative_identity_law+ :: (Monad m, Monoid w, Eq a, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy a -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> ScriptT e r w s p m a -> Bool+prop_applicative_identity_law _ _ _ _ _ _ _ eval s r x =+ scriptEq s r eval (pure id <*> x) x++++prop_applicative_hom_law+ :: (Monad m, Monoid w, Eq a, Eq b, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> (a -> b) -> a -> ScriptT e r w s p m a -> Bool+prop_applicative_hom_law _ _ _ _ _ _ _ _ eval s r f a x =+ scriptEq s r eval+ (pure f <*> (as x $ pure a))+ (pure (f a))++++prop_applicative_interchange_law+ :: (Monad m, Monoid w, Eq a, Eq b, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r+ -> ScriptT e r w s p m (a -> b)+ -> a+ -> ScriptT e r w s p m a -> Bool+prop_applicative_interchange_law _ _ _ _ _ _ _ _ eval s r u a x =+ scriptEq s r eval+ (u <*> (as x $ pure a))+ (pure ($ a) <*> u)++++prop_applicative_composition_law+ :: (Monad m, Monoid w, Eq a, Eq b, Eq c, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy a -> Proxy b -> Proxy c -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r+ -> ScriptT e r w s p m (a -> b)+ -> ScriptT e r w s p m (b -> c)+ -> ScriptT e r w s p m a+ -> Bool+prop_applicative_composition_law _ _ _ _ _ _ _ _ _ eval s r u v x =+ scriptEq s r eval+ (pure (.) <*> v <*> u <*> x)+ (v <*> (u <*> x))++++prop_tell_hom_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> w -> w -> ScriptT e r w s p m () -> Bool+prop_tell_hom_law _ _ _ _ _ _ eval s r w1 w2 x =+ scriptEq s r eval+ (as x (tell w1) >> as x (tell w2))+ (as x (tell (mappend w1 w2)))++++prop_listen_tell_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> w -> ScriptT e r w s p m () -> Bool+prop_listen_tell_law _ _ _ _ _ _ eval s r w x =+ scriptEq s r eval+ (listen (as x (tell w)))+ ((as x (tell w)) >> return ((),w))++++prop_censor_tell_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> (w -> w) -> w -> ScriptT e r w s p m () -> Bool+prop_censor_tell_law _ _ _ _ _ _ eval s r f w x =+ scriptEq s r eval+ (censor f (as x (tell w)))+ (as x (tell (f w)))++++prop_get_put_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> ScriptT e r w s p m s -> Bool+prop_get_put_law _ _ _ _ _ _ eval s r x =+ scriptEq s r eval+ ((as x get) >>= put)+ (return ())++++prop_put_put_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> s -> s -> ScriptT e r w s p m () -> Bool+prop_put_put_law _ _ _ _ _ _ eval s r u v x =+ scriptEq s r eval+ ((as x (put u)) >> put v)+ (as x (put v))++++prop_put_get_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> s -> ScriptT e r w s p m () -> Bool+prop_put_get_law _ _ _ _ _ _ eval s r u x =+ scriptEq s r eval+ ((as x (put u)) >> get)+ ((as x (put u)) >> return u)++++prop_put_modify_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> s -> (s -> s) -> ScriptT e r w s p m () -> Bool+prop_put_modify_law _ _ _ _ _ _ eval s r u f x =+ scriptEq s r eval+ ((as x (put u)) >> modify f)+ ((as x (put $ f u)))++++prop_put_modify'_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> s -> (s -> s) -> ScriptT e r w s p m () -> Bool+prop_put_modify'_law _ _ _ _ _ _ eval s r u f x =+ scriptEq s r eval+ ((as x (put u)) >> modify' f)+ ((as x (put $ f u)))++++prop_gets_modify_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq a, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m -> Proxy a+ -> (forall u. p u -> u)+ -> s -> r -> (s -> a) -> ScriptT e r w s p m a -> Bool+prop_gets_modify_law _ _ _ _ _ _ _ eval s r f x =+ scriptEq s r eval+ (gets f)+ (as x (f <$> get))++++prop_reader_ask_law+ :: (Monad m, Monoid w, Eq e, Eq a, Eq s, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m -> Proxy a+ -> (forall u. p u -> u)+ -> s -> r -> (r -> a) -> ScriptT e r w s p m a -> Bool+prop_reader_ask_law _ _ _ _ _ _ _ eval s r f x =+ scriptEq s r eval+ (reader f)+ (as x (f <$> ask))++++prop_local_ask_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq r, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> (r -> r) -> ScriptT e r w s p m r -> Bool+prop_local_ask_law _ _ _ _ _ _ eval s r f x =+ scriptEq s r eval+ (as x (local f ask))+ (as x (f <$> ask))++++prop_throw_catch_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq r, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> e -> ScriptT e r w s p m e -> Bool+prop_throw_catch_law _ _ _ _ _ _ eval s r e x =+ scriptEq s r eval+ (as x (return e))+ (as x (catch (throw e) return))++++prop_catch_return_law+ :: (Monad m, Monoid w, Eq e, Eq a, Eq s, Eq r, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy a -> Proxy m+ -> (forall u. p u -> u)+ -> s -> r -> a -> ScriptT e r w s p m a -> Bool+prop_catch_return_law _ _ _ _ _ _ _ eval s r a x =+ scriptEq s r eval+ (as x (return a))+ (as x (catch (return a) undefined))++++prop_throw_except_law+ :: (Monad m, Monoid w, Eq e, Eq s, Eq r, Eq a, Eq w, Eq1 m)+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m -> Proxy a+ -> (forall u. p u -> u)+ -> s -> r -> e -> ScriptT e r w s p m a -> Bool+prop_throw_except_law _ _ _ _ _ _ _ eval s r e x =+ scriptEq s r eval+ (as x (except $ Left e))+ (as x (throw e))++++prop_return_except_law+ :: ( Monad m+ , Monoid w+ , Eq e, Eq s, Eq r, Eq a, Eq w+ , Eq1 m+ )+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m -> Proxy a+ -> (forall u. p u -> u)+ -> s -> r -> a -> ScriptT e r w s p m a -> Bool+prop_return_except_law _ _ _ _ _ _ _ eval s r a x =+ scriptEq s r eval+ (as x (except $ Right a))+ (as x (return a))++++prop_throw_triage_law+ :: ( Monad m+ , Monoid w+ , Eq e, Eq s, Eq r, Eq a, Eq w+ , Eq1 m+ )+ => Proxy e -> Proxy r -> Proxy w+ -> Proxy s -> Proxy p -> Proxy m -> Proxy a+ -> (forall u. p u -> u)+ -> s -> r -> e -> (e -> e) -> ScriptT e r w s p m a -> Bool+prop_throw_triage_law _ _ _ _ _ _ _ eval s r e f x =+ scriptEq s r eval+ (as x (triage f $ throw e))+ (as x (throw (f e)))++++test_script_properties_for+ :: ( Monad m+ , Monoid w+ , Eq a, Eq b, Eq c, Eq e, Eq s, Eq w, Eq r+ , Eq1 m+ , Show s, Show r, Show a, Show w, Show e+ , Arbitrary s, Arbitrary r, Arbitrary a, Arbitrary b+ , Arbitrary c, Arbitrary w, Arbitrary e+ , CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary w+ , CoArbitrary s, CoArbitrary r, CoArbitrary e+ , Typeable a, Typeable b, Typeable c, Typeable e, Typeable r+ , Typeable w, Typeable s, Typeable p, Typeable m+ )+ => Proxy e -> Proxy r -> Proxy w -> Proxy s -> Proxy p+ -> Proxy a -> Proxy b -> Proxy c -> Proxy m+ -> (forall u. p u -> u)+ -> TestTree+test_script_properties_for pe pr pw ps pp pa pb pc pm eval =+ let+ label = "Script: " +++ "E: " ++ show (typeRep pe) ++ " " +++ "R: " ++ show (typeRep pr) ++ " " +++ "W: " ++ show (typeRep pw) ++ " " +++ "S: " ++ show (typeRep ps) ++ " " +++ "P: " ++ show (typeRep pp) ++ ", " +++ "a: " ++ show (typeRep pa) ++ ", " +++ "b: " ++ show (typeRep pb) ++ ", " +++ "c: " ++ show (typeRep pc) ++ ", " +++ "m: " ++ show (typeRep pm)+ in+ testGroup label $+ [ testGroup "Monad Laws"+ [ testProperty "x >>= return === x" $+ prop_right_identity_law pe pr pw ps pp pa pm eval+ , testProperty "return a >>= f === f a" $+ prop_left_identity_law pe pr pw ps pp pa pb pm eval+ , testProperty "(x >>= f) >>= g === x >>= (\\z -> f z >>= g)" $+ prop_associativity_law pe pr pw ps pp pa pb pc pm eval+ ]+ , testGroup "Applicative Laws"+ [ testProperty "pure id <*> x === x" $+ prop_applicative_identity_law pe pr pw ps pp pa pm eval+ , testProperty "pure f <*> pure x === pure (f x)" $+ prop_applicative_hom_law pe pr pw ps pp pa pb pm eval+ , testProperty "u <*> pure x === pure ($ x) <*> u" $+ prop_applicative_interchange_law pe pr pw ps pp pa pb pm eval+ , testProperty "pure (.) <*> v <*> u <*> x === v <*> (u <*> x)" $+ prop_applicative_composition_law pe pr pw ps pp pa pb pc pm eval+ ]+ , testGroup "Writer Laws"+ [ testProperty "tell u >> tell v === tell (mappend u v)" $+ prop_tell_hom_law pe pr pw ps pp pm eval+ , testProperty "listen (tell w) === tell w >> return ((),w)" $+ prop_listen_tell_law pe pr pw ps pp pm eval+ , testProperty "censor f (tell w) === tell (f w)" $+ prop_censor_tell_law pe pr pw ps pp pm eval+ ]+ , testGroup "State Laws"+ [ testProperty "get >>= put === return ()" $+ prop_get_put_law pe pr pw ps pp pm eval+ , testProperty "put a >> put b === put b" $+ prop_put_put_law pe pr pw ps pp pm eval+ , testProperty "put s >> get === put s >> return s" $+ prop_put_get_law pe pr pw ps pp pm eval+ , testProperty "put s >> modify f === put (f s)" $+ prop_put_modify_law pe pr pw ps pp pm eval+ , testProperty "put s >> modify' f === put (f s)" $+ prop_put_modify'_law pe pr pw ps pp pm eval+ , testProperty "gets f === f <$> get" $+ prop_gets_modify_law pe pr pw ps pp pm pa eval+ ]+ , testGroup "Reader Laws"+ [ testProperty "reader f === f <$> ask" $+ prop_reader_ask_law pe pr pw ps pp pm pa eval+ , testProperty "local f ask === f <$> ask" $+ prop_local_ask_law pe pr pw ps pp pm eval+ ]+ , testGroup "Error Laws"+ [ testProperty "return e === catch (throw e) return" $+ prop_throw_catch_law pe pr pw ps pp pm eval+ , testProperty "except (Left e) === throw e" $+ prop_throw_except_law pe pr pw ps pp pm pa eval+ , testProperty "except (Right a) === return a" $+ prop_return_except_law pe pr pw ps pp pm pa eval+ , testProperty "catch (return a) undefined === return a" $+ prop_catch_return_law pe pr pw ps pp pa pm eval+ , testProperty "triage f (throw e) === throw (f e)" $+ prop_throw_triage_law pe pr pw ps pp pm pa eval+ ]+ ]++++test_script_properties :: TestTree+test_script_properties =+ testGroup "Script Properties"+ -- Identity+ [ test_script_properties_for pU pU pU pU pQ pU pU pU pId evalQ+ , test_script_properties_for pU pU pU pU pQ pB pB pB pId evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pI pId evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pB pId evalQ+ , test_script_properties_for pU pU pU pU pQ pI pB pI pId evalQ+ , test_script_properties_for pU pU pU pU pQ pB pI pI pId evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pS pId evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pI pId evalQ+ , test_script_properties_for pU pU pU pU pQ pS pI pS pId evalQ+ , test_script_properties_for pU pU pU pU pQ pI pS pS pId evalQ++ , test_script_properties_for pS pS pS pS pQ pU pU pU pId evalQ+ , test_script_properties_for pS pS pS pS pQ pB pB pB pId evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pI pId evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pB pId evalQ+ , test_script_properties_for pS pS pS pS pQ pI pB pI pId evalQ+ , test_script_properties_for pS pS pS pS pQ pB pI pI pId evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pS pId evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pI pId evalQ+ , test_script_properties_for pS pS pS pS pQ pS pI pS pId evalQ+ , test_script_properties_for pS pS pS pS pQ pI pS pS pId evalQ++ -- Maybe+ , test_script_properties_for pU pU pU pU pQ pU pU pU pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pB pB pB pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pI pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pB pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pI pB pI pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pB pI pI pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pS pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pI pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pS pI pS pMb evalQ+ , test_script_properties_for pU pU pU pU pQ pI pS pS pMb evalQ++ , test_script_properties_for pS pS pS pS pQ pU pU pU pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pB pB pB pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pI pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pB pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pI pB pI pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pB pI pI pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pS pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pI pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pS pI pS pMb evalQ+ , test_script_properties_for pS pS pS pS pQ pI pS pS pMb evalQ++ -- List+ , test_script_properties_for pU pU pU pU pQ pU pU pU pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pB pB pB pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pI pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pB pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pI pB pI pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pB pI pI pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pS pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pI pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pS pI pS pLs evalQ+ , test_script_properties_for pU pU pU pU pQ pI pS pS pLs evalQ++ , test_script_properties_for pS pS pS pS pQ pU pU pU pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pB pB pB pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pI pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pB pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pI pB pI pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pB pI pI pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pS pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pI pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pS pI pS pLs evalQ+ , test_script_properties_for pS pS pS pS pQ pI pS pS pLs evalQ++ -- Either+ , test_script_properties_for pU pU pU pU pQ pU pU pU pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pB pB pB pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pI pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pI pI pB pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pI pB pI pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pB pI pI pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pS pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pS pS pI pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pS pI pS pEi evalQ+ , test_script_properties_for pU pU pU pU pQ pI pS pS pEi evalQ++ , test_script_properties_for pS pS pS pS pQ pU pU pU pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pB pB pB pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pI pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pI pI pB pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pI pB pI pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pB pI pI pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pS pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pS pS pI pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pS pI pS pEi evalQ+ , test_script_properties_for pS pS pS pS pQ pI pS pS pEi evalQ+ ]++++data Q a = Q a++evalQ :: Q a -> a+evalQ (Q a) = a++pQ = Proxy :: Proxy Q+pU = Proxy :: Proxy ()+pB = Proxy :: Proxy Bool+pI = Proxy :: Proxy Int+pS = Proxy :: Proxy String++pId = Proxy :: Proxy Identity+pMb = Proxy :: Proxy Maybe+pLs = Proxy :: Proxy []+pEi = Proxy :: Proxy (Either Int)
+ test/Data/MockIO/FileSystem/Test.hs view
@@ -0,0 +1,127 @@+module Data.MockIO.FileSystem.Test (+ tests+) where++import Data.Proxy+ ( Proxy(..) )++import Test.Tasty+import Test.Tasty.QuickCheck++import Data.MockIO.FileSystem++tests :: Int -> TestTree+tests num =+ localOption (QuickCheckTests $ 20 * num) $+ testGroup "FileSystem"+ [ testProperty "(==) reflexive" $+ prop_filesystem_eq_reflexive pI+ , testProperty "(==) symmetric" $+ prop_filesystem_eq_symmetric pI+ , testProperty "(==) transitive" $+ prop_filesystem_eq_transitive pI+ , testProperty "id /= appendLines h lns" $+ prop_appendLines_not_equal pI+ , testProperty "fileExists h . writeLines h lns" $+ prop_writeLines_fileExists pI+ , testProperty "writeFile is a left zero" $+ prop_writeLines_lzero pI+ , testProperty "hasFile h lns $ writeLines h lns fs == True" $+ prop_hasFile_writeLines pI+ , testProperty "appendLines bs . writeLines as == writeLines (as ++ bs)" $+ prop_appendLines_writeLines pI+ , testProperty "deleteFile is idempotent" $+ prop_deleteFile_idempotent pI+ , testProperty "not (fileExists h $ deleteFile h x)" $+ prop_fileExists_deleteFile pI+ , testProperty "get line from deleted file" $+ prop_readLine_deleteFile pI+ , testProperty "get line from empty file" $+ prop_readLine_empty pI+ , testProperty "getLines / hasFile" $+ prop_hasFile_getLines pI+ , testProperty "readLine / writeLines" $+ prop_readLine_writeLines pI+ ]++-- Fake handle type+pI :: Proxy Int+pI = Proxy++++prop_filesystem_eq_reflexive+ :: (Eq a) => Proxy a -> FileSystem a -> Bool+prop_filesystem_eq_reflexive _ x =+ x == x++prop_filesystem_eq_symmetric+ :: (Eq a) => Proxy a -> FileSystem a -> FileSystem a -> Bool+prop_filesystem_eq_symmetric _ x y =+ (x == y) == (y == x)++prop_filesystem_eq_transitive+ :: (Eq a) => Proxy a -> FileSystem a -> FileSystem a -> FileSystem a -> Bool+prop_filesystem_eq_transitive _ x y z =+ if (x == y) && (y == z) then x == z else True++prop_appendLines_not_equal+ :: (Eq a) => Proxy a -> a -> String -> FileSystem a -> Bool+prop_appendLines_not_equal _ h lns fs =+ fs /= appendLines h [lns] fs++prop_writeLines_lzero+ :: (Eq a) => Proxy a -> a -> [String] -> [String] -> FileSystem a -> Bool+prop_writeLines_lzero _ h ls ms fs =+ (writeLines h ls fs) == (writeLines h ls $ writeLines h ms fs)++prop_writeLines_fileExists+ :: (Eq a) => Proxy a -> a -> [String] -> FileSystem a -> Bool+prop_writeLines_fileExists _ h lns fs =+ fileExists h $ writeLines h lns fs++prop_hasFile_writeLines+ :: (Eq a) => Proxy a -> a -> [String] -> FileSystem a -> Bool+prop_hasFile_writeLines _ h lns fs =+ hasFile h lns $ writeLines h lns fs++prop_appendLines_writeLines+ :: (Eq a) => Proxy a -> a -> [String] -> [String] -> FileSystem a -> Bool+prop_appendLines_writeLines _ h as bs fs =+ (==)+ (appendLines h bs $ writeLines h as fs)+ (writeLines h (as ++ bs) fs)++prop_deleteFile_idempotent+ :: (Eq a) => Proxy a -> a -> FileSystem a -> Bool+prop_deleteFile_idempotent _ h fs =+ (deleteFile h fs) == (deleteFile h $ deleteFile h fs)++prop_fileExists_deleteFile+ :: (Eq a) => Proxy a -> a -> FileSystem a -> Bool+prop_fileExists_deleteFile _ h fs =+ not (fileExists h $ deleteFile h fs)++prop_readLine_deleteFile+ :: (Eq a) => Proxy a -> a -> Int -> FileSystem a -> Bool+prop_readLine_deleteFile _ h err fs =+ (Left err) == readLine err (err+1) h (deleteFile h fs)++prop_readLine_empty+ :: (Eq a) => Proxy a -> a -> Int -> FileSystem a -> Bool+prop_readLine_empty _ h err fs =+ (Left err) == readLine (err+1) err h (writeLines h [] fs)++prop_hasFile_getLines+ :: (Eq a) => Proxy a -> a -> [String] -> FileSystem a -> Bool+prop_hasFile_getLines _ h ls fs =+ case getLines h fs of+ Nothing -> not $ fileExists h fs+ Just ms -> hasFile h ms fs++prop_readLine_writeLines+ :: (Eq a) => Proxy a -> a -> String -> FileSystem a -> Bool+prop_readLine_writeLines _ h str fs =+ case readLine () () h $ writeLines h [str] fs of+ Left _ -> False+ Right (x,_) -> x == str
+ test/Data/MockIO/Test.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.MockIO.Test (+ tests+) where++import Prelude hiding (lookup)+import Data.ByteString.Lazy (ByteString)+import Control.Exception (SomeException)+import System.IO (Handle, stdout, stderr)+import Data.Proxy+import Data.Typeable+import Text.Show.Functions++import Test.Tasty+import Test.Tasty.QuickCheck++import Data.MockIO.FileSystem+import Control.Monad.Script.Http+import Data.MockIO++++tests :: Int -> TestTree+tests num = localOption (QuickCheckTests $ 50 * num) $+ testGroup "MockIO"+ [ test_mockio_properties+ , test_mocknet_properties+ ]++++as :: x -> x -> x+as _ = id++pU = Proxy :: Proxy ()+pB = Proxy :: Proxy Bool+pI = Proxy :: Proxy Int+++++mockIOEq+ :: (Eq s, Eq a)+ => s+ -> MockIO s a+ -> MockIO s a+ -> Bool+mockIOEq s x y =+ (==)+ (runMockIO x $ basicMockWorld s)+ (runMockIO y $ basicMockWorld s)++test_mockio_properties :: TestTree+test_mockio_properties =+ testGroup "MockIO Properties"+ [ test_mockio_properties_for pU pU pU pU+ , test_mockio_properties_for pB pB pB pB+ , test_mockio_properties_for pI pI pI pI+ ]++test_mockio_properties_for+ :: ( Eq a, Eq b, Eq c, Eq s+ , Show a, Show b, Show c, Show s+ , Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary s+ , CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary s+ , Typeable a, Typeable b, Typeable c, Typeable s+ )+ => Proxy a -> Proxy b -> Proxy c -> Proxy s -> TestTree+test_mockio_properties_for pa pb pc ps =+ let+ label = "MockIO: " +++ "s: " ++ show (typeRep ps) ++ " " +++ "a: " ++ show (typeRep pa) ++ " " +++ "b: " ++ show (typeRep pb) ++ " " +++ "c: " ++ show (typeRep pc)+ in+ testGroup label+ [ testGroup "Monad Laws"+ [ testProperty "x >>= return === x" $+ prop_mockio_right_identity_law ps pa+ , testProperty "return a >>= f === f a" $+ prop_mockio_left_identity_law ps pa+ , testProperty "(x >>= f) >>= g === x >>= (\\z -> f z >>= g)" $+ prop_mockio_associativity_law pa pb pc ps+ ]+ , testGroup "Applicative Laws"+ [ testProperty "pure id <*> x === x" $+ prop_mockio_applicative_identity_law ps pa+ , testProperty "pure f <*> pure x === pure (f x)" $+ prop_mockio_applicative_hom_law ps pa pb+ , testProperty "u <*> pure x === pure ($ x) <*> u" $+ prop_mockio_applicative_interchange_law ps pa pb+ , testProperty "pure (.) <*> v <*> u <*> x === v <*> (u <*> x)" $+ prop_mockio_applicative_composition_law ps pa pb pc+ ]+ , testGroup "State Laws"+ [ testProperty "get >>= put === return ()" $+ prop_mockio_get_put_law ps+ , testProperty "put s >> put t === put t" $+ prop_mockio_put_put_law ps+ , testProperty "put s >> get === put s >> return s" $+ prop_mockio_put_get_law ps+ , testProperty "put s >> modify f === put (f s)" $+ prop_mockio_put_modify_law ps+ ]+ ]++++prop_mockio_right_identity_law+ :: (Eq s, Eq a)+ => Proxy s -> Proxy a+ -> s -> MockIO s a -> Bool+prop_mockio_right_identity_law _ _ s x =+ mockIOEq s (x >>= return) x++prop_mockio_left_identity_law+ :: (Eq s, Eq a)+ => Proxy s -> Proxy a+ -> s -> a -> (a -> MockIO s a) -> Bool+prop_mockio_left_identity_law _ _ s a f =+ mockIOEq s (return a >>= f) (f a)++prop_mockio_associativity_law+ :: (Eq s, Eq c)+ => Proxy s -> Proxy a -> Proxy b -> Proxy c+ -> s -> MockIO s a+ -> (a -> MockIO s b)+ -> (b -> MockIO s c)+ -> Bool+prop_mockio_associativity_law _ _ _ _ s x f g =+ mockIOEq s ((x >>= f) >>= g) (x >>= (\z -> f z >>= g))++prop_mockio_get_put_law+ :: (Eq s)+ => Proxy s -> s -> MockIO s (MockWorld s) -> s -> Bool+prop_mockio_get_put_law _ u x s =+ mockIOEq u ((as x getMockWorld) >>= putMockWorld) (return ())++prop_mockio_put_put_law+ :: (Eq s)+ => Proxy s -> s -> MockIO s () -> MockWorld s -> MockWorld s -> Bool+prop_mockio_put_put_law _ u x s t =+ mockIOEq u+ ((as x $ putMockWorld s) >> (putMockWorld t))+ (putMockWorld t)++prop_mockio_put_get_law+ :: (Eq s)+ => Proxy s -> s -> MockWorld s -> MockIO s () -> Bool+prop_mockio_put_get_law _ s u x =+ mockIOEq s+ ((as x $ putMockWorld u) >> getMockWorld)+ ((as x $ putMockWorld u) >> return u)++prop_mockio_put_modify_law+ :: (Eq s)+ => Proxy s -> s -> MockWorld s+ -> (MockWorld s -> MockWorld s) -> MockIO s () -> Bool+prop_mockio_put_modify_law _ s u f x =+ mockIOEq s+ ((as x $ putMockWorld u) >> modifyMockWorld f)+ ((as x $ putMockWorld $ f u))++prop_mockio_applicative_identity_law+ :: (Eq a, Eq s)+ => Proxy s -> Proxy a+ -> s -> MockIO s a -> Bool+prop_mockio_applicative_identity_law _ _ s x =+ mockIOEq s (pure id <*> x) x++prop_mockio_applicative_hom_law+ :: (Eq b, Eq s)+ => Proxy s -> Proxy a -> Proxy b+ -> s -> (a -> b) -> a -> MockIO s a -> Bool+prop_mockio_applicative_hom_law _ _ _ s f a x =+ mockIOEq s+ (pure f <*> (as x $ pure a))+ (pure (f a))++prop_mockio_applicative_interchange_law+ :: (Eq a, Eq b, Eq s)+ => Proxy s -> Proxy a -> Proxy b+ -> s+ -> MockIO s (a -> b)+ -> a+ -> MockIO s a -> Bool+prop_mockio_applicative_interchange_law _ _ _ s u a x =+ mockIOEq s+ (u <*> (as x $ pure a))+ (pure ($ a) <*> u)++prop_mockio_applicative_composition_law+ :: (Eq c, Eq s)+ => Proxy s -> Proxy a -> Proxy b -> Proxy c+ -> s+ -> MockIO s (a -> b)+ -> MockIO s (b -> c)+ -> MockIO s a+ -> Bool+prop_mockio_applicative_composition_law _ _ _ _ s u v x =+ mockIOEq s+ (pure (.) <*> v <*> u <*> x)+ (v <*> (u <*> x))++++++mockNetEq+ :: (Eq s, Eq a)+ => s+ -> MockNetwork s a+ -> MockNetwork s a+ -> Bool+mockNetEq s x y =+ let+ (r1,s1) = unMockNetwork x $ MockServer s+ (r2,s2) = unMockNetwork y $ MockServer s+ in+ case (r1,r2) of+ (Right a1, Right a2) -> a1 == a2 && s1 == s2+ (Left _, Left _) -> s1 == s2+ _ -> False++test_mocknet_properties :: TestTree+test_mocknet_properties =+ testGroup "MockNetwork"+ [ test_mocknet_properties_for pU pU pU pU+ , test_mocknet_properties_for pB pB pB pB+ , test_mocknet_properties_for pI pI pI pI+ ]++test_mocknet_properties_for+ :: ( Eq a, Eq b, Eq c, Eq s+ , Show a, Show b, Show c, Show s+ , Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary s+ , CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary s+ , Typeable a, Typeable b, Typeable c, Typeable s+ )+ => Proxy a -> Proxy b -> Proxy c -> Proxy s -> TestTree+test_mocknet_properties_for pa pb pc ps =+ let+ label = "MockIO: " +++ "s: " ++ show (typeRep ps) ++ " " +++ "a: " ++ show (typeRep pa) ++ " " +++ "b: " ++ show (typeRep pb) ++ " " +++ "c: " ++ show (typeRep pc)+ in+ testGroup label+ [ testGroup "Monad Properties"+ [ testProperty "x >>= return === x" $+ prop_mocknet_right_identity_law ps pa+ , testProperty "return a >>= f === f a" $+ prop_mocknet_left_identity_law ps pa+ , testProperty "(x >>= f) >>= g === x >>= (\\z -> f z >>= g)" $+ prop_mocknet_associativity_law pa pb pc ps+ ]+ , testGroup "Applicative Properties"+ [ testProperty "pure id <*> x === x" $+ prop_mocknet_applicative_identity_law ps pa+ , testProperty "pure f <*> pure x === pure (f x)" $+ prop_mocknet_applicative_hom_law ps pa pb+ , testProperty "u <*> pure x === pure ($ x) <*> u" $+ prop_mocknet_applicative_interchange_law ps pa pb+ , testProperty "pure (.) <*> v <*> u <*> x === v <*> (u <*> x)" $+ prop_mocknet_applicative_composition_law ps pa pb pc+ ]+ , testGroup "State Properties"+ [ testProperty "get >>= put === return ()" $+ prop_mocknet_get_put_law ps+ , testProperty "put s >> put t === put t" $+ prop_mocknet_put_put_law ps+ , testProperty "put s >> get === put s >> return s" $+ prop_mocknet_put_get_law ps+ , testProperty "put s >> modify f === put (f s)" $+ prop_mocknet_put_modify_law ps+ ]+ ]++++prop_mocknet_right_identity_law+ :: (Eq s, Eq a)+ => Proxy s -> Proxy a+ -> s -> MockNetwork s a -> Bool+prop_mocknet_right_identity_law _ _ s x =+ mockNetEq s (x >>= return) x++prop_mocknet_left_identity_law+ :: (Eq s, Eq a)+ => Proxy s -> Proxy a+ -> s -> a -> (a -> MockNetwork s a) -> Bool+prop_mocknet_left_identity_law _ _ s a f =+ mockNetEq s (return a >>= f) (f a)++prop_mocknet_associativity_law+ :: (Eq s, Eq c)+ => Proxy s -> Proxy a -> Proxy b -> Proxy c+ -> s -> MockNetwork s a+ -> (a -> MockNetwork s b)+ -> (b -> MockNetwork s c)+ -> Bool+prop_mocknet_associativity_law _ _ _ _ s x f g =+ mockNetEq s ((x >>= f) >>= g) (x >>= (\z -> f z >>= g))++prop_mocknet_get_put_law+ :: (Eq s)+ => Proxy s -> s -> MockNetwork s s -> s -> Bool+prop_mocknet_get_put_law _ u x s =+ mockNetEq u ((as x getMockServer) >>= putMockServer) (return ())++prop_mocknet_put_put_law+ :: (Eq s)+ => Proxy s -> s -> MockNetwork s () -> s -> s -> Bool+prop_mocknet_put_put_law _ u x s t =+ mockNetEq u+ ((as x $ putMockServer s) >> (putMockServer t))+ (putMockServer t)++prop_mocknet_put_get_law+ :: (Eq s)+ => Proxy s -> s -> s -> MockNetwork s () -> Bool+prop_mocknet_put_get_law _ s u x =+ mockNetEq s+ ((as x $ putMockServer u) >> getMockServer)+ ((as x $ putMockServer u) >> return u)++prop_mocknet_put_modify_law+ :: (Eq s)+ => Proxy s -> s -> s -> (s -> s) -> MockNetwork s () -> Bool+prop_mocknet_put_modify_law _ s u f x =+ mockNetEq s+ ((as x $ putMockServer u) >> modifyMockServer f)+ ((as x $ putMockServer $ f u))++prop_mocknet_applicative_identity_law+ :: (Eq a, Eq s)+ => Proxy s -> Proxy a+ -> s -> MockNetwork s a -> Bool+prop_mocknet_applicative_identity_law _ _ s x =+ mockNetEq s (pure id <*> x) x++prop_mocknet_applicative_hom_law+ :: (Eq b, Eq s)+ => Proxy s -> Proxy a -> Proxy b+ -> s -> (a -> b) -> a -> MockNetwork s a -> Bool+prop_mocknet_applicative_hom_law _ _ _ s f a x =+ mockNetEq s+ (pure f <*> (as x $ pure a))+ (pure (f a))++prop_mocknet_applicative_interchange_law+ :: (Eq a, Eq b, Eq s)+ => Proxy s -> Proxy a -> Proxy b+ -> s+ -> MockNetwork s (a -> b)+ -> a+ -> MockNetwork s a -> Bool+prop_mocknet_applicative_interchange_law _ _ _ s u a x =+ mockNetEq s+ (u <*> (as x $ pure a))+ (pure ($ a) <*> u)++prop_mocknet_applicative_composition_law+ :: (Eq c, Eq s)+ => Proxy s -> Proxy a -> Proxy b -> Proxy c+ -> s+ -> MockNetwork s (a -> b)+ -> MockNetwork s (b -> c)+ -> MockNetwork s a+ -> Bool+prop_mocknet_applicative_composition_law _ _ _ _ s u v x =+ mockNetEq s+ (pure (.) <*> v <*> u <*> x)+ (v <*> (u <*> x))
+ test/Data/MockIO/Test/Server.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.MockIO.Test.Server (+ simpleMockWorld+) where++import Data.MockIO+import Data.MockIO.FileSystem++simpleMockWorld :: MockWorld ()+simpleMockWorld = MockWorld+ { _files = emptyFileSystem+ , _time = epoch+ , _serverState = MockServer ()++ , _httpGet = \url -> case url of+ "http://example.com" -> return $ _200ok+ "welcome to example.com"++ "http://example.com/json" -> return $ _200ok+ "{\"key\":\"value\"}"++ , _httpPost = \url payload -> case url of+ "http://example.com" -> return $ _200ok+ "welcome to example.com"++ , _httpDelete = \url -> case url of+ "http://example.com" -> return $ _200ok+ "welcome to example.com"+ }
+ test/Main.hs view
@@ -0,0 +1,30 @@+module Main where++import Control.Concurrent.MVar+import Test.Tasty+import System.Environment++import Data.MockIO.FileSystem.Test+import Control.Monad.Script.Test+import Control.Monad.Script.Http.Test+import Data.MockIO.Test++main :: IO ()+main = do+ k <- numTests+ setEnv "TASTY_NUM_THREADS" "3"+ lock <- newMVar ()+ defaultMain $+ testGroup "All Tests"+ [ Control.Monad.Script.Test.tests k+ , Control.Monad.Script.Http.Test.tests k lock+ , Data.MockIO.Test.tests k+ , Data.MockIO.FileSystem.Test.tests k+ ]++numTests :: IO Int+numTests = do+ var <- lookupEnv "CI"+ case var of+ Just "true" -> return 1+ _ -> return 10