{- |
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.Text
  ( Text )
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
  { MockIO s a -> MockWorld s -> (a, MockWorld s)
runMockIO :: MockWorld s -> (a, MockWorld s) }

instance Monad (MockIO s) where
  return :: a -> MockIO s a
return a
x = (MockWorld s -> (a, MockWorld s)) -> MockIO s a
forall s a. (MockWorld s -> (a, MockWorld s)) -> MockIO s a
MockIO ((MockWorld s -> (a, MockWorld s)) -> MockIO s a)
-> (MockWorld s -> (a, MockWorld s)) -> MockIO s a
forall a b. (a -> b) -> a -> b
$ \MockWorld s
s -> (a
x,MockWorld s
s)

  (MockIO MockWorld s -> (a, MockWorld s)
x) >>= :: MockIO s a -> (a -> MockIO s b) -> MockIO s b
>>= a -> MockIO s b
f = (MockWorld s -> (b, MockWorld s)) -> MockIO s b
forall s a. (MockWorld s -> (a, MockWorld s)) -> MockIO s a
MockIO ((MockWorld s -> (b, MockWorld s)) -> MockIO s b)
-> (MockWorld s -> (b, MockWorld s)) -> MockIO s b
forall a b. (a -> b) -> a -> b
$ \MockWorld s
s ->
    let (a
z,MockWorld s
t) = MockWorld s -> (a, MockWorld s)
x MockWorld s
s in MockIO s b -> MockWorld s -> (b, MockWorld s)
forall s a. MockIO s a -> MockWorld s -> (a, MockWorld s)
runMockIO (a -> MockIO s b
f a
z) MockWorld s
t

instance Applicative (MockIO s) where
  pure :: a -> MockIO s a
pure = a -> MockIO s a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: MockIO s (a -> b) -> MockIO s a -> MockIO s b
(<*>) = MockIO s (a -> b) -> MockIO s a -> MockIO s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor (MockIO s) where
  fmap :: (a -> b) -> MockIO s a -> MockIO s b
fmap a -> b
f MockIO s a
x = MockIO s a
x MockIO s a -> (a -> MockIO s b) -> MockIO s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> MockIO s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> MockIO s b) -> (a -> b) -> a -> MockIO s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Show (MockIO s a) where
  show :: MockIO s a -> String
show MockIO s a
_ = String
"<MockIO>"

instance (Arbitrary a) => Arbitrary (MockIO s a) where
  arbitrary :: Gen (MockIO s a)
arbitrary = do
    a
a <- Gen a
forall a. Arbitrary a => Gen a
arbitrary
    MockIO s a -> Gen (MockIO s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> MockIO s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

-- | Retrieve the current `MockWorld`.
getMockWorld :: MockIO s (MockWorld s)
getMockWorld :: MockIO s (MockWorld s)
getMockWorld = (MockWorld s -> (MockWorld s, MockWorld s))
-> MockIO s (MockWorld s)
forall s a. (MockWorld s -> (a, MockWorld s)) -> MockIO s a
MockIO ((MockWorld s -> (MockWorld s, MockWorld s))
 -> MockIO s (MockWorld s))
-> (MockWorld s -> (MockWorld s, MockWorld s))
-> MockIO s (MockWorld s)
forall a b. (a -> b) -> a -> b
$ \MockWorld s
s -> (MockWorld s
s,MockWorld s
s)

-- | Replace the current `MockWorld`.
putMockWorld :: MockWorld s -> MockIO s ()
putMockWorld :: MockWorld s -> MockIO s ()
putMockWorld MockWorld s
s = (MockWorld s -> ((), MockWorld s)) -> MockIO s ()
forall s a. (MockWorld s -> (a, MockWorld s)) -> MockIO s a
MockIO ((MockWorld s -> ((), MockWorld s)) -> MockIO s ())
-> (MockWorld s -> ((), MockWorld s)) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
_ -> ((),MockWorld s
s)

-- | Mutate the current `MockWorld` strictly.
modifyMockWorld :: (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld :: (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld MockWorld s -> MockWorld s
f = (MockWorld s -> ((), MockWorld s)) -> MockIO s ()
forall s a. (MockWorld s -> (a, MockWorld s)) -> MockIO s a
MockIO ((MockWorld s -> ((), MockWorld s)) -> MockIO s ())
-> (MockWorld s -> ((), MockWorld s)) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
s -> ((), MockWorld s -> MockWorld s
f (MockWorld s -> MockWorld s) -> MockWorld s -> MockWorld s
forall a b. (a -> b) -> a -> b
$! MockWorld s
s)

-- | Bump the timer by a given number of microseconds.
incrementTimer :: Int -> MockIO s ()
incrementTimer :: Int -> MockIO s ()
incrementTimer Int
k =
  (MockWorld s -> MockWorld s) -> MockIO s ()
forall s. (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld ((MockWorld s -> MockWorld s) -> MockIO s ())
-> (MockWorld s -> MockWorld s) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
w -> MockWorld s
w
    { _time :: UTCTime
_time = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) (UTCTime -> UTCTime) -> UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ MockWorld s -> UTCTime
forall s. MockWorld s -> UTCTime
_time MockWorld s
w }



-- | Just enough state to mock out a basic filesystem and HTTP server.
data MockWorld s = MockWorld
  { MockWorld s -> FileSystem (Either String Handle)
_files :: FileSystem (Either FilePath Handle)
  , MockWorld s -> UTCTime
_time :: UTCTime

  , MockWorld s -> Text -> MockNetwork s HttpResponse
_httpGet :: Text -> MockNetwork s HttpResponse
  , MockWorld s -> Text -> ByteString -> MockNetwork s HttpResponse
_httpPost :: Text -> ByteString -> MockNetwork s HttpResponse
  , MockWorld s -> Text -> MockNetwork s HttpResponse
_httpDelete :: Text -> MockNetwork s HttpResponse

  , MockWorld s -> MockServer s
_serverState :: MockServer s
  }

-- | Type representing the internal state of an HTTP server.
newtype MockServer s = MockServer
  { MockServer s -> s
unMockServer :: s
  } deriving (MockServer s -> MockServer s -> Bool
(MockServer s -> MockServer s -> Bool)
-> (MockServer s -> MockServer s -> Bool) -> Eq (MockServer s)
forall s. Eq s => MockServer s -> MockServer s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MockServer s -> MockServer s -> Bool
$c/= :: forall s. Eq s => MockServer s -> MockServer s -> Bool
== :: MockServer s -> MockServer s -> Bool
$c== :: forall s. Eq s => MockServer s -> MockServer s -> Bool
Eq, Int -> MockServer s -> ShowS
[MockServer s] -> ShowS
MockServer s -> String
(Int -> MockServer s -> ShowS)
-> (MockServer s -> String)
-> ([MockServer s] -> ShowS)
-> Show (MockServer s)
forall s. Show s => Int -> MockServer s -> ShowS
forall s. Show s => [MockServer s] -> ShowS
forall s. Show s => MockServer s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MockServer s] -> ShowS
$cshowList :: forall s. Show s => [MockServer s] -> ShowS
show :: MockServer s -> String
$cshow :: forall s. Show s => MockServer s -> String
showsPrec :: Int -> MockServer s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> MockServer s -> ShowS
Show)

-- | 1970-01-01 00:00:00
epoch :: UTCTime
epoch :: UTCTime
epoch = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0

-- | Empty filesystem and trivial HTTP responses
basicMockWorld :: s -> MockWorld s
basicMockWorld :: s -> MockWorld s
basicMockWorld s
s = MockWorld :: forall s.
FileSystem (Either String Handle)
-> UTCTime
-> (Text -> MockNetwork s HttpResponse)
-> (Text -> ByteString -> MockNetwork s HttpResponse)
-> (Text -> MockNetwork s HttpResponse)
-> MockServer s
-> MockWorld s
MockWorld
  { _files :: FileSystem (Either String Handle)
_files = FileSystem (Either String Handle)
forall a. FileSystem a
emptyFileSystem
  , _time :: UTCTime
_time = UTCTime
epoch

  , _httpGet :: Text -> MockNetwork s HttpResponse
_httpGet = \Text
_ -> HttpResponse -> MockNetwork s HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse -> MockNetwork s HttpResponse)
-> HttpResponse -> MockNetwork s HttpResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> HttpResponse
_200ok ByteString
"ok"
  , _httpPost :: Text -> ByteString -> MockNetwork s HttpResponse
_httpPost = \Text
_ ByteString
_ -> HttpResponse -> MockNetwork s HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse -> MockNetwork s HttpResponse)
-> HttpResponse -> MockNetwork s HttpResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> HttpResponse
_200ok ByteString
"ok"
  , _httpDelete :: Text -> MockNetwork s HttpResponse
_httpDelete = \Text
_ -> HttpResponse -> MockNetwork s HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse -> MockNetwork s HttpResponse)
-> HttpResponse -> MockNetwork s HttpResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> HttpResponse
_200ok ByteString
"ok"

  , _serverState :: MockServer s
_serverState = s -> MockServer s
forall s. s -> MockServer s
MockServer s
s
  }

instance (Eq s) => Eq (MockWorld s) where
  MockWorld s
w1 == :: MockWorld s -> MockWorld s -> Bool
== MockWorld s
w2 = (MockWorld s -> FileSystem (Either String Handle)
forall s. MockWorld s -> FileSystem (Either String Handle)
_files MockWorld s
w1 FileSystem (Either String Handle)
-> FileSystem (Either String Handle) -> Bool
forall a. Eq a => a -> a -> Bool
== MockWorld s -> FileSystem (Either String Handle)
forall s. MockWorld s -> FileSystem (Either String Handle)
_files MockWorld s
w2)
    Bool -> Bool -> Bool
&& (MockWorld s -> MockServer s
forall s. MockWorld s -> MockServer s
_serverState MockWorld s
w1 MockServer s -> MockServer s -> Bool
forall a. Eq a => a -> a -> Bool
== MockWorld s -> MockServer s
forall s. MockWorld s -> MockServer s
_serverState MockWorld s
w2)

instance (Show s) => Show (MockWorld s) where
  show :: MockWorld s -> String
show MockWorld s
w = [String] -> String
unlines
    [ String
"Filesystem:", String
"===========", FileSystem (Either String Handle) -> String
forall a. Show a => a -> String
show (FileSystem (Either String Handle) -> String)
-> FileSystem (Either String Handle) -> String
forall a b. (a -> b) -> a -> b
$ MockWorld s -> FileSystem (Either String Handle)
forall s. MockWorld s -> FileSystem (Either String Handle)
_files MockWorld s
w
    , String
"Timestamp:", String
"==========", UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ MockWorld s -> UTCTime
forall s. MockWorld s -> UTCTime
_time MockWorld s
w
    , String
"Server State:", String
"=============", MockServer s -> String
forall a. Show a => a -> String
show (MockServer s -> String) -> MockServer s -> String
forall a b. (a -> b) -> a -> b
$ MockWorld s -> MockServer s
forall s. MockWorld s -> MockServer s
_serverState MockWorld s
w
    ]

instance (Arbitrary s) => Arbitrary (MockWorld s) where
  arbitrary :: Gen (MockWorld s)
arbitrary = s -> MockWorld s
forall s. s -> MockWorld s
basicMockWorld (s -> MockWorld s) -> Gen s -> Gen (MockWorld s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen s
forall a. Arbitrary a => Gen a
arbitrary

instance (CoArbitrary s) => CoArbitrary (MockWorld s) where
  coarbitrary :: MockWorld s -> Gen b -> Gen b
coarbitrary MockWorld s
w =
    Integer -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
variant (DiffTime -> Integer
diffTimeToPicoseconds (DiffTime -> Integer) -> DiffTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime (UTCTime -> DiffTime) -> UTCTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ MockWorld s -> UTCTime
forall s. MockWorld s -> UTCTime
_time MockWorld s
w)



-- | State monad representing network interaction.
data MockNetwork s a = MockNetwork
  { MockNetwork s a
-> MockServer s -> (Either HttpException a, MockServer s)
unMockNetwork :: MockServer s -> (Either HttpException a, MockServer s) }

instance Monad (MockNetwork s) where
  return :: a -> MockNetwork s a
return a
x = (MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
forall s a.
(MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
MockNetwork ((MockServer s -> (Either HttpException a, MockServer s))
 -> MockNetwork s a)
-> (MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
forall a b. (a -> b) -> a -> b
$ \MockServer s
s -> (a -> Either HttpException a
forall a b. b -> Either a b
Right a
x, MockServer s
s)

  (MockNetwork MockServer s -> (Either HttpException a, MockServer s)
x) >>= :: MockNetwork s a -> (a -> MockNetwork s b) -> MockNetwork s b
>>= a -> MockNetwork s b
f = (MockServer s -> (Either HttpException b, MockServer s))
-> MockNetwork s b
forall s a.
(MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
MockNetwork ((MockServer s -> (Either HttpException b, MockServer s))
 -> MockNetwork s b)
-> (MockServer s -> (Either HttpException b, MockServer s))
-> MockNetwork s b
forall a b. (a -> b) -> a -> b
$ \MockServer s
s ->
    let (Either HttpException a
z,MockServer s
t) = MockServer s -> (Either HttpException a, MockServer s)
x MockServer s
s in
    case Either HttpException a
z of
      Left HttpException
e -> (HttpException -> Either HttpException b
forall a b. a -> Either a b
Left HttpException
e, MockServer s
t)
      Right a
a -> MockNetwork s b
-> MockServer s -> (Either HttpException b, MockServer s)
forall s a.
MockNetwork s a
-> MockServer s -> (Either HttpException a, MockServer s)
unMockNetwork (a -> MockNetwork s b
f a
a) MockServer s
t

instance Applicative (MockNetwork s) where
  pure :: a -> MockNetwork s a
pure = a -> MockNetwork s a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: MockNetwork s (a -> b) -> MockNetwork s a -> MockNetwork s b
(<*>) = MockNetwork s (a -> b) -> MockNetwork s a -> MockNetwork s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor (MockNetwork s) where
  fmap :: (a -> b) -> MockNetwork s a -> MockNetwork s b
fmap a -> b
f MockNetwork s a
x = MockNetwork s a
x MockNetwork s a -> (a -> MockNetwork s b) -> MockNetwork s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> MockNetwork s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> MockNetwork s b) -> (a -> b) -> a -> MockNetwork s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Show (MockNetwork s a) where
  show :: MockNetwork s a -> String
show MockNetwork s a
_ = String
"<MockNetwork>"

instance (Arbitrary a) => Arbitrary (MockNetwork s a) where
  arbitrary :: Gen (MockNetwork s a)
arbitrary = do
    a
a <- Gen a
forall a. Arbitrary a => Gen a
arbitrary
    MockNetwork s a -> Gen (MockNetwork s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> MockNetwork s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

-- | Throw an `HttpException`.
errorMockNetwork :: HttpException -> MockNetwork s a
errorMockNetwork :: HttpException -> MockNetwork s a
errorMockNetwork HttpException
e = (MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
forall s a.
(MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
MockNetwork ((MockServer s -> (Either HttpException a, MockServer s))
 -> MockNetwork s a)
-> (MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
forall a b. (a -> b) -> a -> b
$ \MockServer s
s -> (HttpException -> Either HttpException a
forall a b. a -> Either a b
Left HttpException
e, MockServer s
s)

-- | Retrieve the internal state of the fake HTTP server.
getMockServer :: MockNetwork s s
getMockServer :: MockNetwork s s
getMockServer = (MockServer s -> (Either HttpException s, MockServer s))
-> MockNetwork s s
forall s a.
(MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
MockNetwork ((MockServer s -> (Either HttpException s, MockServer s))
 -> MockNetwork s s)
-> (MockServer s -> (Either HttpException s, MockServer s))
-> MockNetwork s s
forall a b. (a -> b) -> a -> b
$ \MockServer s
s -> (s -> Either HttpException s
forall a b. b -> Either a b
Right (s -> Either HttpException s) -> s -> Either HttpException s
forall a b. (a -> b) -> a -> b
$ MockServer s -> s
forall s. MockServer s -> s
unMockServer MockServer s
s,MockServer s
s)

-- | Replace the internal state of the fake HTTP server.
putMockServer :: s -> MockNetwork s ()
putMockServer :: s -> MockNetwork s ()
putMockServer s
s = (MockServer s -> (Either HttpException (), MockServer s))
-> MockNetwork s ()
forall s a.
(MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
MockNetwork ((MockServer s -> (Either HttpException (), MockServer s))
 -> MockNetwork s ())
-> (MockServer s -> (Either HttpException (), MockServer s))
-> MockNetwork s ()
forall a b. (a -> b) -> a -> b
$ \MockServer s
_ -> (() -> Either HttpException ()
forall a b. b -> Either a b
Right (), s -> MockServer s
forall s. s -> MockServer s
MockServer s
s)

-- | Mutate the internal state of the fake HTTP server (strictly).
modifyMockServer :: (s -> s) -> MockNetwork s ()
modifyMockServer :: (s -> s) -> MockNetwork s ()
modifyMockServer s -> s
f = (MockServer s -> (Either HttpException (), MockServer s))
-> MockNetwork s ()
forall s a.
(MockServer s -> (Either HttpException a, MockServer s))
-> MockNetwork s a
MockNetwork ((MockServer s -> (Either HttpException (), MockServer s))
 -> MockNetwork s ())
-> (MockServer s -> (Either HttpException (), MockServer s))
-> MockNetwork s ()
forall a b. (a -> b) -> a -> b
$ \MockServer s
s ->
  (() -> Either HttpException ()
forall a b. b -> Either a b
Right (), s -> MockServer s
forall s. s -> MockServer s
MockServer (s -> MockServer s)
-> (MockServer s -> s) -> MockServer s -> MockServer s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f (s -> s) -> (MockServer s -> s) -> MockServer s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockServer s -> s
forall s. MockServer s -> s
unMockServer (MockServer s -> MockServer s) -> MockServer s -> MockServer s
forall a b. (a -> b) -> a -> b
$! MockServer s
s)