.travis.yml

@@ -1,18 +1,4 @@
-language: c
+language: haskell
-
+ghc:
-sudo: false
+  - 7.8
-
+  - 7.6
-matrix:
-  include:
-    - env: CABALVER=1.18 GHCVER=7.6.3
-      addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
-    - env: CABALVER=1.18 GHCVER=7.8.4
-      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
-    - env: CABALVER=1.22 GHCVER=7.10.2
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
-
-before_install:
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
-
-install: cabal update && cabal install --only-dependencies --enable-tests
-script: cabal configure --enable-tests && cabal build && cabal test

memcached-binary.cabal

@@ -1,5 +1,5 @@
 name:                memcached-binary
-version:             0.2.0
+version:             0.1.2
 synopsis:            memcached client using binary protocol.
 description:         memcached client using binary protocol.
 license:             MIT
@@ -8,7 +8,7 @@ author:              HirotomoMoriwaki<philopon.dependence@gmail.com>
 maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>
 Homepage:            https://github.com/philopon/memcached-binary
 Bug-reports:         https://github.com/philopon/memcached-binary/issues
-copyright:           (c) 2014-2015 Hirotomo Moriwaki
+copyright:           (c) 2014 Hirotomo Moriwaki
 category:            Database
 build-type:          Simple
 cabal-version:       >=1.10
@@ -25,14 +25,14 @@ library
                        Database.Memcached.Binary.Types.Exception
   other-modules:       Database.Memcached.Binary.Internal
                        Database.Memcached.Binary.Internal.Definition
-  build-depends:       base                 >=4.6  && <4.9
+  build-depends:       base                 >=4.6  && <4.8
                      , bytestring           >=0.10 && <0.11
                      , network              >=2.5  && <2.7
                      , storable-endian      >=0.2  && <0.3
                      , data-default-class   >=0.0  && <0.1
                      , resource-pool        >=0.2  && <0.3
                      , unordered-containers >=0.2  && <0.3
-                     , time                 >=1.4  && <1.6
+                     , time                 >=1.4  && <1.5
   ghc-options:         -Wall -O2
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -42,12 +42,12 @@ test-suite test
   hs-source-dirs:      test
   main-is:             test.hs
   ghc-options:         -Wall -O2
-  build-depends:       base
+  build-depends:       base                 >=4.6  && <4.8
-                     , hspec                >=2.1  && <2.3
+                     , hspec                >=1.11 && <1.12
                      , memcached-binary
                      , process              >=1.2  && <1.3
                      , network              >=2.5  && <2.7
-                     , HUnit                >=1.2  && <1.4
+                     , HUnit                >=1.2  && <1.3
-                     , data-default-class
+                     , data-default-class   >=0.0  && <0.1
-                     , bytestring
+                     , bytestring           >=0.10 && <0.11
   default-language:    Haskell2010

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 VersionParseFailed
+    Nothing -> failureHasReturn (-1) "version parse failed"
     Just v  -> successHasReturn v) failureHasReturn
   where
     readVersion s0 = do

src/Database/Memcached/Binary/Either.hs

@@ -18,11 +18,12 @@ successNoReturn  = return Nothing
 {-# INLINE successNoReturn #-}
 
 failureHasReturn :: I.Failure (HasReturn a)
-failureHasReturn = return . Left
+failureHasReturn i m = return . Left $ MemcachedException i m
 {-# INLINE failureHasReturn #-}
 
 failureNoReturn :: I.Failure NoReturn
-failureNoReturn = return . Just
+failureNoReturn i m = return . Just $ MemcachedException i m
 {-# 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 = throwIO
+failureHasReturn i m = throwIO $ MemcachedException i m
 {-# INLINE failureHasReturn #-}
 
 failureNoReturn :: I.Failure NoReturn
-failureNoReturn = throwIO
+failureNoReturn i m = throwIO $ MemcachedException i m
 {-# 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) throwIO h
+        auth a (\_ -> return h) (\w m -> throwIO $ MemcachedException w m) 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,20 +127,16 @@ sendRequest op key elen epoke vlen vpoke opaque cas h =
         hFlush h
 {-# INLINE sendRequest #-}
 
-type Failure a = MemcachedException -> IO a
+type Failure a = Word16 -> S.ByteString -> IO a
 
 peekResponse :: (Ptr Header -> IO a) -> Failure a -> Handle -> IO a
-peekResponse success failure h = allocaBytes 24 $ \p -> do
+peekResponse success failure h = allocaBytes 24 $ \p ->
-    len <- hGetBuf h p 24
+    hGetBuf h p 24 >> peekWord16be (plusPtr p 6) >>= \st ->
-    if len /= 24
+    if st == 0
-        then failure DataReadFailed
+        then success p
         else do
-            peekWord16be (plusPtr p 6) >>= \st ->
+            bl <- peekWord32be (plusPtr p 8)
-                if st == 0
+            failure st =<< S.hGet h (fromIntegral bl)
-                    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 ())
@@ -179,30 +175,27 @@ inspectResponse h p = do
     v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl
     return (e,k,v)
 
-getSuccessCallback :: (Flags -> Value -> IO a) -> Failure a
+getSuccessCallback :: (Flags -> Value -> IO a)
                    -> Handle -> Ptr Header -> IO a
-getSuccessCallback success failure h p = do
+getSuccessCallback success h p = do
     elen <- getExtraLength p
     tlen <- getTotalLength p
-    len  <- hGetBuf h p 4
+    void $ hGetBuf h p 4
-    if len /= 4
+    flags <- peekWord32be p
-        then failure DataReadFailed
+    value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
-        else do
+    success flags value
-            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) failure
+    (getSuccessCallback success) 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) failure h p) failure
+    (\h p -> getCAS p >>= \c -> getSuccessCallback (success c) h p) failure
 
 setAddReplace :: IO a -> Failure a -> OpCode -> CAS
               -> Key -> Value -> Flags -> Expiry -> Handle -> IO a
@@ -231,15 +224,13 @@ incrDecr success failure op cas key delta initial expiry =
         pokeWord32be (plusPtr p 16) expiry
 
     success' h p = do
-        len <- hGetBuf h p 8
+        void $ hGetBuf h p 8
-        if len /= 8
+        peekWord64be p >>= success
-            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 =
@@ -270,7 +261,7 @@ stats h = loop H.empty
   where
     loop m = do
         sendRequest opStat "" 0 nop 0 nop 0 (CAS 0) h
-        peekResponse (success m) throwIO h
+        peekResponse (success m) (\w s -> throwIO $ MemcachedException w s) h
 
     success m p = getTotalLength p >>= \tl ->
         if tl == 0
@@ -289,7 +280,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) failure
+    (getSuccessCallback success) 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,17 +8,14 @@ import Data.Word
 import Data.Typeable
 import qualified Data.ByteString as S
 
-data MemcachedException
+data MemcachedException = MemcachedException
-    = MemcachedException {-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString
+    {-# 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,9 +55,7 @@ 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:"