symantic-http-pipes/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 -- | Pass any executable effect to the underlying 'Monad'.
  42 type instance MC.CanDo (P.Effect m) (MC.EffExec w) = 'False
  43 -- | Pass any executable effect to the underlying 'Monad'.
  44 type instance MC.CanDo (P.Proxy a' a b' b m) (MC.EffExec w) = 'False
  45
  46 type instance FramingMonad  (P.Producer a m r) = m
  47 type instance FramingYield  (P.Producer a m r) = a
  48 type instance FramingReturn (P.Producer a m r) = r
  49
  50 type instance FramingMonad  (P.ListT m a) = m
  51 type instance FramingYield  (P.ListT m a) = a
  52 type instance FramingReturn (P.ListT m a) = ()
  53
  54 -- | Produce 'BS.ByteString' from a 'Monad'.
  55 produceBS ::
  56  IsString r =>
  57  Monad m =>
  58  m BS.ByteString -> P.Producer' BS.ByteString m r
  59 produceBS mbs = go
  60         where
  61         go = do
  62                 bs <- lift mbs
  63                 if BS.null bs
  64                 then return ""
  65                 else do
  66                         P.yield bs
  67                         go
  68
  69 -- * 'NoFraming'
  70 instance FramingEncode NoFraming (P.Producer a IO r) where
  71         framingEncode _framing mimeEnc p =
  72                 right (first mimeEnc) <$> P.next p
  73 instance FramingEncode NoFraming (P.Producer a (Ps.SafeT IO) r) where
  74         framingEncode _framing mimeEnc p =
  75                 right (first mimeEnc) <$> Ps.runSafeT (P.next p)
  76 instance FramingEncode NoFraming (P.ListT IO a) where
  77         framingEncode _framing mimeEnc p =
  78                 right (\(a,n) -> (mimeEnc a, P.Select n)) <$> P.next (P.enumerate p)
  79 instance IsString r => FramingDecode NoFraming (P.Producer a m r) where
  80         framingDecode _framing mimeDec mbs =
  81                 -- TODO: use drawAll
  82                 produceBS mbs P.>-> go
  83                 where go = do
  84                         bs <- P.await
  85                         case mimeDec $ BSL.fromStrict bs of
  86                          Left err -> return $ fromString err
  87                          Right a -> P.yield a >> go
  88
  89 -- * 'NewlineFraming'
  90 -- TODO: see how to use Pbs._unlines?
  91 instance FramingEncode NewlineFraming (P.Producer a IO r) where
  92         framingEncode _framing mimeEnc p =
  93                 right (first (newlineEncode mimeEnc))
  94                  <$> P.next p
  95 instance FramingEncode NewlineFraming (P.Producer a (Ps.SafeT IO) r) where
  96         framingEncode _framing mimeEnc p =
  97                 right (first (newlineEncode mimeEnc))
  98                  <$> Ps.runSafeT (P.next p)
  99 instance IsString r => FramingDecode NewlineFraming (P.Producer a m r) where
 100         framingDecode _framing mimeDec mbs =
 101                 Pg.concats $
 102                 Pg.maps
 103                  (\p -> P.for p $ \bs ->
 104                         case mimeDec $ BSL.fromStrict bs of
 105                          Left _err -> return ()
 106                          Right a  -> P.yield a) $
 107                 Lens.view Pbs.lines $
 108                 produceBS mbs
 109
 110 newlineEncode :: (a -> BSL.ByteString) -> a -> BSL.ByteString
 111 newlineEncode mimeEnc a = mimeEnc a <> BSL.singleton (fromIntegral (Char.ord '\n'))
 112
 113 instance FramingEncode NetstringFraming (P.Producer a IO r) where
 114         framingEncode _framing mimeEnc p =
 115                 right (first (encodeNetstring mimeEnc))
 116                  <$> P.next p
 117 instance FramingEncode NetstringFraming (P.Producer a (Ps.SafeT IO) r) where
 118         framingEncode _framing mimeEnc p =
 119                 right (first (encodeNetstring mimeEnc))
 120                  <$> Ps.runSafeT (P.next p)
 121 instance IsString r => FramingDecode NetstringFraming (P.Producer a m r) where
 122         framingDecode _framing mimeDec mbs =
 123                 Pg.concats $
 124                 parseMany
 125                  (Pp.execStateT $ decodeNetstring @r mimeDec)
 126                  (produceBS mbs)
 127
 128 digit0, digit9 :: Word8
 129 colon, comma :: Word8
 130 newline :: Word8
 131 digit0  = fromIntegral (Char.ord '0')
 132 digit9  = fromIntegral (Char.ord '9')
 133 colon   = fromIntegral (Char.ord ':')
 134 comma   = fromIntegral (Char.ord ',')
 135 newline = fromIntegral (Char.ord '\n')
 136
 137 encodeNetstring :: (a -> BSL.ByteString) -> a -> BSL.ByteString
 138 encodeNetstring mimeEnc a =
 139         let bs = mimeEnc a in
 140         BSL8.pack (show (BSL8.length bs))
 141          <> ":" <> bs <> ","
 142
 143 decodeNetstring ::
 144  IsString r =>
 145  Monad m =>
 146  (BSL.ByteString -> Either String a) ->
 147  ParserP BS.ByteString a m r
 148 decodeNetstring mimeDec = do
 149         lenBSs <- Lens.zoom (Pbs.span (\b -> digit0 <= b && b <= digit9)) drawAllP
 150         case lenBSs >>= BS.unpack of
 151          [] -> return "empty length"
 152          w0:_:_ | w0 == digit0 -> return "leading zero"
 153          lenWs -> do
 154                 let len = List.foldl' (\acc d -> acc * 10 + (fromIntegral d - digit0)) 0 lenWs
 155                 colonW <- drawByteP
 156                 if colonW /= Just colon
 157                 then return "colon expected"
 158                 else do
 159                         -- TODO: make mimeDecode directly able to use Pipes?
 160                         dataBS <- BSL.fromChunks <$> Lens.zoom (Pbs.splitAt len) drawAllP
 161                         commaW <- drawByteP
 162                         if commaW /= Just comma
 163                         then return "comma expected"
 164                         else do
 165                                 case mimeDec dataBS of
 166                                  Left err -> return $ fromString err
 167                                  Right a -> do
 168                                         yieldP a
 169                                         decodeNetstring mimeDec
 170
 171 -- * Type 'P.Parser'
 172
 173 -- | A 'P.Parser', which is itself a 'P.Producer',
 174 -- and thus can 'yieldP' immediately.
 175 type ParserP inp out m r =
 176  forall x. Pp.StateT (P.Producer inp m x) (P.Producer out m) r
 177
 178 yieldP :: Monad m => out -> ParserP inp out m ()
 179 yieldP = lift . P.yield
 180
 181 drawP :: Monad m => ParserP inp out m (Maybe inp)
 182 drawP = P.hoist lift Pp.draw
 183
 184 drawAllP :: Monad m => ParserP inp out m [inp]
 185 drawAllP = P.hoist lift Pp.drawAll
 186
 187 drawByteP :: Monad m => ParserP BS.ByteString out m (Maybe Word8)
 188 drawByteP = P.hoist lift Pbs.drawByte
 189
 190 unDrawP :: Monad m => inp -> ParserP inp out m ()
 191 unDrawP = P.hoist lift . Pp.unDraw
 192
 193 -- | @'parseMany' f@ groups a 'P.Producer' of 'BS.ByteString's
 194 -- into a series of 'P.Producer's delimited by 'f',
 195 -- where the delimiter is dropped.
 196 parseMany ::
 197  Monad m =>
 198  (P.Producer a m r -> P.Producer b m (P.Producer a m r)) ->
 199  P.Producer a m r ->
 200  Pg.FreeT (P.Producer b m) m r
 201 parseMany f = Pg.FreeT . go0
 202         where
 203         go0 p = do
 204                 P.next p >>= \case
 205                  Left r -> return (Pg.Pure r)
 206                  Right (bs, p') -> return $ Pg.Free (go1 (P.yield bs >> p'))
 207         go1 p = Pg.FreeT . go0 <$> f p
 208
 209 {-
 210 -- * Type |Lens'|
 211 -- | Package agnostic lens.
 212 type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
 213 (^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
 214 a ^. lens = getConstant (lens Constant a)
 215 -}