Problems decoding a file strictly with Binary in Haskell

Question

Hi,

I'm trying to read and decode a binary file strictly, which seems to work most of the time. But unfortunately in a few cases my Program fails with

"too few bytes. Failed reading at byte position 1"

I guess Binary its decode function thinks there is no data available, but I know there is and just rerunning the program works fine.

I've tried several solutions, but neither was able to solve my problem :(

• using withBinaryFile:

  decodeFile' path = withBinaryFile path ReadMode doDecode
    where
      doDecode h = do c <- LBS.hGetContents h
                      return $! decode c
  

• reading the whole file with strict ByteString and decoding from it:

  decodeFile' path = decode . LBS.fromChunks . return <$> BS.readFile path
  

• adding some more strictness

  decodeFile' path = fmap (decode . LBS.fromChunks . return) $! BS.readFile path
  

Any ideas what is going on here and how to solve the issue?

Thanks!

EDIT: I think I've figured out my problem. It is not about strictly reading the file. I have a number of processes mostly reading from the file, but from time to time one needs to write to it which will truncate the file first and add the new content then. So for writing I need to set a file lock first, which seems not to be done when "Binary.encodeFile" is used (when I say process I don't mean threads, but real instances of the same program being run).

EDIT Finally had some time to solve my problem using POSIX IO and File Locks. I've had no more Problems since.

Just in case someone is interested in my current solution or maybe someone is able to point out errors/problems I'll post my solution here.

Safe encoding to File:

safeEncodeFile path value = do
    fd <- openFd path WriteOnly (Just 0o600) (defaultFileFlags {trunc = True})
    waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
    let cs = encode value
    let outFn = LBS.foldrChunks (\c rest -> writeChunk fd c >> rest) (return ()) cs
    outFn
    closeFd fd
  where
    writeChunk fd bs = unsafeUseAsCString bs $ \ptr ->
                         fdWriteBuf fd (castPtr ptr) (fromIntegral $ BS.length bs)

and decoding a File:

safeDecodeFile def path = do
    e <- doesFileExist path
    if e
      then do fd <- openFd path ReadOnly Nothing
                           (defaultFileFlags{nonBlock=True})
              waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
              c  <- fdGetContents fd
              let !v = decode $! c
              return v
      else return def

fdGetContents fd = lazyRead
  where
    lazyRead = unsafeInterleaveIO loop

    loop = do blk <- readBlock fd
              case blk of
                Nothing -> return LBS.Empty
                Just c  -> do cs <- lazyRead
                              return (LBS.Chunk c cs)

readBlock fd = do buf <- mallocBytes 4096
                  readSize <- fdReadBuf fd buf 4096
                  if readSize == 0
                    then do free buf
                            closeFd fd
                            return Nothing
                    else do bs <- unsafePackCStringFinalizer buf
                                         (fromIntegral readSize)
                                         (free buf)
                            return $ Just bs

With qualified imports for strict and lazy Bytestrings as:

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Internal as LBS

Answer 1

It would be helpful if you could produce some minimum code snippet that runs and demonstrates the problem. Right now I am not convinced this isn't a problem with your program tracking which handles are opened/closed and the reads/writes getting in the way of each other. Here is example test code I made that works fine.

import Data.Trie as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Binary
import System.IO

tmp = "blah"

main = do
    let trie = T.fromList    [(B.pack [p], p) | p <- [0..]]
    (file,hdl) <- openTempFile "/tmp" tmp
    B.hPutStr hdl (B.concat $ L.toChunks $ encode trie)
    hClose hdl
    putStrLn file
    t <- B.readFile file
    let trie' = decode (L.fromChunks [t])
    print (trie' == trie)