{-# LANGUAGE OverloadedStrings #-}
# LANGUAGE GeneralizedNewtypeDeriving #

module Lec03.ServiceTest where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import Data.List (permutations)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Network.HTTP.Client
       ( Manager
       , RequestBody(RequestBodyLBS)
       , defaultManagerSettings
       , httpLbs
       , method
       , brConsume
       , withResponse
       , newManager
       , parseRequest
       , path
       , requestBody
       , responseBody
       , throwErrorStatusCodes
       )
import Test.QuickCheck
import Test.QuickCheck.Monadic

  We can reuse most of the concurrent testing machinary from the second
-- lecture.

import Lec02ConcurrentSMTesting
       ( History'(History)
       , Operation'(Ok)
       , appendHistory
       , assertWithFail
       , classifyCommandsLength
       , interleavings
       , linearisable
       , prettyHistory
       , toPid
       )
import Lec03.Service

------------------------------------------------------------------------

newtype Index = Index Int
  deriving (Eq, Ord, Show, Num)

data ClientRequest = WriteReq ByteString | ReadReq Index
  deriving Show

data ClientResponse = WriteResp Index | ReadResp ByteString
  deriving (Eq, Show)

newtype ConcProgram = ConcProgram { unConcProgram :: [[ClientRequest]] }
  deriving Show

newtype Model = Model (Vector ByteString)

initModel :: Model
initModel = Model Vector.empty

step :: Model -> ClientRequest -> (Model, ClientResponse)
step (Model vec) (WriteReq bs) =
  (Model (Vector.snoc vec bs), WriteResp (Index (Vector.length vec)))
step (Model vec) (ReadReq (Index ix)) =
  (Model vec, ReadResp (vec Vector.! ix))

type Operation = Operation' ClientRequest ClientResponse

concExec :: Manager -> TQueue Operation -> ClientRequest -> IO ()
concExec mgr hist req =
  case req of
    WriteReq bs -> do
      ix <- httpWrite mgr bs
      pid <- toPid <$> myThreadId
      appendHistory hist (Ok pid (WriteResp ix))
    ReadReq ix -> do
      bs <- httpRead mgr ix
      pid <- toPid <$> myThreadId
      appendHistory hist (Ok pid (ReadResp bs))

------------------------------------------------------------------------

httpWrite :: Manager -> ByteString -> IO Index
httpWrite mgr bs = do
  initReq <- parseRequest (":" ++ show pORT)
  let req = initReq { method = "POST"
                    , requestBody = RequestBodyLBS bs
                    }
  withResponse req mgr $ \resp -> do
    throwErrorStatusCodes req resp
    bss <- brConsume (responseBody resp)
    case LBS8.readInt (LBS8.fromChunks bss) of
      Nothing          -> error "httpWrite: can't read index"
      Just (ix, _rest) -> return (Index ix)

httpRead :: Manager -> Index -> IO ByteString
httpRead mgr (Index ix) = do
  initReq <- parseRequest (":" ++ show pORT)
  let req = initReq { method = "GET"
                    , path = path initReq <> BS8.pack (show ix)
                    }
  withResponse req mgr $ \resp -> do
    throwErrorStatusCodes req resp
    bss <- brConsume (responseBody resp)
    return (LBS8.fromChunks bss)

httpReset :: Manager -> IO ()
httpReset mgr = do
  initReq <- parseRequest (":" ++ show pORT)
  _resp <- httpLbs initReq { method = "DELETE" } mgr
  return ()

------------------------------------------------------------------------

genClientRequest :: Gen ClientRequest
genClientRequest = oneof
  [ WriteReq <$> (LBS.pack <$> arbitrary)
  , ReadReq <$> (Index <$> arbitrary)
  ]

validProgram :: Model -> [ClientRequest] -> Bool
validProgram _model _cmds = True

shrinkClientRequest :: ClientRequest -> [ClientRequest]
shrinkClientRequest (WriteReq bs) = [ WriteReq (LBS.pack s') | s' <- shrink (LBS.unpack bs) ]
shrinkClientRequest (ReadReq _ix) = []

genConcProgram :: Model -> Gen ConcProgram
genConcProgram m0 = sized (go m0 [])
  where
    go :: Model -> [[ClientRequest]] -> Int -> Gen ConcProgram
    go m acc sz | sz <= 0   = return (ConcProgram (reverse acc))
                | otherwise = do
                    n <- chooseInt (2, 5)
                    reqs <- vectorOf n genClientRequest `suchThat` concSafe m
                    go (advanceModel m reqs) (reqs : acc) (sz - n)

advanceModel :: Model -> [ClientRequest] -> Model
advanceModel m reqs = foldl (\ih req -> fst (step ih req)) m reqs

concSafe :: Model -> [ClientRequest] -> Bool
concSafe m = all (validProgram m) . permutations

validConcProgram :: Model -> ConcProgram -> Bool
validConcProgram m0 (ConcProgram reqss0) = go m0 True reqss0
  where
    go :: Model -> Bool -> [[ClientRequest]] -> Bool
    go _m False _              = False
    go _m acc   []             = acc
    go  m _acc  (reqs : reqss) = go (advanceModel m reqs) (concSafe m reqs) reqss

shrinkConcProgram :: Model -> ConcProgram -> [ConcProgram]
shrinkConcProgram m
  = filter (validConcProgram m)
  . map ConcProgram
  . filter (not . null)
  . shrinkList (shrinkList shrinkClientRequest)
  . unConcProgram

prettyConcProgram :: ConcProgram -> String
prettyConcProgram = show

forAllConcProgram :: (ConcProgram -> Property) -> Property
forAllConcProgram k =
  forAllShrinkShow (genConcProgram m) (shrinkConcProgram m) prettyConcProgram k
  where
    m = initModel

-- Finally we can write our integration tests between the queue and the web
-- service, sometimes these tests are also called "collaboration tests".

-- NOTE: We shouldn't use a model in concurrent tests before we made sure it
-- passes sequential tests.

-- NOTE: Assumes that the service is running.
prop_collaborationTests :: Manager -> Property
prop_collaborationTests mgr = mapSize (min 20) $
  forAllConcProgram $ \(ConcProgram reqss) -> monadicIO $ do
    monitor (classifyCommandsLength (concat reqss))
    monitor (tabulate "Client requests" (map constructorString (concat reqss)))
    monitor (tabulate "Number of concurrent client requests" (map (show . length) reqss))
    -- Rerun a couple of times, to avoid being lucky with the interleavings.
    replicateM_ 10 $ do
      queue <- run newTQueueIO
      run (mapM_ (mapConcurrently (concExec mgr queue)) reqss)
      hist <- History <$> run (atomically (flushTQueue queue))
      assertWithFail (linearisable step initModel (interleavings hist)) (prettyHistory hist)
      run (httpReset mgr)
  where
    constructorString :: ClientRequest -> String
    constructorString WriteReq {} = "WriteReq"
    constructorString ReadReq  {} = "ReadReq"

test :: IO ()
test = do
  -- NOTE: fake queue is used here, justified by previous contract testing.
  queue <- fakeQueue mAX_QUEUE_SIZE
  mgr   <- newManager defaultManagerSettings
  withService queue (quickCheck (prop_collaborationTests mgr))

# LANGUAGE OverloadedStrings #
 lecture.
----------------------------------------------------------------------
----------------------------------------------------------------------
----------------------------------------------------------------------
 Finally we can write our integration tests between the queue and the web
 service, sometimes these tests are also called "collaboration tests".
 NOTE: We shouldn't use a model in concurrent tests before we made sure it
 passes sequential tests.
 NOTE: Assumes that the service is running.
 Rerun a couple of times, to avoid being lucky with the interleavings.
 NOTE: fake queue is used here, justified by previous contract testing.
# LANGUAGE GeneralizedNewtypeDeriving #

module Lec03.ServiceTest where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import Data.List (permutations)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Network.HTTP.Client
       ( Manager
       , RequestBody(RequestBodyLBS)
       , defaultManagerSettings
       , httpLbs
       , method
       , brConsume
       , withResponse
       , newManager
       , parseRequest
       , path
       , requestBody
       , responseBody
       , throwErrorStatusCodes
       )
import Test.QuickCheck
import Test.QuickCheck.Monadic

  We can reuse most of the concurrent testing machinary from the second

import Lec02ConcurrentSMTesting
       ( History'(History)
       , Operation'(Ok)
       , appendHistory
       , assertWithFail
       , classifyCommandsLength
       , interleavings
       , linearisable
       , prettyHistory
       , toPid
       )
import Lec03.Service


newtype Index = Index Int
  deriving (Eq, Ord, Show, Num)

data ClientRequest = WriteReq ByteString | ReadReq Index
  deriving Show

data ClientResponse = WriteResp Index | ReadResp ByteString
  deriving (Eq, Show)

newtype ConcProgram = ConcProgram { unConcProgram :: [[ClientRequest]] }
  deriving Show

newtype Model = Model (Vector ByteString)

initModel :: Model
initModel = Model Vector.empty

step :: Model -> ClientRequest -> (Model, ClientResponse)
step (Model vec) (WriteReq bs) =
  (Model (Vector.snoc vec bs), WriteResp (Index (Vector.length vec)))
step (Model vec) (ReadReq (Index ix)) =
  (Model vec, ReadResp (vec Vector.! ix))

type Operation = Operation' ClientRequest ClientResponse

concExec :: Manager -> TQueue Operation -> ClientRequest -> IO ()
concExec mgr hist req =
  case req of
    WriteReq bs -> do
      ix <- httpWrite mgr bs
      pid <- toPid <$> myThreadId
      appendHistory hist (Ok pid (WriteResp ix))
    ReadReq ix -> do
      bs <- httpRead mgr ix
      pid <- toPid <$> myThreadId
      appendHistory hist (Ok pid (ReadResp bs))


httpWrite :: Manager -> ByteString -> IO Index
httpWrite mgr bs = do
  initReq <- parseRequest (":" ++ show pORT)
  let req = initReq { method = "POST"
                    , requestBody = RequestBodyLBS bs
                    }
  withResponse req mgr $ \resp -> do
    throwErrorStatusCodes req resp
    bss <- brConsume (responseBody resp)
    case LBS8.readInt (LBS8.fromChunks bss) of
      Nothing          -> error "httpWrite: can't read index"
      Just (ix, _rest) -> return (Index ix)

httpRead :: Manager -> Index -> IO ByteString
httpRead mgr (Index ix) = do
  initReq <- parseRequest (":" ++ show pORT)
  let req = initReq { method = "GET"
                    , path = path initReq <> BS8.pack (show ix)
                    }
  withResponse req mgr $ \resp -> do
    throwErrorStatusCodes req resp
    bss <- brConsume (responseBody resp)
    return (LBS8.fromChunks bss)

httpReset :: Manager -> IO ()
httpReset mgr = do
  initReq <- parseRequest (":" ++ show pORT)
  _resp <- httpLbs initReq { method = "DELETE" } mgr
  return ()


genClientRequest :: Gen ClientRequest
genClientRequest = oneof
  [ WriteReq <$> (LBS.pack <$> arbitrary)
  , ReadReq <$> (Index <$> arbitrary)
  ]

validProgram :: Model -> [ClientRequest] -> Bool
validProgram _model _cmds = True

shrinkClientRequest :: ClientRequest -> [ClientRequest]
shrinkClientRequest (WriteReq bs) = [ WriteReq (LBS.pack s') | s' <- shrink (LBS.unpack bs) ]
shrinkClientRequest (ReadReq _ix) = []

genConcProgram :: Model -> Gen ConcProgram
genConcProgram m0 = sized (go m0 [])
  where
    go :: Model -> [[ClientRequest]] -> Int -> Gen ConcProgram
    go m acc sz | sz <= 0   = return (ConcProgram (reverse acc))
                | otherwise = do
                    n <- chooseInt (2, 5)
                    reqs <- vectorOf n genClientRequest `suchThat` concSafe m
                    go (advanceModel m reqs) (reqs : acc) (sz - n)

advanceModel :: Model -> [ClientRequest] -> Model
advanceModel m reqs = foldl (\ih req -> fst (step ih req)) m reqs

concSafe :: Model -> [ClientRequest] -> Bool
concSafe m = all (validProgram m) . permutations

validConcProgram :: Model -> ConcProgram -> Bool
validConcProgram m0 (ConcProgram reqss0) = go m0 True reqss0
  where
    go :: Model -> Bool -> [[ClientRequest]] -> Bool
    go _m False _              = False
    go _m acc   []             = acc
    go  m _acc  (reqs : reqss) = go (advanceModel m reqs) (concSafe m reqs) reqss

shrinkConcProgram :: Model -> ConcProgram -> [ConcProgram]
shrinkConcProgram m
  = filter (validConcProgram m)
  . map ConcProgram
  . filter (not . null)
  . shrinkList (shrinkList shrinkClientRequest)
  . unConcProgram

prettyConcProgram :: ConcProgram -> String
prettyConcProgram = show

forAllConcProgram :: (ConcProgram -> Property) -> Property
forAllConcProgram k =
  forAllShrinkShow (genConcProgram m) (shrinkConcProgram m) prettyConcProgram k
  where
    m = initModel



prop_collaborationTests :: Manager -> Property
prop_collaborationTests mgr = mapSize (min 20) $
  forAllConcProgram $ \(ConcProgram reqss) -> monadicIO $ do
    monitor (classifyCommandsLength (concat reqss))
    monitor (tabulate "Client requests" (map constructorString (concat reqss)))
    monitor (tabulate "Number of concurrent client requests" (map (show . length) reqss))
    replicateM_ 10 $ do
      queue <- run newTQueueIO
      run (mapM_ (mapConcurrently (concExec mgr queue)) reqss)
      hist <- History <$> run (atomically (flushTQueue queue))
      assertWithFail (linearisable step initModel (interleavings hist)) (prettyHistory hist)
      run (httpReset mgr)
  where
    constructorString :: ClientRequest -> String
    constructorString WriteReq {} = "WriteReq"
    constructorString ReadReq  {} = "ReadReq"

test :: IO ()
test = do
  queue <- fakeQueue mAX_QUEUE_SIZE
  mgr   <- newManager defaultManagerSettings
  withService queue (quickCheck (prop_collaborationTests mgr))
