split client exception.

memcached-binary.cabal

@@ -1,5 +1,5 @@
 name:                memcached-binary
-version:             0.1.2
+version:             0.2.0
 synopsis:            memcached client using binary protocol.
 description:         memcached client using binary protocol.
 license:             MIT

src/Database/Memcached/Binary/Common.hs

@@ -77,7 +77,7 @@ flushAll = I.useConnection $ I.flushAll successNoReturn failureNoReturn
 
 version :: I.Connection -> IO (HasReturn Version)
 version = I.useConnection $ I.version (\s -> case readVersion s of
-    Nothing -> failureHasReturn (-1) "version parse failed"
+    Nothing -> failureHasReturn VersionParseFailed
     Just v  -> successHasReturn v) failureHasReturn
   where
     readVersion s0 = do

src/Database/Memcached/Binary/Either.hs

@@ -18,12 +18,11 @@ successNoReturn  = return Nothing
 {-# INLINE successNoReturn #-}
 
 failureHasReturn :: I.Failure (HasReturn a)
-failureHasReturn i m = return . Left $ MemcachedException i m
+failureHasReturn = return . Left
 {-# INLINE failureHasReturn #-}
 
 failureNoReturn :: I.Failure NoReturn
-failureNoReturn i m = return . Just $ MemcachedException i m
+failureNoReturn = return . Just
 {-# INLINE failureNoReturn #-}
-
 #include "Common.hs"
 

src/Database/Memcached/Binary/IO.hs

@@ -20,11 +20,11 @@ successNoReturn  = return ()
 {-# INLINE successNoReturn #-}
 
 failureHasReturn :: I.Failure (HasReturn a)
-failureHasReturn i m = throwIO $ MemcachedException i m
+failureHasReturn = throwIO
 {-# INLINE failureHasReturn #-}
 
 failureNoReturn :: I.Failure NoReturn
-failureNoReturn i m = throwIO $ MemcachedException i m
+failureNoReturn = throwIO
 {-# INLINE failureNoReturn #-}
 
 #include "Common.hs"

src/Database/Memcached/Binary/Internal.hs

@@ -47,12 +47,12 @@ connect' i = loop (connectAuth i)
 
     loop [a] = do
         h <- connectTo (connectHost i) (connectPort i)
-        auth a (\_ -> return h) (\w m -> throwIO $ MemcachedException w m) h
+        auth a (\_ -> return h) throwIO h
 
     loop (a:as) = do
         h <- connectTo (connectHost i) (connectPort i)
         handle (\(_::IOError) -> loop as) $
-            auth a (\_ -> return h) (\_ _ -> loop as) h
+            auth a (\_ -> return h) (\_ -> loop as) h
 
 close :: Connection -> IO ()
 close (Connection p) = destroyAllResources p
@@ -127,16 +127,20 @@ sendRequest op key elen epoke vlen vpoke opaque cas h =
         hFlush h
 {-# INLINE sendRequest #-}
 
-type Failure a = Word16 -> S.ByteString -> IO a
+type Failure a = MemcachedException -> IO a
 
 peekResponse :: (Ptr Header -> IO a) -> Failure a -> Handle -> IO a
-peekResponse success failure h = allocaBytes 24 $ \p ->
-    hGetBuf h p 24 >> peekWord16be (plusPtr p 6) >>= \st ->
-    if st == 0
-        then success p
+peekResponse success failure h = allocaBytes 24 $ \p -> do
+    len <- hGetBuf h p 24
+    if len /= 24
+        then failure DataReadFailed
         else do
-            bl <- peekWord32be (plusPtr p 8)
-            failure st =<< S.hGet h (fromIntegral bl)
+            peekWord16be (plusPtr p 6) >>= \st ->
+                if st == 0
+                    then success p
+                    else do
+                        bl <- peekWord32be (plusPtr p 8)
+                        failure . MemcachedException st =<< S.hGet h (fromIntegral bl)
 {-# INLINE peekResponse #-}
 
 withRequest :: OpCode -> Key -> Word8 -> (Ptr Request -> IO ())
@@ -175,27 +179,30 @@ inspectResponse h p = do
     v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl
     return (e,k,v)
 
-getSuccessCallback :: (Flags -> Value -> IO a)
+getSuccessCallback :: (Flags -> Value -> IO a) -> Failure a
                    -> Handle -> Ptr Header -> IO a
-getSuccessCallback success h p = do
+getSuccessCallback success failure h p = do
     elen <- getExtraLength p
     tlen <- getTotalLength p
-    void $ hGetBuf h p 4
-    flags <- peekWord32be p
-    value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
-    success flags value
+    len  <- hGetBuf h p 4
+    if len /= 4
+        then failure DataReadFailed
+        else do
+            flags <- peekWord32be p
+            value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
+            success flags value
 
 get :: (Flags -> Value -> IO a) -> Failure a
     -> Key -> Handle -> IO a
 get success failure key = 
     withRequest opGet key 0 nop 0 nop (CAS 0)
-    (getSuccessCallback success) failure
+    (getSuccessCallback success failure) failure
 
 getWithCAS :: (CAS -> Flags -> Value -> IO a) -> Failure a
            -> Key -> Handle -> IO a
 getWithCAS success failure key =
     withRequest opGet key 0 nop 0 nop (CAS 0)
-    (\h p -> getCAS p >>= \c -> getSuccessCallback (success c) h p) failure
+    (\h p -> getCAS p >>= \c -> getSuccessCallback (success c) failure h p) failure
 
 setAddReplace :: IO a -> Failure a -> OpCode -> CAS
               -> Key -> Value -> Flags -> Expiry -> Handle -> IO a
@@ -224,13 +231,15 @@ incrDecr success failure op cas key delta initial expiry =
         pokeWord32be (plusPtr p 16) expiry
 
     success' h p = do
-        void $ hGetBuf h p 8
-        peekWord64be p >>= success
+        len <- hGetBuf h p 8
+        if len /= 8
+            then failure DataReadFailed
+            else peekWord64be p >>= success
 
 quit :: Handle -> IO ()
 quit h = do
     sendRequest  opQuit "" 0 nop 0 nop 0 (CAS 0) h
-    peekResponse (\_ -> return ()) (\_ _ -> return ()) h
+    peekResponse (\_ -> return ()) (\_ -> return ()) h
 
 flushAll :: IO a -> Failure a -> Handle -> IO a
 flushAll success =
@@ -261,7 +270,7 @@ stats h = loop H.empty
   where
     loop m = do
         sendRequest opStat "" 0 nop 0 nop 0 (CAS 0) h
-        peekResponse (success m) (\w s -> throwIO $ MemcachedException w s) h
+        peekResponse (success m) throwIO h
 
     success m p = getTotalLength p >>= \tl ->
         if tl == 0
@@ -280,7 +289,7 @@ touch :: (Flags -> Value -> IO a) -> Failure a -> OpCode
       -> Key -> Expiry -> Handle -> IO a
 touch success failure op key e =
     withRequest op key 4 (flip pokeWord32be e) 0 nop (CAS 0)
-    (getSuccessCallback success) failure
+    (getSuccessCallback success failure) failure
 
 saslListMechs :: (S.ByteString -> IO a) -> Failure a
               -> Handle -> IO a

src/Database/Memcached/Binary/Maybe.hs

@@ -18,11 +18,11 @@ successNoReturn  = return True
 {-# INLINE successNoReturn #-}
 
 failureHasReturn :: I.Failure (HasReturn a)
-failureHasReturn _ _ = return Nothing
+failureHasReturn _ = return Nothing
 {-# INLINE failureHasReturn #-}
 
 failureNoReturn :: I.Failure NoReturn
-failureNoReturn _ _ = return False
+failureNoReturn _ = return False
 {-# INLINE failureNoReturn #-}
 
 #include "Common.hs"

src/Database/Memcached/Binary/Types/Exception.hs

@@ -8,14 +8,17 @@ import Data.Word
 import Data.Typeable
 import qualified Data.ByteString as S
 
-data MemcachedException = MemcachedException
-    {-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString
+data MemcachedException
+    = MemcachedException {-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString
+    | DataReadFailed
+    | VersionParseFailed
     deriving (Show, Typeable)
 
 instance Exception MemcachedException
 
 #define defExceptionP(n,w) n :: MemcachedException -> Bool;\
-n (MemcachedException i _) = i == w
+n (MemcachedException i _) = i == w;\
+n _ = False
 
 defExceptionP(isKeyNotFound                   , 0x01)
 defExceptionP(isKeyExists                     , 0x02)

test/test.hs

@@ -55,7 +55,9 @@ assertException ex msg m =
     (m >> throwIO (ByPassException "exception not occured.")) `catch`
     (\e -> case fromException e :: Maybe MemcachedException of
         Nothing -> assertFn e
-        Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e'))
+        Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e')
+        Just e' -> assertFn e'
+        )
   where
     assertFn e = assertFailure $ unlines
         [ "not expected exception occured:"