acid-state 0.12.0 → 0.12.1
raw patch · 3 files changed
+40/−25 lines, 3 filesdep ~cerealdep ~template-haskell
Dependency ranges changed: cereal, template-haskell
Files
- acid-state.cabal +2/−2
- src/Data/Acid/Archive.hs +8/−8
- src/Data/Acid/Remote.hs +30/−15
acid-state.cabal view
@@ -1,5 +1,5 @@ Name: acid-state-Version: 0.12.0+Version: 0.12.1 Synopsis: Add ACID guarantees to any serializable Haskell data structure. Description: Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage: http://acid-state.seize.it/@@ -34,7 +34,7 @@ Build-depends: array, base >= 4 && < 5, bytestring >= 0.10,- cereal >= 0.3.2.0,+ cereal >= 0.4.0.0, containers, extensible-exceptions, safecopy >= 0.6,
src/Data/Acid/Archive.hs view
@@ -14,14 +14,14 @@ , entriesToListNoFail ) where -import Data.Acid.CRC+import Data.Acid.CRC -import qualified Data.ByteString.Lazy as Lazy-import qualified Data.ByteString as Strict-import qualified Data.Serialize.Get as Serialize-import Data.Serialize.Get hiding (Result(..))-import Data.Serialize.Builder-import Data.Monoid+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import Data.Monoid+import Data.Serialize.Builder+import Data.Serialize.Get hiding (Result (..))+import qualified Data.Serialize.Get as Serialize type Entry = Lazy.ByteString data Entries = Done | Next Entry Entries | Fail String@@ -62,7 +62,7 @@ Serialize.Done entry rest | Strict.null rest -> Next entry (worker more) | otherwise -> Next entry (worker (rest:more))- Serialize.Fail msg -> Fail msg+ Serialize.Fail msg _ -> Fail msg Serialize.Partial cont -> case more of [] -> check (cont Strict.empty) [] (x:xs) -> check (cont x) xs
src/Data/Acid/Remote.hs view
@@ -78,6 +78,7 @@ ( -- * Server/Client acidServer+ , acidServer' , openRemoteState -- * Authentication , skipAuthenticationCheck@@ -213,10 +214,6 @@ using a socket file. To control access, you can set the permissions of the parent directory which contains the socket file. - The message @SerializeError "too few bytes\nFrom:\tdemandInput\n\n"@ is- displayed on the standard error channel of the server whenever a- client disconnects.- see also: 'openRemoteState' and 'sharedSecretCheck'. -} acidServer :: SafeCopy st =>@@ -227,6 +224,28 @@ acidServer checkAuth port acidState = withSocketsDo $ do listenSocket <- listenOn port+ (acidServer' checkAuth listenSocket acidState) `finally` (cleanup listenSocket)+ where+ cleanup socket =+ do sClose socket+ case port of+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+ UnixSocket path -> removeFile path+#endif+ _ -> return ()++{- | Works the same way as 'acidServer', but uses pre-binded socket @listenSocket@.++ Can be useful when fine-tuning of socket binding parameters is needed+ (for example, listening on a particular network interface, IPv4/IPv6 options).+ -}+acidServer' :: SafeCopy st =>+ (CommChannel -> IO Bool) -- ^ check authentication, see 'sharedSecretPerform'+ -> Socket -- ^ binded socket to accept connections from+ -> AcidState st -- ^ state to serve+ -> IO ()+acidServer' checkAuth listenSocket acidState+ = do let loop = forever $ do (socket, _sockAddr) <- accept listenSocket let commChannel = socketToCommChannel socket@@ -235,7 +254,7 @@ process commChannel acidState ccClose commChannel -- FIXME: `finally` ? infi = loop `catchSome` logError >> infi- infi `finally` (cleanup listenSocket)+ infi where logError :: (Show e) => e -> IO () logError e = hPrint stderr e@@ -254,13 +273,6 @@ then return () -- h (toException e) -- we could log the exception, but there could be thousands of them else throw e ]- cleanup socket =- do sClose socket- case port of-#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)- UnixSocket path -> removeFile path-#endif- _ -> return () data Command = RunQuery (Tagged Lazy.ByteString) | RunUpdate (Tagged Lazy.ByteString)@@ -310,9 +322,12 @@ worker chan (runGetPartial get Strict.empty) where worker chan inp = case inp of- Fail msg -> throwIO (SerializeError msg)+ Fail msg _ -> throwIO (SerializeError msg) Partial cont -> do bs <- ccGetSome 1024- worker chan (cont bs)+ if Strict.null bs then+ return ()+ else+ worker chan (cont bs) Done cmd rest -> do processCommand chan cmd; worker chan (runGetPartial get rest) processCommand chan cmd = case cmd of@@ -414,7 +429,7 @@ getResponse leftover = do debugStrLn $ "listener: listening for Response." let go inp = case inp of- Fail msg -> error msg+ Fail msg _ -> error msg Partial cont -> do debugStrLn $ "listener: ccGetSome" bs <- ccGetSome cc 1024 go (cont bs)