content: {-# LANGUAGE CPP                   #-}
  {-# LANGUAGE DeriveDataTypeable    #-}
  {-# LANGUAGE FlexibleContexts      #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings     #-}
  {-# LANGUAGE ScopedTypeVariables   #-}
  {-# OPTIONS_GHC -fno-warn-orphans  #-}
  
  ------------------------------------------------------------------------------
  module Snap.Test.Common where
  
  ------------------------------------------------------------------------------
  import           Control.DeepSeq             (deepseq)
  import           Control.Exception.Lifted    (SomeException (..), catch, evaluate, finally, try)
  import           Control.Monad               (liftM, replicateM)
  import           Control.Monad.IO.Class      (MonadIO (..))
  import           Control.Monad.Trans.Control (MonadBaseControl)
  import           Data.ByteString.Builder     (byteString, toLazyByteString)
  import           Data.ByteString.Char8       (ByteString)
  import qualified Data.ByteString.Char8       as S
  import qualified Data.ByteString.Lazy        as L
  import           Data.Monoid                 (Monoid (mappend, mempty))
  import           Data.Typeable               (Typeable, typeOf)
  import           Network.Socket              (Socket)
  import qualified Network.Socket              as N hiding (recv)
  import           System.Timeout              (timeout)
  import           Test.HUnit                  (assertFailure)
  import           Test.QuickCheck             (Arbitrary (arbitrary), choose)
  
  import qualified Network.Socket.ByteString   as N
  #if !(MIN_VERSION_base(4,6,0))
  import           Prelude                     hiding (catch)
  #endif
  ------------------------------------------------------------------------------
  instance Arbitrary S.ByteString where
      arbitrary = liftM S.pack arbitrary
  
  instance Arbitrary L.ByteString where
      arbitrary = do
          n      <- choose(0,5)
          chunks <- replicateM n arbitrary
          return $! L.fromChunks chunks
  
  
  ------------------------------------------------------------------------------
  expectException :: IO a -> IO ()
  expectException m = do
      e <- try m
      case e of
        Left (z::SomeException) -> length (show z) `seq` return ()
        Right _ -> assertFailure "expected exception, didn't get it"
  
  
  ------------------------------------------------------------------------------
  expectExceptionBeforeTimeout :: IO a    -- ^ action to run
                               -> Int     -- ^ number of seconds to expect
                                          -- exception by
                               -> IO Bool
  expectExceptionBeforeTimeout act nsecs = do
      x <- timeout (nsecs * (10::Int)^(6::Int)) f
      case x of
        Nothing  -> return False
        (Just y) -> return y
  
    where
      f = (act >> return False) `catch` \(e::SomeException) -> do
              if show e == "<<timeout>>"
                 then return False
                 else return True
  
  
  ------------------------------------------------------------------------------
  withSock :: Int -> (Socket -> IO a) -> IO a
  withSock port go = do
      addr <- liftM (N.addrAddress . Prelude.head) $
              N.getAddrInfo (Just myHints)
                            (Just "127.0.0.1")
                            (Just $ show port)
  
      sock <- N.socket N.AF_INET N.Stream N.defaultProtocol
      N.connect sock addr
  
      go sock `finally` close sock
  
    where
  #if MIN_VERSION_network(2,7,0)
      close = N.close
  #else
      close = N.sClose
  #endif
      myHints = N.defaultHints { N.addrFlags = [ N.AI_NUMERICHOST ] }
  
  
  ------------------------------------------------------------------------------
  recvAll :: Socket -> IO ByteString
  recvAll sock = do
      b <- f mempty sock
      return $! S.concat $ L.toChunks $ toLazyByteString b
  
    where
      f b sk = do
          s <- N.recv sk 100000
          if S.null s
            then return b
            else f (b `mappend` byteString s) sk
  
  
  ------------------------------------------------------------------------------
  ditchHeaders :: [ByteString] -> [ByteString]
  ditchHeaders ("":xs)   = xs
  ditchHeaders ("\r":xs) = xs
  ditchHeaders (_:xs)    = ditchHeaders xs
  ditchHeaders []        = []
  
  
  ------------------------------------------------------------------------------
  forceSameType :: a -> a -> a
  forceSameType _ a = a
  
  
  ------------------------------------------------------------------------------
  -- | Kill the false negative on derived show instances.
  coverShowInstance :: (Monad m, Show a) => a -> m ()
  coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return ()
    where
      a = showsPrec 0 x ""
      b = show x
      c = showList [x] ""
  
  
  ------------------------------------------------------------------------------
  coverReadInstance :: (MonadIO m, Read a) => a -> m ()
  coverReadInstance x = do
      liftIO $ eatException $ evaluate $ forceSameType [(x,"")] $ readsPrec 0 ""
      liftIO $ eatException $ evaluate $ forceSameType [([x],"")] $ readList ""
  
  
  ------------------------------------------------------------------------------
  coverEqInstance :: (Monad m, Eq a) => a -> m ()
  coverEqInstance x = a `seq` b `seq` return ()
    where
      a = x == x
      b = x /= x
  
  
  ------------------------------------------------------------------------------
  coverOrdInstance :: (Monad m, Ord a) => a -> m ()
  coverOrdInstance x = a `deepseq` b `deepseq` return ()
    where
      a = [ x < x
          , x >= x
          , x > x
          , x <= x
          , compare x x == EQ ]
  
      b = min a $ max a a
  
  
  ------------------------------------------------------------------------------
  coverTypeableInstance :: (Monad m, Typeable a) => a -> m ()
  coverTypeableInstance a = typeOf a `seq` return ()
  
  
  ------------------------------------------------------------------------------
  eatException :: (MonadBaseControl IO m) => m a -> m ()
  eatException a = (a >> return ()) `catch` handler
    where
      handler :: (MonadBaseControl IO m) => SomeException -> m ()
      handler _ = return ()
  
  
  ------------------------------------------------------------------------------
  timeoutIn :: Int -> IO a -> IO a
  timeoutIn n m = timeout (n * 1000000) m >>= maybe (fail "timeout") return
  