0 | module TyTTP.HTTP.Consumer
  1 |
  2 | import Control.Monad.Trans
  3 | import Control.Monad.Either
  4 | import Data.Buffer
  5 | import Data.List
  6 | import public Data.List.Quantifiers
  7 | import Data.Maybe
  8 | import Data.SnocList
  9 | import Data.IORef
 10 | import TyTTP
 11 | import TyTTP.HTTP.Protocol
 12 |
 13 | public export
 14 | interface Accept t where
 15 |   contentType : (ty : Type) -> { auto p : ty = t } -> List String
 16 |
 17 | public export
 18 | data IsAccept : (t : Type) -> Type where
 19 |   ItIsAccept : Accept t => IsAccept t
 20 |
 21 | public export
 22 | ConsumerError : Type
 23 | ConsumerError = String
 24 |
 25 | public export
 26 | interface Accept t => Consumer a t where
 27 |   consumeRaw : (ty : Type) -> { auto p : ty = t } -> (ct : String) -> (raw : Buffer) -> Either ConsumerError a
 28 |
 29 | public export
 30 | data IsConsumer : (a : Type) -> (t : Type) -> Type where
 31 |   ItIsConsumer : Consumer a t => IsConsumer a t
 32 |
 33 | ||| This function consumes the stream from the underlying server, thus the original stream cannot be used twice.
 34 | ||| If you make sure that the original stream is not used twice, then this function can be used.
 35 | export
 36 | unsafeConsumeBody : Error e
 37 |   => HasIO m
 38 |   => MonadPromise e m p
 39 |   => (
 40 |     Context me u v h1 s h2 Buffer b
 41 |     -> (forall p'. MonadPromise e m p' => p' $ Context me' u' v' h1' s' h2' a' b')
 42 |   )
 43 |   -> Context me u v h1 s h2 (Publisher m e Buffer) b
 44 |   -> p $ Context me' u' v' h1' s' h2' a' b'
 45 | unsafeConsumeBody handler ctx = promise $ \resolve', reject' => do
 46 |   acc <- newIORef Lin
 47 |   let subscriber : Subscriber m e Buffer = MkSubscriber
 48 |         { onNext = \a => modifyIORef acc (:< a)
 49 |         , onSucceded = \_ => do
 50 |             all <- concatBuffers =<< asList <$> readIORef acc
 51 |             Just emptyBuffer <- newBuffer 0 | _ => assert_total $ idris_crash "creating an empty buffer has failed"
 52 |             let result = handler $ { request.body := fromMaybe emptyBuffer all } ctx
 53 |             runPromise { m = m } resolve' reject' result
 54 |         , onFailed = reject'
 55 |         }
 56 |   ctx.request.body.subscribe subscriber
 57 |
 58 | consumePayload :
 59 |   (t : Type)
 60 |   -> (isConsumer : IsConsumer a t)
 61 |   -> (ct : String)
 62 |   -> (raw : Buffer)
 63 |   -> Either ConsumerError a
 64 | consumePayload t ItIsConsumer ct raw =
 65 |   consumeRaw t ct raw
 66 |
 67 | safeConsume :
 68 |   Error e
 69 |   => MonadTrans t
 70 |   => MonadPromise e IO m
 71 |   => Alternative (t m)
 72 |   => HasContentType h1
 73 |   => (list: List Type)
 74 |   -> (areAccepts : All IsAccept list)
 75 |   -> (areConsumers : All (IsConsumer a) list)
 76 |   -> (ct : String)
 77 |   -> (
 78 |     Context me u v h1 s h2 (Either ConsumerError a) b
 79 |     -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' a' b')
 80 |   )
 81 |   -> Context me u v h1 s h2 (Publisher IO e Buffer) b
 82 |   -> t m $ Context me' u' v' h1' s' h2' (Publisher IO e Buffer) b'
 83 | safeConsume [] _ _ _ _ _ = empty
 84 | safeConsume (t::ts) (ItIsAccept::as) (c::cs) ct handler ctx =
 85 |   if elem ct (contentType t)
 86 |   then lift $ flip unsafeConsumeBody ctx $ \ctx' => promise $ \resolve' ,reject' => do
 87 |           let raw = ctx'.request.body
 88 |               result = handler $ { request.body := consumePayload t c ct raw } ctx'
 89 |               success = \r => resolve' $ { request.body := singleton raw } r
 90 |           runPromise { m = IO } success reject' result
 91 |   else safeConsume ts as cs ct handler ctx
 92 |
 93 | export
 94 | consumes :
 95 |   Error e
 96 |   => MonadTrans t
 97 |   => MonadPromise e IO m
 98 |   => Alternative (t m)
 99 |   => HasContentType h1
100 |   => (list: List Type)
101 |   -> {auto isNonEmpty : NonEmpty list}
102 |   -> {auto areAccepts : All IsAccept list}
103 |   -> {auto areConsumers : All (IsConsumer a) list}
104 |   -> (
105 |     Context me u v h1 s h2 (Either ConsumerError a) b
106 |     -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' a' b')
107 |   )
108 |   -> Context me u v h1 s h2 (Publisher IO e Buffer) b
109 |   -> t m $ Context me' u' v' h1' s' h2' (Publisher IO e Buffer) b'
110 | consumes list {isNonEmpty} {areAccepts} {areConsumers} handler ctx = do
111 |   let Just ct = getContentType ctx.request.headers
112 |     | _ => empty
113 |
114 |   safeConsume list areAccepts areConsumers ct handler ctx
115 |
116 | export
117 | consumes' :
118 |   Error e
119 |   => MonadTrans t
120 |   => MonadPromise e IO m
121 |   => Alternative (t m)
122 |   => HasContentType h1
123 |   => (list: List Type)
124 |   -> {auto isNonEmpty : NonEmpty list}
125 |   -> {auto areAccepts : All IsAccept list}
126 |   -> {auto areConsumers : All (IsConsumer a) list}
127 |   -> (
128 |     Context me u v h1 s h2 ConsumerError b
129 |     -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' a' b')
130 |   )
131 |   -> (
132 |     Context me u v h1 s h2 a b
133 |     -> (forall m''. MonadPromise e IO m'' => m'' $ Context me' u' v' h1' s' h2' a'' b')
134 |   )
135 |   -> Context me u v h1 s h2 (Publisher IO e Buffer) b
136 |   -> t m $ Context me' u' v' h1' s' h2' (Publisher IO e Buffer) b'
137 | consumes' list {isNonEmpty} {areAccepts} {areConsumers} errHandler handler ctx =
138 |   let handler' : 
139 |         Context me u v h1 s h2 (Either ConsumerError a) b
140 |         -> (forall m'. MonadPromise e IO m' => m' $ Context me' u' v' h1' s' h2' () b')
141 |       handler' s =
142 |         case s.request.body of
143 |           Right r => do
144 |             result <- handler $ { request.body := r } s
145 |             pure $ { request.body := () } result
146 |           Left  l => do
147 |             result <- errHandler $ { request.body := l } s
148 |             pure $ { request.body := () } result
149 |   in consumes list handler' ctx
150 |