hOpenPGP-0.2: Data/Conduit/Cereal/Temp.hs

module Data.Conduit.Cereal.Temp (conduitGet)
where

import Control.Exception (throw)
import Control.Monad.Trans
import qualified Data.ByteString as BS
import qualified Data.Conduit as DC
import Data.Conduit.Cereal
import Data.Serialize
import Data.Serialize.Get

conduitGet :: (DC.ResourceThrow m, Serialize output) => Get output -> DC.Conduit BS.ByteString m output
conduitGet f = do
    let acceptable = case runGetPartial f BS.empty of
                 Data.Serialize.Fail s -> throw $ GetException s
                 Data.Serialize.Partial f -> True
                 Data.Serialize.Done _ _ -> throw GetDoesntConsumeInput
    if acceptable then DC.conduitState BS.empty (push f) (close f) else undefined
    where
        push :: (DC.ResourceThrow m, Serialize a) => Get a -> BS.ByteString -> BS.ByteString -> DC.ResourceT m (DC.ConduitStateResult BS.ByteString BS.ByteString a)
        push f state input = (\(as, bs) -> return $ DC.StateProducing bs as) (go f ([], state `BS.append` input))

        close :: (DC.ResourceThrow m, Serialize a) => Get a -> BS.ByteString -> DC.ResourceT m [a]
        close f state = return []

        go :: Serialize a => Get a -> ([a], BS.ByteString) -> ([a], BS.ByteString)
        go f (as, bs)
            | BS.null bs = (as, bs)
            | otherwise = case runGetState f bs 0 of
                              Left err -> (as, bs)
                              Right (a, b) -> go f (as ++ [a], b)