Tests.hs

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Snap.Internal.Http.Server.Socket.Tests (tests) where

------------------------------------------------------------------------------
import           Control.Applicative               ((<$>))
import qualified Network.Socket                    as N
------------------------------------------------------------------------------
import           Control.Concurrent                (forkIO, killThread, newEmptyMVar, putMVar, readMVar, takeMVar)
import qualified Control.Exception                 as E
import           Data.IORef                        (newIORef, readIORef, writeIORef)
import           Test.Framework                    (Test)
import           Test.Framework.Providers.HUnit    (testCase)
import           Test.HUnit                        (assertEqual)
------------------------------------------------------------------------------
import qualified Snap.Internal.Http.Server.Socket  as Sock
import           Snap.Test.Common                  (eatException, expectException, withSock)
------------------------------------------------------------------------------
#ifdef HAS_UNIX_SOCKETS
import           System.Directory                  (getTemporaryDirectory)
import           System.FilePath                   ((</>))
import qualified System.Posix                      as Posix
# if !MIN_VERSION_unix(2,6,0)
import           Control.Monad.State               (replicateM)
import           Control.Monad.Trans.State.Strict  as State
import qualified Data.Vector.Unboxed               as V
import           System.Directory                  (createDirectoryIfMissing)
import           System.Random                     (StdGen, newStdGen, randomR)
# endif
#else
import           Snap.Internal.Http.Server.Address (AddressNotSupportedException)
#endif

------------------------------------------------------------------------------
#ifdef HAS_UNIX_SOCKETS
mkdtemp :: String -> IO FilePath
# if MIN_VERSION_unix(2,6,0)
mkdtemp = Posix.mkdtemp

# else

tMPCHARS :: V.Vector Char
tMPCHARS = V.fromList $! ['a'..'z'] ++ ['0'..'9']

mkdtemp template = do
    suffix <- newStdGen >>= return . State.evalState (chooseN 8 tMPCHARS)
    let dir = template ++ suffix
    createDirectoryIfMissing False dir
    return dir
  where
    choose :: V.Vector Char -> State.State StdGen Char
    choose v = do let sz = V.length v
                  idx <- State.state $ randomR (0, sz - 1)
                  return $! (V.!) v idx

    chooseN :: Int -> V.Vector Char -> State.State StdGen String
    chooseN n v = replicateM n $ choose v
#endif
#endif

------------------------------------------------------------------------------
tests :: [Test]
tests = [
          testUnixSocketBind
#if !MIN_VERSION_network(3,0,0)
        , testAcceptFailure
        , testSockClosedOnListenException
#endif
        ]

------------------------------------------------------------------------------
-- TODO: fix these tests which rely on deprecated socket apis
#if !MIN_VERSION_network(3,0,0)
testSockClosedOnListenException :: Test
testSockClosedOnListenException = testCase "socket/closedOnListenException" $ do
    ref <- newIORef Nothing
    expectException $ Sock.bindSocketImpl (sso ref) bs ls "127.0.0.1" 4444
    (Just sock) <- readIORef ref
    let (N.MkSocket _ _ _ _ mvar) = sock
    readMVar mvar >>= assertEqual "socket closed" N.Closed

  where
    sso ref sock _ _ = do
        let (N.MkSocket _ _ _ _ mvar) = sock
        readMVar mvar >>= assertEqual "socket not connected" N.NotConnected
        writeIORef ref (Just sock) >> fail "set socket option"
    bs _ _ = fail "bindsocket"
    ls _ _ = fail "listen"

------------------------------------------------------------------------------
testAcceptFailure :: Test
testAcceptFailure = testCase "socket/acceptAndInitialize" $ do
    sockmvar <- newEmptyMVar
    donemvar <- newEmptyMVar
    E.bracket (Sock.bindSocket "127.0.0.1" $ fromIntegral N.aNY_PORT)
              (N.close)
              (\s -> do
                   p <- fromIntegral <$> N.socketPort s
                   forkIO $ server s sockmvar donemvar
                   E.bracket (forkIO $ client p)
                             (killThread)
                             (\_ -> do
                                csock <- takeMVar sockmvar
                                takeMVar donemvar
                                N.isConnected csock >>=
                                    assertEqual "closed" False
                             )
              )
  where
    server sock sockmvar donemvar = serve `E.finally` putMVar donemvar ()
      where
        serve = eatException $ E.mask $ \restore ->
                Sock.acceptAndInitialize sock restore $ \(csock, _) -> do
                  putMVar sockmvar csock
                  fail "error"

    client port = withSock port (const $ return ())
#endif

testUnixSocketBind :: Test
#ifdef HAS_UNIX_SOCKETS
testUnixSocketBind = testCase "socket/unixSocketBind" $
  withSocketPath $ \path ->  do
#if !MIN_VERSION_network(3,0,0)
    E.bracket (Sock.bindUnixSocket Nothing path) N.close $ \sock -> do
        N.isListening sock >>= assertEqual "listening" True
#endif

    expectException $ E.bracket (Sock.bindUnixSocket Nothing "a/relative/path")
                    N.close doNothing

    expectException $ E.bracket (Sock.bindUnixSocket Nothing "/relative/../path")
                    N.close doNothing

    expectException $ E.bracket (Sock.bindUnixSocket Nothing "/hopefully/not/existing/path")
                    N.close doNothing

#ifdef LINUX
    -- Most (all?) BSD systems ignore access mode on unix sockets.
    -- Should we still check it?

    -- This is pretty much for 100% coverage
    expectException $ E.bracket (Sock.bindUnixSocket Nothing "/")
                    N.close doNothing

    let mode = 0o766
    E.bracket (Sock.bindUnixSocket (Just mode) path) N.close $ \_ -> do
        -- Should check sockFd instead of path?
        sockMode <- fmap Posix.fileMode $ Posix.getFileStatus path
        assertEqual "access mode" (fromIntegral mode) $
            Posix.intersectFileModes Posix.accessModes sockMode
#endif
  where
    doNothing _ = return ()
    withSocketPath act = do
      tmpRoot <- getTemporaryDirectory
      tmpDir <- mkdtemp $ tmpRoot </> "snap-server-test-"
      let path = tmpDir </> "unixSocketBind.sock"
      E.finally (act path) $ do
          eatException $ Posix.removeLink path
          eatException $ Posix.removeDirectory tmpDir

#else
testUnixSocketBind = testCase "socket/unixSocketBind" $ do
    caught <- E.catch (Sock.bindUnixSocket Nothing "/tmp/snap-sock.sock" >> return False)
              $ \(e :: AddressNotSupportedException) -> length (show e) `seq` return True
    assertEqual "not supported" True caught

#endif