{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Symantic.HTTP.Pipes where
import Control.Arrow (first, right)
import Control.Monad (Monad(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Word (Word8)
import Prelude (fromIntegral, Num(..))
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Lens.Family as Lens
import qualified Lens.Family.State.Strict as Lens
import qualified Pipes as P
import qualified Pipes.ByteString as Pbs
import qualified Pipes.Group as Pg
import qualified Pipes.Parse as Pp
import qualified Pipes.Safe as Ps
import Symantic.HTTP.API
instance IsString () where
fromString _ = ()
type instance MC.CanDo (P.Effect m) (MC.EffExec w) = 'False
type instance MC.CanDo (P.Proxy a' a b' b m) (MC.EffExec w) = 'False
type instance FramingMonad (P.Producer a m r) = m
type instance FramingYield (P.Producer a m r) = a
type instance FramingReturn (P.Producer a m r) = r
type instance FramingMonad (P.ListT m a) = m
type instance FramingYield (P.ListT m a) = a
type instance FramingReturn (P.ListT m a) = ()
produceBS ::
IsString r =>
Monad m =>
m BS.ByteString -> P.Producer' BS.ByteString m r
produceBS mbs = go
where
go = do
bs <- lift mbs
if BS.null bs
then return ""
else do
P.yield bs
go
instance FramingEncode NoFraming (P.Producer a IO r) where
framingEncode _framing mimeEnc p =
right (first mimeEnc) <$> P.next p
instance FramingEncode NoFraming (P.Producer a (Ps.SafeT IO) r) where
framingEncode _framing mimeEnc p =
right (first mimeEnc) <$> Ps.runSafeT (P.next p)
instance FramingEncode NoFraming (P.ListT IO a) where
framingEncode _framing mimeEnc p =
right (\(a,n) -> (mimeEnc a, P.Select n)) <$> P.next (P.enumerate p)
instance IsString r => FramingDecode NoFraming (P.Producer a m r) where
framingDecode _framing mimeDec mbs =
produceBS mbs P.>-> go
where go = do
bs <- P.await
case mimeDec $ BSL.fromStrict bs of
Left err -> return $ fromString err
Right a -> P.yield a >> go
instance FramingEncode NewlineFraming (P.Producer a IO r) where
framingEncode _framing mimeEnc p =
right (first (newlineEncode mimeEnc))
<$> P.next p
instance FramingEncode NewlineFraming (P.Producer a (Ps.SafeT IO) r) where
framingEncode _framing mimeEnc p =
right (first (newlineEncode mimeEnc))
<$> Ps.runSafeT (P.next p)
instance IsString r => FramingDecode NewlineFraming (P.Producer a m r) where
framingDecode _framing mimeDec mbs =
Pg.concats $
Pg.maps
(\p -> P.for p $ \bs ->
case mimeDec $ BSL.fromStrict bs of
Left _err -> return ()
Right a -> P.yield a) $
Lens.view Pbs.lines $
produceBS mbs
newlineEncode :: (a -> BSL.ByteString) -> a -> BSL.ByteString
newlineEncode mimeEnc a = mimeEnc a <> BSL.singleton (fromIntegral (Char.ord '\n'))
instance FramingEncode NetstringFraming (P.Producer a IO r) where
framingEncode _framing mimeEnc p =
right (first (encodeNetstring mimeEnc))
<$> P.next p
instance FramingEncode NetstringFraming (P.Producer a (Ps.SafeT IO) r) where
framingEncode _framing mimeEnc p =
right (first (encodeNetstring mimeEnc))
<$> Ps.runSafeT (P.next p)
instance IsString r => FramingDecode NetstringFraming (P.Producer a m r) where
framingDecode _framing mimeDec mbs =
Pg.concats $
parseMany
(Pp.execStateT $ decodeNetstring @r mimeDec)
(produceBS mbs)
digit0, digit9 :: Word8
colon, comma :: Word8
newline :: Word8
digit0 = fromIntegral (Char.ord '0')
digit9 = fromIntegral (Char.ord '9')
colon = fromIntegral (Char.ord ':')
comma = fromIntegral (Char.ord ',')
newline = fromIntegral (Char.ord '\n')
encodeNetstring :: (a -> BSL.ByteString) -> a -> BSL.ByteString
encodeNetstring mimeEnc a =
let bs = mimeEnc a in
BSL8.pack (show (BSL8.length bs))
<> ":" <> bs <> ","
decodeNetstring ::
IsString r =>
Monad m =>
(BSL.ByteString -> Either String a) ->
ParserP BS.ByteString a m r
decodeNetstring mimeDec = do
lenBSs <- Lens.zoom (Pbs.span (\b -> digit0 <= b && b <= digit9)) drawAllP
case lenBSs >>= BS.unpack of
[] -> return "empty length"
w0:_:_ | w0 == digit0 -> return "leading zero"
lenWs -> do
let len = List.foldl' (\acc d -> acc * 10 + (fromIntegral d - digit0)) 0 lenWs
colonW <- drawByteP
if colonW /= Just colon
then return "colon expected"
else do
dataBS <- BSL.fromChunks <$> Lens.zoom (Pbs.splitAt len) drawAllP
commaW <- drawByteP
if commaW /= Just comma
then return "comma expected"
else do
case mimeDec dataBS of
Left err -> return $ fromString err
Right a -> do
yieldP a
decodeNetstring mimeDec
type ParserP inp out m r =
forall x. Pp.StateT (P.Producer inp m x) (P.Producer out m) r
yieldP :: Monad m => out -> ParserP inp out m ()
yieldP = lift . P.yield
drawP :: Monad m => ParserP inp out m (Maybe inp)
drawP = P.hoist lift Pp.draw
drawAllP :: Monad m => ParserP inp out m [inp]
drawAllP = P.hoist lift Pp.drawAll
drawByteP :: Monad m => ParserP BS.ByteString out m (Maybe Word8)
drawByteP = P.hoist lift Pbs.drawByte
unDrawP :: Monad m => inp -> ParserP inp out m ()
unDrawP = P.hoist lift . Pp.unDraw
parseMany ::
Monad m =>
(P.Producer a m r -> P.Producer b m (P.Producer a m r)) ->
P.Producer a m r ->
Pg.FreeT (P.Producer b m) m r
parseMany f = Pg.FreeT . go0
where
go0 p = do
P.next p >>= \case
Left r -> return (Pg.Pure r)
Right (bs, p') -> return $ Pg.Free (go1 (P.yield bs >> p'))
go1 p = Pg.FreeT . go0 <$> f p