container travis

.travis.yml

@@ -1,4 +1,18 @@
-language: haskell
-ghc:
-  - 7.8
-  - 7.6
+language: c
+
+sudo: false
+
+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.1.2
+version:             0.2.0
 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 Hirotomo Moriwaki
+copyright:           (c) 2014-2015 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.8
+  build-depends:       base                 >=4.6  && <4.9
                      , 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.5
+                     , time                 >=1.4  && <1.6
   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                 >=4.6  && <4.8
-                     , hspec                >=1.11 && <1.12
+  build-depends:       base
+                     , hspec                >=2.1  && <2.3
                      , memcached-binary
                      , process              >=1.2  && <1.3
                      , network              >=2.5  && <2.7
-                     , HUnit                >=1.2  && <1.3
-                     , data-default-class   >=0.0  && <0.1
-                     , bytestring           >=0.10 && <0.11
+                     , HUnit                >=1.2  && <1.4
+                     , data-default-class
+                     , bytestring
   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 (-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:"