fix warnings, stylish-haskell, wibbles

This commit is contained in:
Joel Stanley 2016-05-25 16:26:28 -07:00
parent df46b33c6a
commit 80dd0e0874
6 changed files with 98 additions and 81 deletions

View file

@ -56,7 +56,7 @@ library
, grpc/impl/codegen/slice.h , grpc/impl/codegen/slice.h
build-tools: c2hs build-tools: c2hs
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -fwarn-incomplete-patterns ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind
include-dirs: include include-dirs: include
hs-source-dirs: src hs-source-dirs: src
default-extensions: CPP default-extensions: CPP
@ -80,7 +80,7 @@ test-suite test
LowLevelTests, LowLevelTests,
UnsafeTests UnsafeTests
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -fwarn-incomplete-patterns -g -threaded ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-unused-do-bind -g -threaded
hs-source-dirs: tests hs-source-dirs: tests
main-is: Properties.hs main-is: Properties.hs
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0

View file

@ -107,3 +107,9 @@ destroyCall call@ServerCall{..} = do
forM_ callDetails C.destroyCallDetails forM_ callDetails C.destroyCallDetails
grpcDebug $ "destroying deadline." ++ show callDeadline grpcDebug $ "destroying deadline." ++ show callDeadline
forM_ callDeadline C.timespecDestroy forM_ callDeadline C.timespecDestroy
_nowarn_unused :: a
_nowarn_unused =
castPtr `undefined`
(peek :: Ptr Int -> IO Int) `undefined`
()

View file

@ -6,8 +6,8 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Network.GRPC.LowLevel.CompletionQueue ( module Network.GRPC.LowLevel.CompletionQueue
CompletionQueue ( CompletionQueue
, withCompletionQueue , withCompletionQueue
, createCompletionQueue , createCompletionQueue
, shutdownCompletionQueue , shutdownCompletionQueue
@ -16,33 +16,35 @@ module Network.GRPC.LowLevel.CompletionQueue (
, channelCreateRegisteredCall , channelCreateRegisteredCall
, channelCreateCall , channelCreateCall
, TimeoutSeconds , TimeoutSeconds
, eventSuccess , isEventSuccessful
, serverRegisterCompletionQueue , serverRegisterCompletionQueue
, serverShutdownAndNotify , serverShutdownAndNotify
, serverRequestRegisteredCall , serverRequestRegisteredCall
, serverRequestCall , serverRequestCall
, newTag , newTag
) where )
where
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, retry, check) import Control.Concurrent.STM (atomically, check, retry)
import Control.Concurrent.STM.TVar (TVar, newTVarIO, modifyTVar', import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO,
readTVar, writeTVar) readTVar, writeTVar)
import Control.Exception (bracket) import Control.Exception (bracket)
import Data.IORef (IORef, newIORef, atomicModifyIORef') import Data.IORef (IORef, atomicModifyIORef',
newIORef)
import Data.List (intersperse) import Data.List (intersperse)
import Foreign.Marshal.Alloc (malloc, free) import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Ptr (nullPtr, plusPtr)
import Foreign.Storable (peek) import Foreign.Storable (peek)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Constants as C import qualified Network.GRPC.Unsafe.Constants as C
import qualified Network.GRPC.Unsafe.Time as C
import qualified Network.GRPC.Unsafe.Op as C
import qualified Network.GRPC.Unsafe.Metadata as C import qualified Network.GRPC.Unsafe.Metadata as C
import qualified Network.GRPC.Unsafe.Op as C
import qualified Network.GRPC.Unsafe.Time as C
import System.Timeout (timeout) import System.Timeout (timeout)
import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.GRPC
-- NOTE: the concurrency requirements for a CompletionQueue are a little -- NOTE: the concurrency requirements for a CompletionQueue are a little
-- complicated. There are two read operations: next and pluck. We can either -- complicated. There are two read operations: next and pluck. We can either
@ -159,13 +161,14 @@ eventToError (C.Event C.QueueShutdown _ _) = Left GRPCIOShutdown
eventToError (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout eventToError (C.Event C.QueueTimeout _ _) = Left GRPCIOTimeout
eventToError _ = Left GRPCIOUnknownError eventToError _ = Left GRPCIOUnknownError
isFailedEvent :: C.Event -> Bool -- | Returns true iff the given grpc_event was a success.
isFailedEvent C.Event{..} = (eventCompletionType /= C.OpComplete) isEventSuccessful :: C.Event -> Bool
|| not eventSuccess isEventSuccessful (C.Event C.OpComplete True _) = True
isEventSuccessful _ = False
-- | Waits for the given number of seconds for the given tag to appear on the -- | Waits for the given number of seconds for the given tag to appear on the
-- completion queue. Throws 'GRPCIOShutdown' if the completion queue is shutting -- completion queue. Throws 'GRPCIOShutdown' if the completion queue is shutting
--down and cannot handle new requests. -- down and cannot handle new requests.
pluck :: CompletionQueue -> C.Tag -> TimeoutSeconds pluck :: CompletionQueue -> C.Tag -> TimeoutSeconds
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
pluck cq@CompletionQueue{..} tag waitSeconds = do pluck cq@CompletionQueue{..} tag waitSeconds = do
@ -175,9 +178,7 @@ pluck cq@CompletionQueue{..} tag waitSeconds = do
C.withDeadlineSeconds waitSeconds $ \deadline -> do C.withDeadlineSeconds waitSeconds $ \deadline -> do
ev <- C.grpcCompletionQueuePluck unsafeCQ tag deadline C.reserved ev <- C.grpcCompletionQueuePluck unsafeCQ tag deadline C.reserved
grpcDebug $ "pluck: finished. Event: " ++ show ev grpcDebug $ "pluck: finished. Event: " ++ show ev
if isFailedEvent ev return $ if isEventSuccessful ev then Right () else eventToError ev
then return $ eventToError ev
else return $ Right ()
-- TODO: I'm thinking it might be easier to use 'Either' uniformly everywhere -- TODO: I'm thinking it might be easier to use 'Either' uniformly everywhere
-- even when it's isomorphic to 'Maybe'. If that doesn't turn out to be the -- even when it's isomorphic to 'Maybe'. If that doesn't turn out to be the
@ -207,7 +208,7 @@ shutdownCompletionQueue (CompletionQueue{..}) = do
atomically $ readTVar currentPluckers >>= \x -> check (x == 0) atomically $ readTVar currentPluckers >>= \x -> check (x == 0)
--drain the queue --drain the queue
C.grpcCompletionQueueShutdown unsafeCQ C.grpcCompletionQueueShutdown unsafeCQ
loopRes <- timeout (5*10^6) drainLoop loopRes <- timeout (5*10^(6::Int)) drainLoop
case loopRes of case loopRes of
Nothing -> return $ Left GRPCIOShutdownFailure Nothing -> return $ Left GRPCIOShutdownFailure
Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ()) Just () -> C.grpcCompletionQueueDestroy unsafeCQ >> return (Right ())
@ -221,11 +222,6 @@ shutdownCompletionQueue (CompletionQueue{..}) = do
C.QueueTimeout -> drainLoop C.QueueTimeout -> drainLoop
C.OpComplete -> drainLoop C.OpComplete -> drainLoop
-- | Returns true iff the given grpc_event was a success.
eventSuccess :: C.Event -> Bool
eventSuccess (C.Event C.OpComplete True _) = True
eventSuccess _ = False
channelCreateRegisteredCall :: C.Channel -> C.Call -> C.PropagationMask channelCreateRegisteredCall :: C.Channel -> C.Call -> C.PropagationMask
-> CompletionQueue -> C.CallHandle -> CompletionQueue -> C.CallHandle
-> C.CTimeSpecPtr -> IO (Either GRPCIOError Call) -> C.CTimeSpecPtr -> IO (Either GRPCIOError Call)
@ -290,7 +286,7 @@ serverRequestRegisteredCall
return $ Right assembledCall return $ Right assembledCall
-- TODO: see TODO for failureCleanup in serverRequestCall. -- TODO: see TODO for failureCleanup in serverRequestCall.
where failureCleanup deadline callPtr metadataArrayPtr bbPtr = forkIO $ do where failureCleanup deadline callPtr metadataArrayPtr bbPtr = forkIO $ do
threadDelay (30*10^6) threadDelaySecs 30
grpcDebug "serverRequestRegisteredCall: doing delayed cleanup." grpcDebug "serverRequestRegisteredCall: doing delayed cleanup."
C.timespecDestroy deadline C.timespecDestroy deadline
free callPtr free callPtr
@ -340,7 +336,7 @@ serverRequestCall server cq@CompletionQueue{..} timeLimit =
-- we sleep for a while before freeing the objects. We should find a -- we sleep for a while before freeing the objects. We should find a
-- permanent solution that's more robust. -- permanent solution that's more robust.
where failureCleanup callPtr callDetails metadataArrayPtr = forkIO $ do where failureCleanup callPtr callDetails metadataArrayPtr = forkIO $ do
threadDelay (30*10^6) threadDelaySecs 30
grpcDebug "serverRequestCall: doing delayed cleanup." grpcDebug "serverRequestCall: doing delayed cleanup."
free callPtr free callPtr
C.destroyCallDetails callDetails C.destroyCallDetails callDetails
@ -356,3 +352,6 @@ serverRegisterCompletionQueue server CompletionQueue{..} =
serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO () serverShutdownAndNotify :: C.Server -> CompletionQueue -> C.Tag -> IO ()
serverShutdownAndNotify server CompletionQueue{..} tag = serverShutdownAndNotify server CompletionQueue{..} tag =
C.grpcServerShutdownAndNotify server unsafeCQ tag C.grpcServerShutdownAndNotify server unsafeCQ tag
threadDelaySecs :: Int -> IO ()
threadDelaySecs = threadDelay . (* 10^(6::Int))

View file

@ -51,7 +51,7 @@ grpcDebug :: String -> IO ()
grpcDebug str = do tid <- myThreadId grpcDebug str = do tid <- myThreadId
putStrLn $ (show tid) ++ ": " ++ str putStrLn $ (show tid) ++ ": " ++ str
#else #else
grpcDebug str = return () grpcDebug _ = return ()
#endif #endif
{- {-

View file

@ -1,5 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
module Network.GRPC.LowLevel.Op where module Network.GRPC.LowLevel.Op where
@ -10,17 +10,18 @@ import Data.Maybe (catMaybes)
import Data.String (IsString) import Data.String (IsString)
import Foreign.C.String (CString) import Foreign.C.String (CString)
import Foreign.C.Types (CInt) import Foreign.C.Types (CInt)
import Foreign.Marshal.Alloc (malloc, mallocBytes, free) import Foreign.Marshal.Alloc (free, malloc,
mallocBytes)
import Foreign.Ptr (Ptr, nullPtr) import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (peek, poke) import Foreign.Storable (peek, poke)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C ()
import qualified Network.GRPC.Unsafe.Metadata as C
import qualified Network.GRPC.Unsafe.ByteBuffer as C import qualified Network.GRPC.Unsafe.ByteBuffer as C
import qualified Network.GRPC.Unsafe.Metadata as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.CompletionQueue
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.CompletionQueue
import Network.GRPC.LowLevel.GRPC
type MetadataMap = M.Map B.ByteString B.ByteString type MetadataMap = M.Map B.ByteString B.ByteString
@ -224,3 +225,6 @@ runOps call cq ops timeLimit =
grpcDebug "runOps: got good op; starting." grpcDebug "runOps: got good op; starting."
fmap (Right . catMaybes) $ mapM resultFromOpContext contexts fmap (Right . catMaybes) $ mapM resultFromOpContext contexts
Left err -> return $ Left err Left err -> return $ Left err
_nowarn_unused :: a
_nowarn_unused = undefined nullPtr

View file

@ -12,12 +12,17 @@ import Foreign.Storable (peek)
import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe as C
import qualified Network.GRPC.Unsafe.Op as C import qualified Network.GRPC.Unsafe.Op as C
import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,
pluck, serverRegisterCompletionQueue, serverShutdownAndNotify,
createCompletionQueue, shutdownCompletionQueue, TimeoutSeconds,
serverRequestRegisteredCall, serverRequestCall)
import Network.GRPC.LowLevel.Call import Network.GRPC.LowLevel.Call
import Network.GRPC.LowLevel.CompletionQueue (CompletionQueue,
TimeoutSeconds,
createCompletionQueue,
pluck,
serverRegisterCompletionQueue,
serverRequestCall,
serverRequestRegisteredCall,
serverShutdownAndNotify,
shutdownCompletionQueue)
import Network.GRPC.LowLevel.GRPC
import Network.GRPC.LowLevel.Op import Network.GRPC.LowLevel.Op
import qualified Network.GRPC.Unsafe.ByteBuffer as C import qualified Network.GRPC.Unsafe.ByteBuffer as C
@ -199,7 +204,7 @@ serverHandleNormalRegisteredCall :: Server
-- metadata and returns a response body and -- metadata and returns a response body and
-- metadata. -- metadata.
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverHandleNormalRegisteredCall s@Server{..} rm timeLimit initMetadata f = do serverHandleNormalRegisteredCall s@Server{..} rm timeLimit srvMetadata f = do
-- TODO: we use this timeLimit twice, so the max time spent is 2*timeLimit. -- TODO: we use this timeLimit twice, so the max time spent is 2*timeLimit.
-- Should we just hard-code time limits instead? Not sure if client -- Should we just hard-code time limits instead? Not sure if client
-- programmer cares, since this function will likely just be put in a loop -- programmer cares, since this function will likely just be put in a loop
@ -229,16 +234,16 @@ serverHandleNormalRegisteredCall s@Server{..} rm timeLimit initMetadata f = do
-- | Handle one unregistered call. -- | Handle one unregistered call.
serverHandleNormalCall :: Server -> TimeoutSeconds serverHandleNormalCall :: Server -> TimeoutSeconds
-> MetadataMap -> MetadataMap
-- ^ Initial metadata. -- ^ Initial server metadata.
-> (ByteString -> MetadataMap -> (ByteString -> MetadataMap
-> IO (ByteString, MetadataMap, StatusDetails)) -> IO (ByteString, MetadataMap, StatusDetails))
-- ^ Handler function takes a request body and -- ^ Handler function takes a request body and
-- metadata and returns a response body and metadata. -- metadata and returns a response body and metadata.
-> IO (Either GRPCIOError ()) -> IO (Either GRPCIOError ())
serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do serverHandleNormalCall s@Server{..} timeLimit srvMetadata f = do
withServerCall s timeLimit $ \call -> do withServerCall s timeLimit $ \call -> do
grpcDebug "serverHandleNormalCall: starting batch." grpcDebug "serverHandleNormalCall: starting batch."
let recvOps = serverOpsGetNormalCall initMetadata let recvOps = serverOpsGetNormalCall srvMetadata
opResults <- runOps call serverCQ recvOps timeLimit opResults <- runOps call serverCQ recvOps timeLimit
case opResults of case opResults of
Left x -> return $ Left x Left x -> return $ Left x
@ -255,3 +260,6 @@ serverHandleNormalCall s@Server{..} timeLimit initMetadata f = do
Right _ -> grpcDebug "serverHandleNormalCall: ops done." Right _ -> grpcDebug "serverHandleNormalCall: ops done."
>> return (Right ()) >> return (Right ())
x -> error $ "impossible pattern match: " ++ show x x -> error $ "impossible pattern match: " ++ show x
_nowarn_unused :: a
_nowarn_unused = undefined threadDelay