{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RecordWildCards #-}
module GHC.Debug.Types(module T
, Request(..)
, ForkOrPause(..)
, requestCommandId
, doRequest
, isWriteRequest
, withWriteRequest
, isImmutableRequest
, AnyReq(..)
, AnyResp(..)
, CommandId(..)
, SourceInformation(..)
, ClosureType(..)
, Version(..)
-- * Serialisation functions
, getIPE
, putIPE
, getInfoTable
, putInfoTable
, putRequest
, getCCS
, getCC
, putCCS
, putCC
, putIndexTable
, getIndexTable
, putCCSMainPtr
, getCCSMainPtr
, getProfilingMode
, putProfilingMode
, getRequest
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.Word
import System.IO
import Data.Functor
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Hashable
import GHC.Debug.Types.Closures as T
import GHC.Debug.Types.Ptr as T
import GHC.Debug.Types.Version
import GHC.Debug.Utils
import Control.Concurrent
-- | The decision about whether to fork the running process or
-- pause it running whilst we are debugging it.
data ForkOrPause = Pause | Fork deriving (Eq, Ord, Show, Enum)
instance Hashable ForkOrPause where
hashWithSalt s v = s `hashWithSalt` (fromEnum v)
instance Binary ForkOrPause where
put = putWord8 . fromIntegral . fromEnum
get = getWord8 >>= toBool
where
toBool 0 = return (toEnum 0)
toBool 1 = return (toEnum 1)
toBool c = fail ("Could not map value " ++ show c ++ " to ForkOrPause")
-- | A request sent from the debugger to the debuggee parametrized on the result type.
data Request a where
-- | Request protocol version
RequestVersion :: Request Version
-- | Pause the debuggee.
RequestPause :: ForkOrPause -> Request ()
-- | Resume the debuggee.
RequestResume :: Request ()
-- | Request the debuggee's root pointers.
RequestRoots :: Request [ClosurePtr]
-- | Request a closure
RequestClosure :: ClosurePtr -> Request RawClosure
-- | Request an info table
RequestInfoTable :: InfoTablePtr -> Request RawInfoTable
-- | Request the SRT of an info table. Some closures, like constructors, can never have SRTs.
-- Thunks, functions and stack frames may have SRTs.
-- Returns Nothing when the closure does not have an SRT.
RequestSRT :: InfoTablePtr -> Request (Maybe ClosurePtr)
-- | Wait for the debuggee to pause itself and then
-- execute an action. It currently impossible to resume after
-- a pause caused by a poll.
RequestPoll :: Request ()
-- | A client can save objects by calling a special RTS method
-- This function returns the closures it saved.
RequestSavedObjects :: Request [ClosurePtr]
-- | Request the pointer bitmap for a stack frame at a given offset
-- from a StackPtr.
RequestStackBitmap :: StackPtr -> Word32 -> Request PtrBitmap
-- | Decode the bitmap contained in a StgFunInfoTable
-- Used by PAP and AP closure types.
RequestFunBitmap :: Word16 -> ClosurePtr -> Request PtrBitmap
-- | Request the constructor description for an info table.
-- The info table must be from a 'ConstrClosure'
RequestConstrDesc :: InfoTablePtr -> Request ConstrDesc
-- | Lookup source information of an info table
RequestSourceInfo :: InfoTablePtr -> Request (Maybe SourceInformation)
-- | Copy all blocks from the process at once
RequestAllBlocks :: Request [RawBlock]
-- | Request the block which contains a specific pointer
RequestBlock :: ClosurePtr -> Request RawBlock
-- | Request the cost center stack
RequestCCS :: CCSPtr -> Request CCSPayload
-- | Request the cost center entry
RequestCC :: CCPtr -> Request CCPayload
-- | Request the index table.
RequestIndexTable :: IndexTablePtr -> Request IndexTable
-- | Request the CCS_MAIN pointer
RequestCCSMainPtr :: Request CCSPtr
data SourceInformation = SourceInformation { infoName :: !String
, infoClosureType :: !ClosureType
, infoType :: !String
, infoLabel :: !String
, infoModule :: !String
, infoPosition :: !String }
deriving (Show, Eq, Ord)
eq1request :: Request a -> Request b -> Bool
eq1request r1 r2 =
case r1 of
RequestVersion -> case r2 of {RequestVersion -> True; _ -> False}
RequestPause f1 -> case r2 of {RequestPause f2 -> f1 == f2; _ -> False }
RequestResume -> case r2 of {RequestResume -> True; _ -> False }
RequestRoots -> case r2 of {RequestRoots -> True; _ -> False }
RequestClosure cs -> case r2 of {(RequestClosure cs') -> cs == cs'; _ -> False }
RequestInfoTable itp -> case r2 of { (RequestInfoTable itp') -> itp == itp'; _ -> False }
RequestSRT itp -> case r2 of { (RequestSRT itp') -> itp == itp'; _ -> False }
RequestPoll -> case r2 of { RequestPoll -> True; _ -> False }
RequestSavedObjects -> case r2 of {RequestSavedObjects -> True; _ -> False }
RequestStackBitmap p o -> case r2 of {(RequestStackBitmap p' o') -> p == p' && o == o'; _ -> False }
RequestFunBitmap n cp -> case r2 of {(RequestFunBitmap n' cp') -> n == n' && cp == cp'; _ -> False }
RequestConstrDesc cp -> case r2 of { (RequestConstrDesc cp') -> cp == cp'; _ -> False }
RequestSourceInfo itp -> case r2 of { (RequestSourceInfo itp') -> itp == itp'; _ -> False }
RequestAllBlocks -> case r2 of { RequestAllBlocks -> True; _ -> False }
RequestBlock cp -> case r2 of { RequestBlock cp' -> cp == cp'; _ -> False }
RequestCCS cp -> case r2 of { RequestCCS cp' -> cp == cp'; _ -> False }
RequestCC cp -> case r2 of { RequestCC cp' -> cp == cp'; _ -> False }
RequestIndexTable cp -> case r2 of { RequestIndexTable cp' -> cp == cp'; _ -> False }
RequestCCSMainPtr -> case r2 of { RequestCCSMainPtr -> True; _ -> False }
-- | Whether a request mutates the debuggee state, don't cache these ones
isWriteRequest :: Request a -> Bool
isWriteRequest r = getConst $ withWriteRequest r (Const False) (const (Const True))
withWriteRequest :: Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a
withWriteRequest r def k =
case r of
RequestPause f -> k (RequestPause f)
RequestResume -> k RequestResume
RequestPoll -> k RequestPoll
_ -> def
-- | Requests which will always answer the same.
-- For example, info tables are immutable and so requesting an info table
-- will always result in the same value and is safe to cache across pause
-- lines.
isImmutableRequest :: Request a -> Bool
isImmutableRequest r =
case r of
RequestVersion {} -> True
RequestInfoTable {} -> True
RequestSRT {} -> True
RequestSourceInfo {} -> True
RequestConstrDesc {} -> True
RequestCCS {} -> True
RequestCC {} -> True
_ -> False
deriving instance Show (Request a)
deriving instance Eq (Request a)
instance Hashable (Request a) where
hashWithSalt s r = case r of
RequestVersion -> s `hashWithSalt` cmdRequestVersion
RequestPause f -> s `hashWithSalt` f `hashWithSalt` cmdRequestPause
RequestResume -> s `hashWithSalt` cmdRequestResume
RequestRoots -> s `hashWithSalt` cmdRequestRoots
RequestClosure cs -> s `hashWithSalt` cmdRequestClosures `hashWithSalt` cs
RequestInfoTable itp -> s `hashWithSalt` cmdRequestInfoTables `hashWithSalt` itp
RequestSRT itp -> s `hashWithSalt` cmdRequestSRT `hashWithSalt` itp
RequestPoll -> s `hashWithSalt` cmdRequestPoll
RequestSavedObjects -> s `hashWithSalt` cmdRequestSavedObjects
RequestStackBitmap p o -> s `hashWithSalt` cmdRequestStackBitmap `hashWithSalt` p `hashWithSalt` o
RequestFunBitmap n cp -> s `hashWithSalt` cmdRequestFunBitmap `hashWithSalt` cp `hashWithSalt` n
RequestConstrDesc cp -> s `hashWithSalt` cmdRequestConstrDesc `hashWithSalt` cp
RequestSourceInfo itp -> s `hashWithSalt` cmdRequestSourceInfo `hashWithSalt` itp
RequestAllBlocks -> s `hashWithSalt` cmdRequestAllBlocks
RequestBlock cp -> s `hashWithSalt` cmdRequestBlock `hashWithSalt` cp
RequestCCS cp -> s `hashWithSalt` cmdRequestCCS `hashWithSalt` cp
RequestCC cp -> s `hashWithSalt` cmdRequestCC `hashWithSalt` cp
RequestIndexTable cp -> s `hashWithSalt` cmdRequestIndexTable `hashWithSalt` cp
RequestCCSMainPtr -> s `hashWithSalt` cmdRequestCCSMainPtr
newtype CommandId = CommandId Word32
deriving (Eq, Ord, Show)
deriving newtype (Binary, Hashable)
requestCommandId :: Request a -> CommandId
requestCommandId r = case r of
RequestVersion {} -> cmdRequestVersion
RequestPause {} -> cmdRequestPause
RequestResume {} -> cmdRequestResume
RequestRoots {} -> cmdRequestRoots
RequestClosure {} -> cmdRequestClosures
RequestInfoTable {} -> cmdRequestInfoTables
RequestSRT {} -> cmdRequestSRT
RequestPoll {} -> cmdRequestPoll
RequestSavedObjects {} -> cmdRequestSavedObjects
RequestStackBitmap {} -> cmdRequestStackBitmap
RequestFunBitmap {} -> cmdRequestFunBitmap
RequestConstrDesc {} -> cmdRequestConstrDesc
RequestSourceInfo {} -> cmdRequestSourceInfo
RequestAllBlocks {} -> cmdRequestAllBlocks
RequestBlock {} -> cmdRequestBlock
RequestCCS{} -> cmdRequestCCS
RequestCC{} -> cmdRequestCC
RequestIndexTable{} -> cmdRequestIndexTable
RequestCCSMainPtr{} -> cmdRequestCCSMainPtr
cmdRequestVersion :: CommandId
cmdRequestVersion = CommandId 1
cmdRequestPause :: CommandId
cmdRequestPause = CommandId 2
cmdRequestResume :: CommandId
cmdRequestResume = CommandId 3
cmdRequestRoots :: CommandId
cmdRequestRoots = CommandId 4
cmdRequestClosures :: CommandId
cmdRequestClosures = CommandId 5
cmdRequestInfoTables :: CommandId
cmdRequestInfoTables = CommandId 6
cmdRequestStackBitmap :: CommandId
cmdRequestStackBitmap = CommandId 7
cmdRequestPoll :: CommandId
cmdRequestPoll = CommandId 8
cmdRequestSavedObjects :: CommandId
cmdRequestSavedObjects = CommandId 9
cmdRequestConstrDesc :: CommandId
cmdRequestConstrDesc = CommandId 11
cmdRequestSourceInfo :: CommandId
cmdRequestSourceInfo = CommandId 12
cmdRequestAllBlocks :: CommandId
cmdRequestAllBlocks = CommandId 14
cmdRequestBlock :: CommandId
cmdRequestBlock = CommandId 15
cmdRequestFunBitmap :: CommandId
cmdRequestFunBitmap = CommandId 16
cmdRequestSRT :: CommandId
cmdRequestSRT = CommandId 17
cmdRequestCCS :: CommandId
cmdRequestCCS = CommandId 18
cmdRequestCC :: CommandId
cmdRequestCC = CommandId 19
cmdRequestIndexTable :: CommandId
cmdRequestIndexTable = CommandId 20
cmdRequestCCSMainPtr :: CommandId
cmdRequestCCSMainPtr = CommandId 21
data AnyReq = forall req . AnyReq !(Request req)
instance Hashable AnyReq where
hashWithSalt s (AnyReq r) = hashWithSalt s r
instance Eq AnyReq where
(AnyReq r1) == (AnyReq r2) = eq1request r1 r2
data AnyResp = forall a . AnyResp !a !(a -> Put)
putCommand :: CommandId -> Put -> Put
putCommand c body = do
putWord32be $ fromIntegral (4 + BSL.length body')
put c
putLazyByteString body'
where
body' = runPut body
putRequest :: Request a -> Put
putRequest RequestVersion = putCommand cmdRequestVersion mempty
putRequest (RequestPause p) = putCommand cmdRequestPause (put p)
putRequest RequestResume = putCommand cmdRequestResume mempty
putRequest RequestRoots = putCommand cmdRequestRoots mempty
putRequest (RequestClosure cs) =
putCommand cmdRequestClosures $ do
putWord16be 1
put cs
putRequest (RequestInfoTable ts) =
putCommand cmdRequestInfoTables $ do
putWord16be 1
put ts
putRequest (RequestSRT ts) =
putCommand cmdRequestSRT $ do
putWord16be 1
put ts
putRequest (RequestStackBitmap sp o) =
putCommand cmdRequestStackBitmap $ put sp >> putWord32be o
putRequest (RequestFunBitmap n cp) =
putCommand cmdRequestFunBitmap $ put cp >> putWord16be n
putRequest (RequestConstrDesc itb) =
putCommand cmdRequestConstrDesc $ put itb
putRequest RequestPoll = putCommand cmdRequestPoll mempty
putRequest RequestSavedObjects = putCommand cmdRequestSavedObjects mempty
--putRequest (RequestFindPtr c) =
-- putCommand cmdRequestFindPtr $ put c
putRequest (RequestSourceInfo it) = putCommand cmdRequestSourceInfo $ put it
putRequest (RequestAllBlocks) = putCommand cmdRequestAllBlocks $ return ()
putRequest (RequestBlock cp) = putCommand cmdRequestBlock $ put cp
putRequest (RequestCCS cp) = putCommand cmdRequestCCS $ put cp
putRequest (RequestCC cp) = putCommand cmdRequestCC $ put cp
putRequest (RequestIndexTable cp) = putCommand cmdRequestIndexTable $ put cp
putRequest RequestCCSMainPtr = putCommand cmdRequestCCSMainPtr mempty
-- This is used to serialise the RequestCache
getRequest :: Get AnyReq
getRequest = do
len <- getWord32be
isolate (fromIntegral len) $ do
cmd <- get
if
| cmd == cmdRequestVersion -> return (AnyReq RequestVersion)
| cmd == cmdRequestPause -> do
b <- get
return (AnyReq (RequestPause b))
| cmd == cmdRequestResume -> return (AnyReq RequestResume)
| cmd == cmdRequestRoots -> return (AnyReq RequestRoots)
| cmd == cmdRequestClosures -> do
_n <- getWord16be
-- cs <- replicateM (fromIntegral n) get
cp <- get
return (AnyReq (RequestClosure cp))
| cmd == cmdRequestInfoTables -> do
_n <- getWord16be
--itbs <- replicateM (fromIntegral n) get
itb <- get
return (AnyReq (RequestInfoTable itb))
| cmd == cmdRequestSRT -> do
_n <- getWord16be
itb <- get
return (AnyReq (RequestSRT itb))
| cmd == cmdRequestStackBitmap -> do
sp <- get
o <- getWord32be
return (AnyReq (RequestStackBitmap sp o))
| cmd == cmdRequestFunBitmap -> do
cp <- get
n <- getWord16be
return (AnyReq (RequestFunBitmap n cp))
| cmd == cmdRequestConstrDesc -> do
itb <- get
return (AnyReq (RequestConstrDesc itb))
| cmd == cmdRequestPoll -> return (AnyReq RequestPoll)
| cmd == cmdRequestSavedObjects -> return (AnyReq RequestSavedObjects)
| cmd == cmdRequestSourceInfo -> do
it <- get
return (AnyReq (RequestSourceInfo it))
| cmd == cmdRequestAllBlocks -> return (AnyReq RequestAllBlocks)
| cmd == cmdRequestBlock -> do
cp <- get
return (AnyReq (RequestBlock cp))
| cmd == cmdRequestCCS -> do
cp <- get
return (AnyReq (RequestCCS cp))
| cmd == cmdRequestCC -> do
cp <- get
return (AnyReq (RequestCC cp))
| cmd == cmdRequestIndexTable -> do
cp <- get
return (AnyReq (RequestIndexTable cp))
| cmd == cmdRequestCCSMainPtr -> return (AnyReq RequestCCSMainPtr)
| otherwise -> error (show cmd)
getResponse :: Request a -> Get a
getResponse RequestVersion = Version <$> get <*> get <*> getProfilingMode <*> get
getResponse RequestPause {} = get
getResponse RequestResume = get
getResponse RequestRoots = many get
getResponse (RequestClosure {}) = get
getResponse (RequestInfoTable {}) = getInfoTable
getResponse (RequestSRT {}) = do
cptr <- get
pure $ guard (cptr /= UntaggedClosurePtr 0) $> cptr
-- zipWith (\p (it, r) -> (StgInfoTableWithPtr p it, r)) itps
-- <$> replicateM (length itps) getInfoTable
getResponse (RequestStackBitmap {}) = get
getResponse (RequestFunBitmap {}) = get
getResponse (RequestConstrDesc _) = getConstrDesc
getResponse RequestPoll = get
getResponse RequestSavedObjects = many get
getResponse (RequestSourceInfo _c) = getIPE
getResponse RequestAllBlocks = many get
getResponse RequestBlock {} = get
getResponse (RequestCCS {}) = getCCS
getResponse (RequestCC {}) = getCC
getResponse (RequestIndexTable {}) = getIndexTable
getResponse (RequestCCSMainPtr {}) = getCCSMainPtr
getProfilingMode :: Get (Maybe ProfilingMode)
getProfilingMode = do
w <- getWord8
case w of
0 -> pure $ Nothing
1 -> pure $ Just NoProfiling
2 -> pure $ Just RetainerProfiling
3 -> pure $ Just LDVProfiling
4 -> pure $ Just EraProfiling
5 -> pure $ Just OtherProfiling
_ -> error $ "Unknown profiling mode: " ++ (show w)
putProfilingMode :: Maybe ProfilingMode -> Put
putProfilingMode Nothing = putWord8 0
putProfilingMode (Just mode) =
case mode of
NoProfiling -> putWord8 1
RetainerProfiling -> putWord8 2
LDVProfiling -> putWord8 3
EraProfiling -> putWord8 4
OtherProfiling -> putWord8 5
getCCS :: Get CCSPayload
getCCS = do
ccsID <- getInt64le
ccsCc <- get
ccsPrevStack <- do
p <- get
pure $ guard (p /= CCSPtr 0) $> p
ccsIndexTable <- do
p <- get
pure $ guard (p /= IndexTablePtr 0) $> p
ccsRoot <- do
p <- get
pure $ guard (p /= CCSPtr 0) $> p
ccsDepth <- fromIntegral <$> getWord64le
ccsSccCount <- getWord64le
ccsSelected <- fromIntegral <$> getWord64le
ccsTimeTicks <- fromIntegral <$> getWord64le
ccsMemAlloc <- getWord64le
ccsInheritedAlloc <- getWord64le
ccsInheritedTicks <- fromIntegral <$> getWord64le
pure CCSPayload{..}
putCCS :: CCSPayload -> Put
putCCS CCSPayload{..} = do
putInt64le ccsID
put ccsCc
case ccsPrevStack of
Nothing -> put (CCSPtr 0)
Just x -> put x
case ccsIndexTable of
Nothing -> put (IndexTablePtr 0)
Just x -> put x
case ccsRoot of
Nothing -> put (CCSPtr 0)
Just x -> put x
putWord64le $ fromIntegral ccsDepth
putWord64le ccsSccCount
putWord64le $ fromIntegral ccsSelected
putWord64le $ fromIntegral ccsTimeTicks
putWord64le ccsMemAlloc
putWord64le ccsInheritedAlloc
putWord64le $ fromIntegral ccsInheritedTicks
getCC :: Get CCPayload
getCC = do
ccID <- getInt64le
ccLabel <- getString
ccMod <- getString
ccLoc <- getString
ccMemAlloc <- get
ccTimeTicks <- get
ccIsCaf <- (\i -> if i == 0 then False else True ) <$> getWord64be
ccLink <- do
p <- get
pure $ guard (p /= CCPtr 0) $> p
pure CCPayload{..}
where
getString = do
len <- getInt32be
C8.unpack <$> getByteString (fromIntegral len)
putCC :: CCPayload -> Put
putCC CCPayload{..} = do
putInt64le ccID
putString ccLabel
putString ccMod
putString ccLoc
put ccMemAlloc
put ccTimeTicks
if ccIsCaf
then putWord64le 0
else putWord64le 1
case ccLink of
Nothing -> put (CCPtr 0)
Just x -> put x
where
putString xs = do
putInt32be (fromIntegral $ length xs)
putByteString (C8.pack xs)
getIndexTable :: Get IndexTable
getIndexTable = do
itCostCentre <- get
itCostCentreStack <- get
itNext <- do
p <- get
pure $ guard (p /= IndexTablePtr 0) $> p
itBackEdge <- (\i -> if i == 0 then False else True) <$> getWord8
pure IndexTable{..}
putIndexTable :: IndexTable -> Put
putIndexTable IndexTable {..} = do
put itCostCentre
put itCostCentreStack
case itNext of
Nothing -> put (IndexTablePtr 0)
Just x -> put x
if itBackEdge
then putWord8 0
else putWord8 1
getCCSMainPtr :: Get CCSPtr
getCCSMainPtr = get
putCCSMainPtr :: CCSPtr -> Put
putCCSMainPtr = put
getConstrDesc :: Get ConstrDesc
getConstrDesc = do
len <- getInt32be
parseConstrDesc . C8.unpack <$> getByteString (fromIntegral len)
getIPE :: Get (Maybe SourceInformation)
getIPE = do
num <- getInt32be
res <- replicateM (fromIntegral num) getOne
case res of
(id_name:cty:ty:lab:modu:loc:[]) ->
return . Just $! SourceInformation id_name (readCTy cty) ty lab modu loc
[] -> return Nothing
fs -> fail (show ("Expecting 6 or 0 fields in IPE" :: String, fs,num))
where
getOne = do
!len <- getInt32be
!res <- C8.unpack <$> getByteString (fromIntegral len)
return res
-- All constructor nodes get 0, this is a wibble in the implementation
-- of IPEs
readCTy "0" = CONSTR
readCTy n = toEnum (read @Int n)
putIPE :: Maybe SourceInformation -> Put
putIPE Nothing = putInt32be 0
putIPE (Just (SourceInformation a ty b c d e)) = do
putInt32be 6
putOne a
putOne (show (fromEnum ty))
putOne b
putOne c
putOne d
putOne e
where
putOne s = do
putInt32be (fromIntegral $ length s)
putByteString (C8.pack s)
getInfoTable :: Get RawInfoTable
getInfoTable = do
!len <- getInt32be
!r <- RawInfoTable <$> getByteString (fromIntegral len)
return r
putInfoTable :: RawInfoTable -> Put
putInfoTable (RawInfoTable rc) = do
let n = BS.length rc
putWord32be (fromIntegral n)
putByteString rc
data Error = BadCommand
| BadStack
| AlreadyPaused
| NotPaused
| NoResume
deriving stock (Eq, Ord, Show)
instance Exception Error
data ResponseCode = Okay
| OkayContinues
| Error Error
deriving stock (Eq, Ord, Show)
getResponseCode :: Get ResponseCode
getResponseCode = getWord16be >>= f
where
f 0x0 = pure Okay
f 0x1 = pure OkayContinues
f 0x100 = pure $ Error BadCommand
f 0x104 = pure $ Error BadStack
f 0x101 = pure $ Error AlreadyPaused
f 0x102 = pure $ Error NotPaused
f 0x103 = pure $ Error NoResume
f c = error $ "Unknown response code: " ++ showAsHex c
data Stream a r = Next !a (Stream a r)
| End r
readFrames :: Handle -> IO (Stream BS.ByteString (Maybe Error))
readFrames hdl = do
(respLen, status) <- runGet_ frameHeader <$> BSL.hGet hdl 6
respBody <- BS.hGet hdl (fromIntegral respLen)
case status of
OkayContinues -> do rest <- readFrames hdl
return $ Next respBody rest
Okay -> return $ Next respBody (End Nothing)
Error err-> return $ End (Just err)
where
frameHeader :: Get (Word32, ResponseCode)
frameHeader =
(,) <$> getWord32be
<*> getResponseCode
throwStream :: Exception e => Stream a (Maybe e) -> [a]
throwStream = f
where
f (Next x rest) = x : f rest
f (End Nothing) = []
f (End (Just e)) = throw e
concatStream :: Stream BS.ByteString (Maybe Error) -> BSL.ByteString
concatStream = BSL.fromChunks . throwStream
-- | Perform a request
doRequest :: MVar Handle -> Request a -> IO a
doRequest mhdl req = withMVar mhdl $ \hdl -> do
BSL.hPutStr hdl $ runPut $ putRequest req
bframes <- readFrames hdl
let x = runGet_ (getResponse req) (concatStream bframes)
return x