Ticket #4144: ByteStringHandle.hs

File ByteStringHandle.hs, 3.4 KB (added by AntoineLatter, 4 years ago)

ByteString? handle

Line 
1{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2
3module ByteStringHandle where
4
5import Control.Applicative
6import Control.Concurrent.MVar
7import Control.Monad
8
9import Data.ByteString (ByteString)
10import qualified Data.ByteString as B
11import Data.ByteString.Char8()
12import Data.ByteString.Unsafe as B
13import Data.ByteString.Internal (memcpy)
14import Data.Typeable (Typeable)
15import Data.Word
16
17import Foreign
18
19import GHC.IO.Buffer
20import GHC.IO.BufferedIO
21import GHC.IO.Device
22import GHC.IO.Handle
23
24import System.IO
25
26-- | Create a seakable read-handle from a bytestring
27bsHandle :: ByteString -> FilePath -> IO Handle
28bsHandle bs fp
29    = newBsDevice bs >>= \dev ->
30      mkFileHandle dev fp ReadMode Nothing noNewlineTranslation
31
32data BSIODevice
33    = BSIODevice
34       ByteString
35       (MVar Int) -- Position
36 deriving Typeable
37
38newBsDevice :: ByteString -> IO BSIODevice
39newBsDevice bs = BSIODevice bs <$> newMVar 0
40
41remaining :: BSIODevice -> IO Int
42remaining (BSIODevice bs mPos)
43    = do
44  let bsLen = B.length bs
45  withMVar mPos $ \pos -> return (bsLen - pos)
46
47sizeBS :: BSIODevice -> Int
48sizeBS (BSIODevice bs _) = B.length bs
49
50seekBS :: BSIODevice -> SeekMode -> Int -> IO ()
51seekBS dev AbsoluteSeek pos
52    | pos < 0 = error "Cannot seek to a negative position!"
53    | pos > sizeBS dev = error "Cannot seek past end of handle!"
54    | otherwise = case dev of
55                    BSIODevice _ mPos
56                        -> modifyMVar_ mPos $ \_ -> return pos
57seekBS dev SeekFromEnd pos = seekBS dev AbsoluteSeek (sizeBS dev - pos)
58seekBS dev RelativeSeek pos
59    = case dev of
60        BSIODevice _bs mPos
61            -> modifyMVar_ mPos $ \curPos ->
62               let newPos = curPos + pos
63               in if newPos < 0 || newPos > sizeBS dev
64                  then error "Cannot seek outside of handle!"
65                  else return newPos
66
67tellBS :: BSIODevice -> IO Int
68tellBS (BSIODevice _ mPos) = readMVar mPos
69
70dupBS :: BSIODevice -> IO BSIODevice
71dupBS (BSIODevice bs mPos) = BSIODevice bs <$> (readMVar mPos >>= newMVar)
72
73readBS :: BSIODevice -> Ptr Word8 -> Int -> IO Int
74readBS dev@(BSIODevice bs mPos) buff amount
75    = do
76  rem <- remaining dev
77  if amount > rem
78   then readBS dev buff rem
79   else B.unsafeUseAsCString bs $ \ptr ->
80       do
81         memcpy buff (castPtr ptr) (fromIntegral amount)
82         modifyMVar_ mPos (return . (+amount))
83         return amount
84
85instance BufferedIO BSIODevice where
86    newBuffer dev buffState = newByteBuffer (sizeBS dev) buffState
87    fillReadBuffer dev buff = readBuf dev buff
88    fillReadBuffer0 dev buff
89        = do
90      (amount, buff') <- fillReadBuffer dev buff
91      return (if amount == 0 then Nothing else Just amount, buff')
92
93instance RawIO BSIODevice where
94    read = readBS
95    readNonBlocking dev buff n = Just `liftM` readBS dev buff n
96
97instance IODevice BSIODevice where
98    ready _ True _ = return False -- read only
99    ready _ False _ = return True -- always ready
100
101    close _ = return ()
102    isTerminal _ = return False
103    isSeekable _ = return True
104    seek dev seekMode pos = seekBS dev seekMode (fromIntegral pos)
105    tell dev = fromIntegral <$> tellBS dev
106    getSize dev = return $ fromIntegral $ sizeBS dev
107    setEcho _ _ = error "Not a terminal device"
108    getEcho _ = error "Not a terminal device"
109    setRaw _ _ = error "Raw mode not supported"
110    devType _ = return RegularFile
111    dup = dupBS
112    dup2 _ _ = error "Dup2 not supported"
113