Pipes.hs

{-# 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 _ = ()

-- | Pass any executable effect to the underlying 'Monad'.
type instance MC.CanDo (P.Effect m) (MC.EffExec w) = 'False
-- | Pass any executable effect to the underlying 'Monad'.
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) = ()

-- | Produce 'BS.ByteString' from a 'Monad'.
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

-- * 'NoFraming'
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 =
		-- TODO: use drawAll
		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

-- * 'NewlineFraming'
-- TODO: see how to use Pbs._unlines?
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
			-- TODO: make mimeDecode directly able to use Pipes?
			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 'P.Parser'

-- | A 'P.Parser', which is itself a 'P.Producer',
-- and thus can 'yieldP' immediately.
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 f'@ groups a 'P.Producer' of 'BS.ByteString's
-- into a series of 'P.Producer's delimited by f,
-- where the delimiter is dropped
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

{-
-- * Type |Lens'|
-- | Package agnostic lens.
type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
(^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
a ^. lens = getConstant (lens Constant a)
-}