Symantic/HTTP/Pipes.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RankNTypes #-}
   3 {-# OPTIONS_GHC -Wno-orphans #-}
   4 module Symantic.HTTP.Pipes where
   5
   6 import Control.Arrow (first, right)
   7 import Control.Monad (Monad(..))
   8 import Control.Monad.Trans.Class (MonadTrans(..))
   9 import Data.Bool
  10 import Data.Either (Either(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Maybe (Maybe(..))
  15 import Data.Ord (Ord(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.String (String, IsString(..))
  18 import Data.Word (Word8)
  19 import Prelude (fromIntegral, Num(..))
  20 import System.IO (IO)
  21 import Text.Show (Show(..))
  22 import qualified Control.Monad.Classes as MC
  23 import qualified Data.ByteString as BS
  24 import qualified Data.ByteString.Lazy as BSL
  25 import qualified Data.ByteString.Lazy.Char8 as BSL8
  26 import qualified Data.Char as Char
  27 import qualified Data.List as List
  28 import qualified Lens.Family as Lens
  29 import qualified Lens.Family.State.Strict as Lens
  30 import qualified Pipes as P
  31 import qualified Pipes.ByteString as Pbs
  32 import qualified Pipes.Group as Pg
  33 import qualified Pipes.Parse as Pp
  34 import qualified Pipes.Safe as Ps
  35
  36 import Symantic.HTTP.API
  37
  38 instance IsString () where
  39         fromString _ = ()
  40
  41 type instance MC.CanDo (P.Effect m) (MC.EffExec w) = 'False
  42
  43 type instance FramingMonad  (P.Producer a m r) = m
  44 type instance FramingYield  (P.Producer a m r) = a
  45 type instance FramingReturn (P.Producer a m r) = r
  46
  47 type instance FramingMonad  (P.ListT m a) = m
  48 type instance FramingYield  (P.ListT m a) = a
  49 type instance FramingReturn (P.ListT m a) = ()
  50
  51 -- | Produce 'BS.ByteString' from a 'Monad'.
  52 produceBS ::
  53  IsString r =>
  54  MC.MonadExec IO m =>
  55  m BS.ByteString -> P.Producer' BS.ByteString m r
  56 produceBS mbs = go
  57         where
  58         go = do
  59                 bs <- lift mbs
  60                 if BS.null bs
  61                 then return ""
  62                 else do
  63                         P.yield bs
  64                         go
  65
  66 -- * 'NoFraming'
  67 instance FramingEncode NoFraming (P.Producer a IO r) where
  68         framingEncode _framing mimeEnc p =
  69                 right (first mimeEnc) <$> P.next p
  70 instance FramingEncode NoFraming (P.Producer a (Ps.SafeT IO) r) where
  71         framingEncode _framing mimeEnc p =
  72                 right (first mimeEnc) <$> Ps.runSafeT (P.next p)
  73 instance FramingEncode NoFraming (P.ListT IO a) where
  74         framingEncode _framing mimeEnc p =
  75                 right (\(a,n) -> (mimeEnc a, P.Select n)) <$> P.next (P.enumerate p)
  76 instance IsString r => FramingDecode NoFraming (P.Producer a m r) where
  77         framingDecode _framing mimeDec mbs =
  78                 -- TODO: use drawAll
  79                 produceBS mbs P.>-> go
  80                 where go = do
  81                         bs <- P.await
  82                         case mimeDec $ BSL.fromStrict bs of
  83                          Left err -> return $ fromString err
  84                          Right a -> P.yield a >> go
  85
  86 -- * 'NewlineFraming'
  87 -- TODO: see how to use Pbs._unlines?
  88 instance FramingEncode NewlineFraming (P.Producer a IO r) where
  89         framingEncode _framing mimeEnc p =
  90                 right (first (newlineEncode mimeEnc))
  91                  <$> P.next p
  92 instance FramingEncode NewlineFraming (P.Producer a (Ps.SafeT IO) r) where
  93         framingEncode _framing mimeEnc p =
  94                 right (first (newlineEncode mimeEnc))
  95                  <$> Ps.runSafeT (P.next p)
  96 instance IsString r => FramingDecode NewlineFraming (P.Producer a m r) where
  97         framingDecode _framing mimeDec mbs =
  98                 Pg.concats $
  99                 Pg.maps
 100                  (\p -> P.for p $ \bs ->
 101                         case mimeDec $ BSL.fromStrict bs of
 102                          Left _err -> return ()
 103                          Right a  -> P.yield a) $
 104                 Lens.view Pbs.lines $
 105                 produceBS mbs
 106
 107 newlineEncode :: (a -> BSL.ByteString) -> a -> BSL.ByteString
 108 newlineEncode mimeEnc a = mimeEnc a <> BSL.singleton (fromIntegral (Char.ord '\n'))
 109
 110 instance FramingEncode NetstringFraming (P.Producer a IO r) where
 111         framingEncode _framing mimeEnc p =
 112                 right (first (netstringEncode mimeEnc))
 113                  <$> P.next p
 114 instance FramingEncode NetstringFraming (P.Producer a (Ps.SafeT IO) r) where
 115         framingEncode _framing mimeEnc p =
 116                 right (first (netstringEncode mimeEnc))
 117                  <$> Ps.runSafeT (P.next p)
 118 instance IsString r => FramingDecode NetstringFraming (P.Producer a m r) where
 119         framingDecode _framing mimeDec mbs =
 120                 Pg.concats $
 121                 parseMany
 122                  (Pp.execStateT $ parseNetstringP @r mimeDec)
 123                  (produceBS mbs)
 124
 125 digit0, digit9 :: Word8
 126 colon, comma :: Word8
 127 newline :: Word8
 128 digit0  = fromIntegral (Char.ord '0')
 129 digit9  = fromIntegral (Char.ord '9')
 130 colon   = fromIntegral (Char.ord ':')
 131 comma   = fromIntegral (Char.ord ',')
 132 newline = fromIntegral (Char.ord '\n')
 133
 134 netstringEncode :: (a -> BSL.ByteString) -> a -> BSL.ByteString
 135 netstringEncode mimeEnc a =
 136         let bs = mimeEnc a in
 137         BSL8.pack (show (BSL8.length bs))
 138          <> ":" <> bs <> ","
 139
 140 parseNetstringP ::
 141  IsString r =>
 142  Monad m =>
 143  (BSL.ByteString -> Either String a) ->
 144  ParserP BS.ByteString a m r
 145 parseNetstringP mimeDec = do
 146         lenBSs <- Lens.zoom (Pbs.span (\b -> digit0 <= b && b <= digit9)) drawAllP
 147         case lenBSs >>= BS.unpack of
 148          [] -> return "empty length"
 149          w0:_:_ | w0 == digit0 -> return "leading zero"
 150          lenWs -> do
 151                 let len = List.foldl' (\acc d -> acc * 10 + (fromIntegral d - digit0)) 0 lenWs
 152                 colonW <- drawByteP
 153                 if colonW /= Just colon
 154                 then return "colon expected"
 155                 else do
 156                         -- TODO: make mimeDecode directly able to use Pipes?
 157                         dataBS <- BSL.fromChunks <$> Lens.zoom (Pbs.splitAt len) drawAllP
 158                         commaW <- drawByteP
 159                         if commaW /= Just comma
 160                         then return "comma expected"
 161                         else do
 162                                 case mimeDec dataBS of
 163                                  Left err -> return $ fromString err
 164                                  Right a -> do
 165                                         yieldP a
 166                                         parseNetstringP mimeDec
 167
 168 -- * Type 'P.Parser'
 169
 170 -- | A 'P.Parser', which is itself a 'P.Producer',
 171 -- and thus can 'yieldP' immediately.
 172 type ParserP inp out m r =
 173  forall x. Pp.StateT (P.Producer inp m x) (P.Producer out m) r
 174
 175 yieldP :: Monad m => out -> ParserP inp out m ()
 176 yieldP = lift . P.yield
 177
 178 drawP :: Monad m => ParserP inp out m (Maybe inp)
 179 drawP = P.hoist lift Pp.draw
 180
 181 drawAllP :: Monad m => ParserP inp out m [inp]
 182 drawAllP = P.hoist lift Pp.drawAll
 183
 184 drawByteP :: Monad m => ParserP BS.ByteString out m (Maybe Word8)
 185 drawByteP = P.hoist lift Pbs.drawByte
 186
 187 unDrawP :: Monad m => inp -> ParserP inp out m ()
 188 unDrawP = P.hoist lift . Pp.unDraw
 189
 190 -- | @'parseMany f'@ groups a 'P.Producer' of 'BS.ByteString's
 191 -- into a series of 'P.Producer's delimited by f,
 192 -- where the delimiter is dropped
 193 parseMany ::
 194  Monad m =>
 195  (P.Producer a m r -> P.Producer b m (P.Producer a m r)) ->
 196  P.Producer a m r ->
 197  Pg.FreeT (P.Producer b m) m r
 198 parseMany f = Pg.FreeT . go0
 199         where
 200         go0 p = do
 201                 P.next p >>= \case
 202                  Left r -> return (Pg.Pure r)
 203                  Right (bs, p') -> return $ Pg.Free (go1 (P.yield bs >> p'))
 204         go1 p = Pg.FreeT . go0 <$> f p
 205
 206 {-
 207 -- * Type |Lens'|
 208 -- | Package agnostic lens.
 209 type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
 210 (^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
 211 a ^. lens = getConstant (lens Constant a)
 212 -}