module Database.EventStore.Internal.Reader (readerThread) where
import Prelude hiding (take)
import Control.Monad
import qualified Data.ByteString as B
import System.IO
import Text.Printf
import Data.Serialize.Get
import Data.UUID
import Database.EventStore.Internal.Types
readerThread :: (Package -> IO ()) -> Handle -> IO ()
readerThread push_p h = forever $ do
header_bs <- B.hGet h 4
case runGet getLengthPrefix header_bs of
Left _
-> error "Wrong package framing"
Right length_prefix
-> B.hGet h length_prefix >>= parsePackage
where
parsePackage bs =
case runGet getPackage bs of
Left e -> error $ printf "Parsing error [%s]" e
Right pack -> push_p pack
getLengthPrefix :: Get Int
getLengthPrefix = fmap fromIntegral getWord32le
authOffset :: Int
authOffset = 18
getPackage :: Get Package
getPackage = do
cmd <- getWord8
flg <- getFlag
col <- getUUID
cred <- getCredentials flg
rest <- remaining
dta <- getBytes rest
let pack = Package
{ packageCmd = cmd
, packageCorrelation = col
, packageData = dta
, packageCred = cred
}
return pack
getFlag :: Get Flag
getFlag = do
wd <- getWord8
case wd of
0x00 -> return None
0x01 -> return Authenticated
_ -> fail $ printf "TCP: Unhandled flag value 0x%x" wd
getCredEntryLength :: Get Int
getCredEntryLength = fmap fromIntegral getWord8
getCredentials :: Flag -> Get (Maybe Credentials)
getCredentials None = return Nothing
getCredentials _ = do
loginLen <- getCredEntryLength
login <- getBytes loginLen
passwLen <- getCredEntryLength
passw <- getBytes passwLen
return $ Just $ credentials login passw
getUUID :: Get UUID
getUUID = do
bs <- getLazyByteString 16
case fromByteString bs of
Just uuid -> return uuid
_ -> fail "TCP: Wrong UUID format"