packages feed

strelka 0.4 → 0.4.0.1

raw patch · 4 files changed

+194/−50 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

library/Strelka/RequestBodyConsumer.hs view
@@ -1,4 +1,5 @@-module Strelka.RequestBodyConsumer where+module Strelka.RequestBodyConsumer+where  import Strelka.Prelude import Strelka.Model@@ -16,13 +17,17 @@ import qualified Data.Text.Lazy.Builder  +{-|+A specification of how to consume the request body.+-} newtype RequestBodyConsumer a =   RequestBodyConsumer (IO ByteString -> IO a)   deriving (Functor) --- |--- Fold with support for early termination,--- which is interpreted from Left.+{-|+Fold with support for early termination,+which is interpreted from Left.+-} foldBytesTerminating :: (a -> ByteString -> Either a a) -> a -> RequestBodyConsumer a foldBytesTerminating step init =   RequestBodyConsumer consumer@@ -40,9 +45,10 @@                   Left newState -> return newState                   Right newState -> recur newState --- |--- Fold with support for early termination,--- which is interpreted from Left.+{-|+Fold with support for early termination,+which is interpreted from Left.+-} foldTextTerminating :: (a -> Text -> Either a a) -> a -> RequestBodyConsumer a foldTextTerminating step init =   fmap snd (foldBytesTerminating bytesStep bytesInit)@@ -59,6 +65,9 @@             then Right (nextDecode, state)             else bimap ((,) nextDecode) ((,) nextDecode) (step state textChunk) +{-|+Fold over ByteString chunks.+-} foldBytes :: (a -> ByteString -> a) -> a -> RequestBodyConsumer a foldBytes step init =   RequestBodyConsumer consumer@@ -74,8 +83,9 @@                 then return state                 else recur (step state chunk) --- |--- A UTF8 text chunks decoding consumer.+{-|+Fold over text chunks decoded using UTF8.+-} foldText :: (a -> Text -> a) -> a -> RequestBodyConsumer a foldText step init =   fmap fst (foldBytes bytesStep bytesInit)@@ -99,26 +109,44 @@ build proj =   foldBytes (\l r -> mappend l (proj r)) mempty +{-|+Consume as ByteString.+-} bytes :: RequestBodyConsumer ByteString bytes =   fmap Data.ByteString.Lazy.toStrict lazyBytes +{-|+Consume as lazy ByteString.+-} lazyBytes :: RequestBodyConsumer Data.ByteString.Lazy.ByteString lazyBytes =   fmap Data.ByteString.Builder.toLazyByteString bytesBuilder +{-|+Consume as ByteString Builder.+-} bytesBuilder :: RequestBodyConsumer Data.ByteString.Builder.Builder bytesBuilder =   build Data.ByteString.Builder.byteString +{-|+Consume as Text.+-} text :: RequestBodyConsumer Text text =   fmap Data.Text.Lazy.toStrict lazyText +{-|+Consume as lazy Text.+-} lazyText :: RequestBodyConsumer Data.Text.Lazy.Text lazyText =   fmap Data.Text.Lazy.Builder.toLazyText textBuilder +{-|+Consume as Text Builder.+-} textBuilder :: RequestBodyConsumer Data.Text.Lazy.Builder.Builder textBuilder =   fmap fst (foldBytes step init)@@ -130,16 +158,27 @@     init =       (mempty, Data.Text.Encoding.streamDecodeUtf8) --- |--- Turn a bytes parser into an input stream consumer.+{-|+Lift an Attoparsec ByteString parser.++Consumption is non-greedy and terminates when the parser is done.+-} bytesParser :: Data.Attoparsec.ByteString.Parser a -> RequestBodyConsumer (Either Text a) bytesParser parser =   parserResult foldBytesTerminating (Data.Attoparsec.ByteString.Partial (Data.Attoparsec.ByteString.parse parser)) +{-|+Lift an Attoparsec Text parser.++Consumption is non-greedy and terminates when the parser is done.+-} textParser :: Data.Attoparsec.Text.Parser a -> RequestBodyConsumer (Either Text a) textParser parser =   parserResult foldTextTerminating (Data.Attoparsec.Text.Partial (Data.Attoparsec.Text.parse parser)) +{-|+Given a chunk-specialized terminating fold implementation lifts a generic Attoparsec result.+-} parserResult :: Monoid i => (forall a. (a -> i -> Either a a) -> a -> RequestBodyConsumer a) -> Data.Attoparsec.Types.IResult i a -> RequestBodyConsumer (Either Text a) parserResult fold result =   fmap finalise (fold step result)
library/Strelka/RequestParser.hs view
@@ -15,6 +15,10 @@ import qualified Strelka.HTTPAuthorizationParser as D  +{-|+Parser of an HTTP request.+Consumes path segments, analyzes +-} newtype RequestParser m a =   RequestParser (ReaderT Request (StateT [Text] (ExceptT Text m)) a)   deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadError Text)@@ -31,10 +35,16 @@   lift m =     RequestParser (lift (lift (lift m))) +{-|+Execute the parser providing a request and a list of segments.+-} run :: RequestParser m a -> Request -> [Text] -> m (Either Text (a, [Text])) run (RequestParser impl) request segments =   runExceptT (runStateT (runReaderT impl request) segments) +{-|+Fail with a text message.+-} fail :: Monad m => Text -> RequestParser m a fail message =   RequestParser $@@ -45,6 +55,9 @@   Left $   message +{-|+Lift Either, interpreting Left as a failure.+-} liftEither :: Monad m => Either Text a -> RequestParser m a liftEither =   RequestParser .@@ -53,15 +66,17 @@   ExceptT .   return --- |--- +{-|+Lift Maybe, interpreting Nothing as a failure.+-} liftMaybe :: Monad m => Maybe a -> RequestParser m a liftMaybe =   liftEither .   maybe (Left "Unexpected Nothing") Right --- |--- Extract the error from RequestParser.+{-|+Try a parser, extracting the error as Either.+-} unliftEither :: Monad m => RequestParser m a -> RequestParser m (Either Text a) unliftEither =   tryError@@ -70,8 +85,9 @@ -- * Path segments ------------------------- --- |--- Consume the next segment of the path.+{-|+Consume the next segment of the path.+-} consumeSegment :: Monad m => RequestParser m Text consumeSegment =   RequestParser $@@ -83,16 +99,25 @@     _ ->       ExceptT (return (Left "No segments left")) +{-|+Consume the next segment of the path with Attoparsec parser.+-} consumeSegmentWithParser :: Monad m => Q.Parser a -> RequestParser m a consumeSegmentWithParser parser =   consumeSegment >>= liftEither . first E.pack . Q.parseOnly parser +{-|+Consume the next segment if it matches the provided value and fail otherwise.+-} consumeSegmentIfIs :: Monad m => Text -> RequestParser m () consumeSegmentIfIs expectedSegment =   do     segment <- consumeSegment     guard (segment == expectedSegment) +{-|+Fail if there's any path segments left unconsumed.+-} ensureThatNoSegmentsIsLeft :: Monad m => RequestParser m () ensureThatNoSegmentsIsLeft =   RequestParser (lift (gets null)) >>= guard@@ -101,50 +126,62 @@ -- * Methods ------------------------- +{-|+Get the request method.+-} getMethod :: Monad m => RequestParser m ByteString getMethod =   do     Request (Method method) _ _ _ _ <- RequestParser ask     return method +{-|+Ensure that the method matches the provided value in lower-case.+-} ensureThatMethodIs :: Monad m => ByteString -> RequestParser m () ensureThatMethodIs expectedMethod =   do     method <- getMethod     guard (expectedMethod == method) --- |--- Same as @ensureThatMethodIs "get"@.+{-|+Same as @'ensureThatMethodIs' "get"@.+-} ensureThatMethodIsGet :: Monad m => RequestParser m () ensureThatMethodIsGet =   ensureThatMethodIs "get" --- |--- Same as @ensureThatMethodIs "post"@.+{-|+Same as @'ensureThatMethodIs' "post"@.+-} ensureThatMethodIsPost :: Monad m => RequestParser m () ensureThatMethodIsPost =   ensureThatMethodIs "post" --- |--- Same as @ensureThatMethodIs "put"@.+{-|+Same as @'ensureThatMethodIs' "put"@.+-} ensureThatMethodIsPut :: Monad m => RequestParser m () ensureThatMethodIsPut =   ensureThatMethodIs "put" --- |--- Same as @ensureThatMethodIs "delete"@.+{-|+Same as @'ensureThatMethodIs' "delete"@.+-} ensureThatMethodIsDelete :: Monad m => RequestParser m () ensureThatMethodIsDelete =   ensureThatMethodIs "delete" --- |--- Same as @ensureThatMethodIs "head"@.+{-|+Same as @'ensureThatMethodIs' "head"@.+-} ensureThatMethodIsHead :: Monad m => RequestParser m () ensureThatMethodIsHead =   ensureThatMethodIs "head" --- |--- Same as @ensureThatMethodIs "trace"@.+{-|+Same as @'ensureThatMethodIs' "trace"@.+-} ensureThatMethodIsTrace :: Monad m => RequestParser m () ensureThatMethodIsTrace =   ensureThatMethodIs "trace"@@ -153,51 +190,58 @@ -- * Headers ------------------------- --- |--- Lookup a header by name in lower-case.+{-|+Lookup a header by name in lower-case.+-} getHeader :: Monad m => ByteString -> RequestParser m ByteString getHeader name =   do     Request _ _ _ headers _ <- RequestParser ask     liftMaybe (liftM (\(HeaderValue value) -> value) (G.lookup (HeaderName name) headers)) --- |--- Ensure that the request provides an Accept header,--- which includes the specified content type.--- Content type must be in lower-case.+{-|+Ensure that the request provides an Accept header,+which includes the specified content type.+Content type must be in lower-case.+-} ensureThatAccepts :: Monad m => ByteString -> RequestParser m () ensureThatAccepts contentType =   checkIfAccepts contentType >>=   liftEither . bool (Left ("Unacceptable content-type: " <> fromString (show contentType))) (Right ()) --- |--- Same as @ensureThatAccepts "text/plain"@.+{-|+Same as @'ensureThatAccepts' "text/plain"@.+-} ensureThatAcceptsText :: Monad m => RequestParser m () ensureThatAcceptsText =   ensureThatAccepts "text/plain" --- |--- Same as @ensureThatAccepts "text/html"@.+{-|+Same as @'ensureThatAccepts' "text/html"@.+-} ensureThatAcceptsHTML :: Monad m => RequestParser m () ensureThatAcceptsHTML =   ensureThatAccepts "text/html" --- |--- Same as @ensureThatAccepts "application/json"@.+{-|+Same as @'ensureThatAccepts' "application/json"@.+-} ensureThatAcceptsJSON :: Monad m => RequestParser m () ensureThatAcceptsJSON =   ensureThatAccepts "application/json" --- |--- Check whether the request provides an Accept header,--- which includes the specified content type.--- Content type must be in lower-case.+{-|+Check whether the request provides an Accept header,+which includes the specified content type.+Content type must be in lower-case.+-} checkIfAccepts :: Monad m => ByteString -> RequestParser m Bool checkIfAccepts contentType =   liftM (isJust . K.matchAccept [contentType]) (getHeader "accept") --- |--- Parse the username and password from the basic authorization header.+{-|+Parse the username and password from the basic authorization header.+-} getAuthorization :: Monad m => RequestParser m (Text, Text) getAuthorization =   getHeader "authorization" >>= liftEither . D.basicCredentials@@ -206,7 +250,7 @@ -- * Params ------------------------- -{- |+{-| Get a parameter\'s value by its name, failing if the parameter is not present.   @Maybe@ encodes whether the value was specified, i.e. @?name=value@ vs @?name@.@@ -221,48 +265,85 @@ -- * Body ------------------------- +{-|+Consume the request body using the provided RequestBodyConsumer.++[NOTICE]+Since the body is consumed as a stream,+you can only consume it once regardless of the Alternative branching.+-} consumeBody :: MonadIO m => P.RequestBodyConsumer a -> RequestParser m a consumeBody (P.RequestBodyConsumer consume) =   do     Request _ _ _ _ (InputStream getChunk) <- RequestParser ask     liftIO (consume getChunk) +{-|+Same as @'consumeBody' 'P.foldBytes'@.+-} consumeBodyFolding :: MonadIO m => (a -> ByteString -> a) -> a -> RequestParser m a consumeBodyFolding step init =   consumeBody (P.foldBytes step init) +{-|+Same as @'consumeBody' 'P.build'@.+-} consumeBodyBuilding :: (MonadIO m, Monoid a) => (ByteString -> a) -> RequestParser m a consumeBodyBuilding proj =   consumeBody (P.build proj) +{-|+Same as @'consumeBody' 'P.bytes'@.+-} consumeBodyAsBytes :: MonadIO m => RequestParser m ByteString consumeBodyAsBytes =   consumeBody P.bytes +{-|+Same as @'consumeBody' 'P.lazyBytes'@.+-} consumeBodyAsLazyBytes :: MonadIO m => RequestParser m B.ByteString consumeBodyAsLazyBytes =   consumeBody P.lazyBytes +{-|+Same as @'consumeBody' 'P.bytesBuilder'@.+-} consumeBodyAsBytesBuilder :: MonadIO m => RequestParser m C.Builder consumeBodyAsBytesBuilder =   consumeBody P.bytesBuilder +{-|+Same as @'consumeBody' 'P.text'@.+-} consumeBodyAsText :: MonadIO m => RequestParser m Text consumeBodyAsText =   consumeBody P.text +{-|+Same as @'consumeBody' 'P.lazyText'@.+-} consumeBodyAsLazyText :: MonadIO m => RequestParser m L.Text consumeBodyAsLazyText =   consumeBody P.lazyText +{-|+Same as @'consumeBody' 'P.textBuilder'@.+-} consumeBodyAsTextBuilder :: MonadIO m => RequestParser m M.Builder consumeBodyAsTextBuilder =   consumeBody P.textBuilder +{-|+Same as @'consumeBody' 'P.bytesParser'@.+-} consumeBodyWithBytesParser :: MonadIO m => F.Parser a -> RequestParser m a consumeBodyWithBytesParser parser =   consumeBody (P.bytesParser parser) >>= liftEither +{-|+Same as @'consumeBody' 'P.textParser'@.+-} consumeBodyWithTextParser :: MonadIO m => Q.Parser a -> RequestParser m a consumeBodyWithTextParser parser =   consumeBody (P.textParser parser) >>= liftEither
library/Strelka/ResponseBodyBuilder.hs view
@@ -10,6 +10,9 @@ import qualified Data.Text.Lazy.Builder as J  +{-|+A builder of the response body.+-} newtype ResponseBodyBuilder =   ResponseBodyBuilder ((ByteString -> IO ()) -> IO () -> IO ()) @@ -26,22 +29,37 @@ instance Semigroup ResponseBodyBuilder  +{-|+Lift ByteString.+-} bytes :: ByteString -> ResponseBodyBuilder bytes x =   ResponseBodyBuilder (\feed flush -> feed x *> flush) +{-|+Lift lazy ByteString.+-} lazyBytes :: D.ByteString -> ResponseBodyBuilder lazyBytes x =   ResponseBodyBuilder (\feed flush -> D.foldlChunks (\io chunk -> io >> feed chunk) (pure ()) x >> flush) +{-|+Lift ByteString Builder.+-} bytesBuilder :: E.Builder -> ResponseBodyBuilder bytesBuilder =   lazyBytes . E.toLazyByteString +{-|+Lift Text.+-} text :: Text -> ResponseBodyBuilder text text =   bytes (H.encodeUtf8 text) +{-|+Lift lazy Text.+-} lazyText :: F.Text -> ResponseBodyBuilder lazyText text =   ResponseBodyBuilder impl@@ -55,6 +73,9 @@             bytesChunk =               H.encodeUtf8 textChunk +{-|+Lift ByteString Builder.+-} textBuilder :: J.Builder -> ResponseBodyBuilder textBuilder =   lazyText . J.toLazyText
strelka.cabal view
@@ -1,9 +1,9 @@ name:   strelka version:-  0.4+  0.4.0.1 synopsis:-  Extremely flexible and composable router+  A flexible and composable HTTP-router description:   An HTTP server can be defined as a request parser, which produces a response.   As simple as that.@@ -13,6 +13,9 @@   [Warning]   This library is currently in active development.   The API can change rapidly.+  .+  [Demo]+  <https://github.com/nikita-volkov/strelka-demo>. homepage:   https://github.com/nikita-volkov/strelka bug-reports: