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 -- TODO: write something like Pbs._lines to form a Lens'
 144 decodeNetstring ::
 145  IsString r =>
 146  Monad m =>
 147  (BSL.ByteString -> Either String a) ->
 148  ParserP BS.ByteString a m r
 149 decodeNetstring mimeDec = do
 150         lenBSs <- Lens.zoom (Pbs.span (\b -> digit0 <= b && b <= digit9)) drawAllP
 151         case lenBSs >>= BS.unpack of
 152          [] -> return "empty length"
 153          w0:_:_ | w0 == digit0 -> return "leading zero"
 154          lenWs -> do
 155                 let len = List.foldl' (\acc d -> acc * 10 + (fromIntegral d - digit0)) 0 lenWs
 156                 colonW <- drawByteP
 157                 if colonW /= Just colon
 158                 then return "colon expected"
 159                 else do
 160                         -- TODO: make mimeDecode directly able to use Pipes?
 161                         dataBS <- BSL.fromChunks <$> Lens.zoom (Pbs.splitAt len) drawAllP
 162                         commaW <- drawByteP
 163                         if commaW /= Just comma
 164                         then return "comma expected"
 165                         else do
 166                                 case mimeDec dataBS of
 167                                  Left err -> return $ fromString err
 168                                  Right a -> do
 169                                         yieldP a
 170                                         decodeNetstring mimeDec
 171
 172 -- * Type 'P.Parser'
 173
 174 -- | A 'P.Parser', which is itself a 'P.Producer',
 175 -- and thus can 'yieldP' immediately.
 176 type ParserP inp out m r =
 177  forall x. Pp.StateT (P.Producer inp m x) (P.Producer out m) r
 178
 179 yieldP :: Monad m => out -> ParserP inp out m ()
 180 yieldP = lift . P.yield
 181
 182 drawP :: Monad m => ParserP inp out m (Maybe inp)
 183 drawP = P.hoist lift Pp.draw
 184
 185 drawAllP :: Monad m => ParserP inp out m [inp]
 186 drawAllP = P.hoist lift Pp.drawAll
 187
 188 drawByteP :: Monad m => ParserP BS.ByteString out m (Maybe Word8)
 189 drawByteP = P.hoist lift Pbs.drawByte
 190
 191 unDrawP :: Monad m => inp -> ParserP inp out m ()
 192 unDrawP = P.hoist lift . Pp.unDraw
 193
 194 -- | @'parseMany' f@ groups a 'P.Producer' of @(inp)@
 195 -- into a series of 'P.Producer's of @(a)@ delimited by 'f'
 196 -- (which must drop the delimiter).
 197 parseMany ::
 198  forall m inp r a.
 199  Monad m =>
 200  (P.Producer inp m r -> P.Producer a m (P.Producer inp m r)) ->
 201  P.Producer inp m r ->
 202  Pg.FreeT (P.Producer a m) m r
 203 parseMany f = go0
 204         where
 205         go0 ::
 206          P.Producer inp m r ->
 207          Pg.FreeT (P.Producer a m) m r
 208         go0 p = Pg.FreeT $ do
 209                 P.next p >>= \case
 210                  Left r -> return $ Pg.Pure r
 211                  Right (inp, p') -> return $ Pg.Free $ go1 $ P.yield inp >> p'
 212
 213         go1 ::
 214          P.Producer inp m r ->
 215          P.Producer a m (Pg.FreeT (P.Producer a m) m r)
 216         go1 p = go0 <$> f p
 217
 218 {-
 219 -- * Type |Lens'|
 220 -- | Package agnostic lens.
 221 type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
 222 (^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
 223 a ^. lens = getConstant (lens Constant a)
 224 -}