packages feed

strelka 1 → 2

raw patch · 19 files changed

+1452/−854 lines, 19 filesdep +attoparsec-datadep +bytestring-tree-builderdep +scientificdep ~strelka-core

Dependencies added: attoparsec-data, bytestring-tree-builder, scientific, text-builder, time, url-decoders

Dependency ranges changed: strelka-core

Files

− library/Strelka/HTTPAuthorizationParser.hs 
@@ -1,38 +0,0 @@-module Strelka.HTTPAuthorizationParser -where--import Strelka.Prelude-import qualified Data.ByteString.Base64 as A-import qualified Data.Text as B-import qualified Data.Text.Encoding as B-import qualified Data.ByteString as C---basicCredentials :: ByteString -> Either Text (Text, Text)-basicCredentials =-  dropPrefix >=> decodeBase64 >=> decodeText >=> splitText-  where-    dropPrefix =-      maybe (Left "Not a basic authorization") Right .-      C.stripPrefix "Basic "-    decodeBase64 =-      first adaptFailure .-      A.decode-      where-        adaptFailure string =-          "Base64 decoding failure: " <> fromString string-    decodeText =-      first adaptFailure .-      B.decodeUtf8'-      where-        adaptFailure failure =-          "UTF8 decoding failure. " <>-          (B.pack . show) failure-    splitText input =-      case B.span (/= ':') input of-        (prefix, remainder) ->-          if B.null prefix-            then Left ("Couldn't split the decoded text: " <> remainder)-            else if B.null remainder-              then Left ("Couldn't split the decoded text: " <> prefix)-              else Right (prefix, B.tail remainder)
+ library/Strelka/HTTPAuthorizationParsing.hs view
@@ -0,0 +1,38 @@+module Strelka.HTTPAuthorizationParsing +where++import Strelka.Prelude+import qualified Data.ByteString.Base64 as A+import qualified Data.Text as B+import qualified Data.Text.Encoding as B+import qualified Data.ByteString as C+++basicCredentials :: ByteString -> Either Text (Text, Text)+basicCredentials =+  dropPrefix >=> decodeBase64 >=> decodeText >=> splitText+  where+    dropPrefix =+      maybe (Left "Not a basic authorization") Right .+      C.stripPrefix "Basic "+    decodeBase64 =+      first adaptFailure .+      A.decode+      where+        adaptFailure string =+          "Base64 decoding failure: " <> fromString string+    decodeText =+      first adaptFailure .+      B.decodeUtf8'+      where+        adaptFailure failure =+          "UTF8 decoding failure. " <>+          (B.pack . show) failure+    splitText input =+      case B.span (/= ':') input of+        (prefix, remainder) ->+          if B.null prefix+            then Left ("Couldn't split the decoded text: " <> remainder)+            else if B.null remainder+              then Left ("Couldn't split the decoded text: " <> prefix)+              else Right (prefix, B.tail remainder)
+ library/Strelka/ParamsParsing.hs view
@@ -0,0 +1,30 @@+{-|+DSL for parsing of parameters.+-}+module Strelka.ParamsParsing+(+  A.Params,+  A.param,+  A.defaultParam,+  -- * Multi-arity default param parser helpers+  A.defaultParams1,+  A.defaultParams2,+  A.defaultParams3,+  A.defaultParams4,+  A.defaultParams5,+  A.defaultParams6,+  A.defaultParams7,+  -- * Value parsers+  B.Value,+  B.parser,+  B.matcher,+  B.list,+  B.maybe,+  -- * Implicit default value parsers+  C.DefaultValue(..),+)+where++import qualified Strelka.ParamsParsing.Params as A+import qualified Strelka.ParamsParsing.Value as B+import qualified Strelka.ParamsParsing.DefaultValue as C
+ library/Strelka/ParamsParsing/DefaultValue.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP #-}+module Strelka.ParamsParsing.DefaultValue+where++import Strelka.Prelude+import qualified Attoparsec.Data.Implicit as B+import qualified Strelka.ParamsParsing.Value as D+++{-|+Provides a default value parser.+-}+class DefaultValue value where+  defaultValue :: D.Value value++{-|+Uses 'D.maybe' over 'defaultValue'.+-}+instance DefaultValue a => DefaultValue (Maybe a) where+  {-# INLINE defaultValue #-}+  defaultValue =+    D.maybe defaultValue++{-|+Uses 'D.list' over 'defaultValue'.+-}+instance DefaultValue a => DefaultValue [a] where+  {-# INLINE defaultValue #-}+  defaultValue =+    D.list defaultValue+++-- * Generated DefaultValue instances+-------------------------++#define INSTANCE1(TYPE, FUNCTION) instance DefaultValue TYPE where {{-# INLINE defaultValue #-}; defaultValue = FUNCTION;}+#define INSTANCE2(TYPE) INSTANCE1(TYPE, D.parser B.lenientParser)++INSTANCE1(Text, D.matcher Right)+INSTANCE1(String, D.string)+-- | Encodes the input using UTF8.+INSTANCE2(ByteString)+INSTANCE2(Char)+{-|+Interprets all the following inputs case-insensitively:+\"1\" or \"0\", \"true\" or \"false\", \"yes\" or \"no\", \"y\" or \"n\", \"t\" or \"f\".+The absense of a value is interpreted as 'False'.+-}+INSTANCE1(Bool, D.bool)+INSTANCE2(Integer)+INSTANCE2(Int)+INSTANCE2(Int8)+INSTANCE2(Int16)+INSTANCE2(Int32)+INSTANCE2(Int64)+INSTANCE2(Word)+INSTANCE2(Word8)+INSTANCE2(Word16)+INSTANCE2(Word32)+INSTANCE2(Word64)+INSTANCE2(Double)+INSTANCE2(Scientific)+INSTANCE2(TimeOfDay)+INSTANCE2(Day)+INSTANCE2(TimeZone)+INSTANCE2(UTCTime)++#undef INSTANCE1+#undef INSTANCE2+
+ library/Strelka/ParamsParsing/Params.hs view
@@ -0,0 +1,118 @@+module Strelka.ParamsParsing.Params+where++import Strelka.Prelude+import qualified Strelka.ParamsParsing.DefaultValue as A+import qualified Strelka.ParamsParsing.Value as C+++{-|+Parser of a product of parameters.++Can be composed using the Applicative interface.+-}+newtype Params a =+  Params (ReaderT (Text -> Maybe [Text]) (Except Text) a)+  deriving (Functor, Applicative, Alternative)++run :: Params a -> (Text -> Maybe [Text]) -> Either Text a+run (Params reader) lookup =+  runExcept (runReaderT reader lookup)++-- | Parse a param by its name using an explicit parser.+{-# INLINABLE param #-}+param :: Text -> C.Value a -> Params a+param name value =+  Params (ReaderT onLookup)+  where+    onLookup lookup =+      maybe notFound found (lookup name)+      where+        notFound =+          (except . Left) ("Parameter \"" <> name <> "\" not found")+        found input =+          case value of+            C.Value (ReaderT onInput) -> withExcept updateError (onInput input)+          where+            updateError x =+              "Parameter \"" <> name <> "\" values parsing failure: " <> x+++-- * Default Helpers+-------------------------++-- | Parse a param by its name using the implicit default parser.+{-# INLINE defaultParam #-}+defaultParam :: A.DefaultValue a => Text -> Params a+defaultParam name =+  param name A.defaultValue++-- | Same as 'defaultParam'.+{-# INLINE defaultParams1 #-}+defaultParams1 :: A.DefaultValue a => Text -> Params a+defaultParams1 =+  defaultParam++-- | A helper abstracting over the Applicative composition of multiple 'defaultParam'.+{-# INLINE defaultParams2 #-}+defaultParams2 :: (A.DefaultValue a, A.DefaultValue b) => Text -> Text -> Params (a, b)+defaultParams2 name1 name2 =+  (,) <$>+  defaultParam name1 <*>+  defaultParam name2++-- | A helper abstracting over the Applicative composition of multiple 'defaultParam'.+{-# INLINE defaultParams3 #-}+defaultParams3 :: (A.DefaultValue a, A.DefaultValue b, A.DefaultValue c) => Text -> Text -> Text -> Params (a, b, c)+defaultParams3 name1 name2 name3 =+  (,,) <$>+  defaultParam name1 <*>+  defaultParam name2 <*>+  defaultParam name3++-- | A helper abstracting over the Applicative composition of multiple 'defaultParam'.+{-# INLINE defaultParams4 #-}+defaultParams4 :: (A.DefaultValue a, A.DefaultValue b, A.DefaultValue c, A.DefaultValue d) => Text -> Text -> Text -> Text -> Params (a, b, c, d)+defaultParams4 name1 name2 name3 name4 =+  (,,,) <$>+  defaultParam name1 <*>+  defaultParam name2 <*>+  defaultParam name3 <*>+  defaultParam name4++-- | A helper abstracting over the Applicative composition of multiple 'defaultParam'.+{-# INLINE defaultParams5 #-}+defaultParams5 :: (A.DefaultValue a, A.DefaultValue b, A.DefaultValue c, A.DefaultValue d, A.DefaultValue e) => Text -> Text -> Text -> Text -> Text -> Params (a, b, c, d, e)+defaultParams5 name1 name2 name3 name4 name5 =+  (,,,,) <$>+  defaultParam name1 <*>+  defaultParam name2 <*>+  defaultParam name3 <*>+  defaultParam name4 <*>+  defaultParam name5++-- | A helper abstracting over the Applicative composition of multiple 'defaultParam'.+{-# INLINE defaultParams6 #-}+defaultParams6 :: (A.DefaultValue a, A.DefaultValue b, A.DefaultValue c, A.DefaultValue d, A.DefaultValue e, A.DefaultValue f) => Text -> Text -> Text -> Text -> Text -> Text -> Params (a, b, c, d, e, f)+defaultParams6 name1 name2 name3 name4 name5 name6 =+  (,,,,,) <$>+  defaultParam name1 <*>+  defaultParam name2 <*>+  defaultParam name3 <*>+  defaultParam name4 <*>+  defaultParam name5 <*>+  defaultParam name6++-- | A helper abstracting over the Applicative composition of multiple 'defaultParam'.+{-# INLINE defaultParams7 #-}+defaultParams7 :: (A.DefaultValue a, A.DefaultValue b, A.DefaultValue c, A.DefaultValue d, A.DefaultValue e, A.DefaultValue f, A.DefaultValue g) => Text -> Text -> Text -> Text -> Text -> Text -> Text -> Params (a, b, c, d, e, f, g)+defaultParams7 name1 name2 name3 name4 name5 name6 name7 =+  (,,,,,,) <$>+  defaultParam name1 <*>+  defaultParam name2 <*>+  defaultParam name3 <*>+  defaultParam name4 <*>+  defaultParam name5 <*>+  defaultParam name6 <*>+  defaultParam name7+
+ library/Strelka/ParamsParsing/Value.hs view
@@ -0,0 +1,85 @@+module Strelka.ParamsParsing.Value+where++import Strelka.Prelude hiding (maybe, list)+import qualified Data.Attoparsec.Text as G+import qualified Data.Text as E+import qualified Attoparsec.Data.Implicit as B+++{-|+A parser of a parameter value.+-}+newtype Value a =+  Value (ReaderT [Text] (Except Text) a)+  deriving (Functor, Applicative, Alternative)++{-|+Lifts an Attoparsec parser into Value.+-}+{-# INLINE parser #-}+parser :: G.Parser a -> Value a+parser parser =+  matcher (first fromString . G.parseOnly finishedParser)+  where+    finishedParser =+      parser <* (G.endOfInput <|> fail "Didn't parse the whole data")++{-|+Lifts a text-matching function into Value.+-}+{-# INLINE matcher #-}+matcher :: (Text -> Either Text a) -> Value a+matcher matcher =+  Value (ReaderT (except . join . liftM matcher . head))+  where+    head =+      \case+        x : _ -> Right x+        _ -> Left ("Not a single value is specified")++{-# INLINE text #-}+text :: Value Text+text =+  matcher Right++{-# INLINE string #-}+string :: Value String+string =+  matcher (Right . E.unpack)++{-|+Lifts a single value parser to the parser of a list of values.++Useful for decoding lists of values of the same name.+E.g., it'll work for the both following cases:++> ?param[]=1&param[]=2++> ?param=1&param=2++In both cases the name of the parameter to look up will be \"param\".+-}+{-# INLINE list #-}+list :: Value a -> Value [a]+list (Value (ReaderT singleValueFn)) =+  Value (ReaderT (traverse (singleValueFn . pure)))++{-|+Lifts a single value parser to the parser of a possibly specified value.++It's useful for decoding the difference between the following two cases:++> ?param=value++> ?param+-}+{-# INLINE maybe #-}+maybe :: Value a -> Value (Maybe a)+maybe (Value (ReaderT singleValueFn)) =+  Value (ReaderT (traverse (singleValueFn . pure) . listToMaybe))++{-# INLINE bool #-}+bool :: Value Bool+bool =+  fromMaybe False <$> maybe (parser B.lenientParser)
library/Strelka/Prelude.hs view
@@ -50,10 +50,18 @@ ------------------------- import Data.Text as Exports (Text) +-- scientific+-------------------------+import Data.Scientific as Exports (Scientific)+ -- hashable ------------------------- import Data.Hashable as Exports +-- time+-------------------------+import Data.Time as Exports+ -- Utils ------------------------- import qualified Data.ByteString as ByteString@@ -74,6 +82,14 @@           192 <= w && w <= 214 ||           216 <= w && w <= 222 +{-# INLINE tryError #-} tryError :: MonadError e m => m a -> m (Either e a) tryError m =   catchError (liftM Right m) (return . Left)++{-# INLINE list #-}+list :: a -> (b -> [b] -> a) -> [b] -> a+list nil cons =+  \case+    head : tail -> cons head tail+    _ -> nil
− library/Strelka/RequestBodyConsumer.hs 
@@ -1,205 +0,0 @@-module Strelka.RequestBodyConsumer-where--import Strelka.Prelude-import qualified Data.Attoparsec.ByteString-import qualified Data.Attoparsec.Text-import qualified Data.Attoparsec.Types-import qualified Data.ByteString-import qualified Data.ByteString.Lazy-import qualified Data.ByteString.Builder-import qualified Data.Text-import qualified Data.Text.Encoding-import qualified Data.Text.Encoding.Error-import qualified Data.Text.Lazy-import qualified Data.Text.Lazy.Encoding-import qualified Data.Text.Lazy.Builder---{-|-A specification of how to consume the request body byte-stream.--}-newtype RequestBodyConsumer a =-  RequestBodyConsumer (IO ByteString -> IO a)-  deriving (Functor)--{-|-Fold with support for early termination,-which is interpreted from "Left".--}-foldBytesWithTermination :: (a -> ByteString -> Either a a) -> a -> RequestBodyConsumer a-foldBytesWithTermination step init =-  RequestBodyConsumer consumer-  where-    consumer getChunk =-      recur init-      where-        recur state =-          getChunk >>= onChunk-          where-            onChunk chunk =-              if Data.ByteString.null chunk-                then return state-                else case step state chunk of-                  Left newState -> return newState-                  Right newState -> recur newState--{-|-Fold with support for early termination,-which is interpreted from "Left".--}-foldTextWithTermination :: (a -> Text -> Either a a) -> a -> RequestBodyConsumer a-foldTextWithTermination step init =-  fmap snd (foldBytesWithTermination bytesStep bytesInit)-  where-    bytesInit =-      (decode, init)-      where-        decode =-          Data.Text.Encoding.streamDecodeUtf8With Data.Text.Encoding.Error.lenientDecode-    bytesStep (!decode, !state) bytesChunk =-      case decode bytesChunk of-        Data.Text.Encoding.Some textChunk leftovers nextDecode ->-          if Data.Text.null textChunk-            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-  where-    consumer getChunk =-      recur init-      where-        recur state =-          getChunk >>= onChunk-          where-            onChunk chunk =-              if Data.ByteString.null chunk-                then return state-                else recur (step state chunk)--{-|-Fold over text chunks decoded using UTF8.--}-foldText :: (a -> Text -> a) -> a -> RequestBodyConsumer a-foldText step init =-  fmap fst (foldBytes bytesStep bytesInit)-  where-    bytesInit =-      (init, Data.Text.Encoding.streamDecodeUtf8With Data.Text.Encoding.Error.lenientDecode)-    bytesStep (!state, !decode) bytesChunk =-      case decode bytesChunk of-        Data.Text.Encoding.Some textChunk leftovers nextDecode ->-          (nextState, nextDecode)-          where-            nextState =-              if Data.Text.null textChunk-                then state-                else step state textChunk--{- |-Similar to "Foldable"\'s 'foldMap'.--}-buildFromBytes :: Monoid a => (ByteString -> a) -> RequestBodyConsumer a-buildFromBytes proj =-  foldBytes (\l r -> mappend l (proj r)) mempty--{- |-Similar to "Foldable"\'s 'foldMap'.--}-buildFromText :: Monoid a => (Text -> a) -> RequestBodyConsumer a-buildFromText proj =-  foldText (\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 =-  buildFromBytes 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)-  where-    step (builder, decode) bytes =-      case decode bytes of-        Data.Text.Encoding.Some decodedChunk _ newDecode ->-          (builder <> Data.Text.Lazy.Builder.fromText decodedChunk, newDecode)-    init =-      (mempty, Data.Text.Encoding.streamDecodeUtf8)--{-|-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 foldBytesWithTermination (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 foldTextWithTermination (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)-  where-    step result chunk =-      case result of-        Data.Attoparsec.Types.Partial chunkToResult ->-          Right (chunkToResult chunk)-        _ ->-          Left result-    finalise =-      \case-        Data.Attoparsec.Types.Partial chunkToResult ->-          finalise (chunkToResult mempty)-        Data.Attoparsec.Types.Done leftovers resultValue ->-          Right resultValue-        Data.Attoparsec.Types.Fail leftovers contexts message ->-          Left (fromString (intercalate " > " contexts <> ": " <> message))
+ library/Strelka/RequestBodyParsing.hs view
@@ -0,0 +1,19 @@+module Strelka.RequestBodyParsing+(+  Parser,+  Folded(..),+  fail,+  foldBytes,+  foldText,+  buildFromBytes,+  buildFromText,+  parseBytes,+  parseText,+  parseParams,+  -- * Implicit default parsers+  DefaultParser(..),+)+where++import Strelka.RequestBodyParsing.Parser+import Strelka.RequestBodyParsing.DefaultParser
+ library/Strelka/RequestBodyParsing/DefaultParser.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+module Strelka.RequestBodyParsing.DefaultParser+where++import Strelka.Prelude+import qualified Strelka.RequestBodyParsing.Parser as A+import qualified Attoparsec.Data.Implicit as B+import qualified Data.Text.Lazy as C+import qualified Data.Text.Lazy.Builder as D+import qualified Text.Builder as E+import qualified Data.ByteString.Lazy as F+import qualified Data.ByteString.Builder as G+import qualified ByteString.TreeBuilder as H+++{-|+Provides a default request body parser.+-}+class DefaultParser a where+  defaultParser :: A.Parser a+++-- * Generated instances+-------------------------++#define INSTANCE(TYPE, FUNCTION) instance DefaultParser TYPE where {{-# INLINE defaultParser #-}; defaultParser = FUNCTION;}+#define TEXT_PARSER_INSTANCE(TYPE) INSTANCE(TYPE, A.parseText B.lenientParser)++INSTANCE(Text, A.text)+INSTANCE(E.Builder, A.textBuilder)+INSTANCE(C.Text, A.lazyText)+INSTANCE(D.Builder, A.lazyTextBuilder)+INSTANCE(ByteString, A.bytes)+INSTANCE(H.Builder, A.bytesBuilder)+INSTANCE(F.ByteString, A.lazyBytes)+INSTANCE(G.Builder, A.lazyBytesBuilder)+TEXT_PARSER_INSTANCE(Char)+TEXT_PARSER_INSTANCE(Bool)+TEXT_PARSER_INSTANCE(Integer)+TEXT_PARSER_INSTANCE(Int)+TEXT_PARSER_INSTANCE(Int8)+TEXT_PARSER_INSTANCE(Int16)+TEXT_PARSER_INSTANCE(Int32)+TEXT_PARSER_INSTANCE(Int64)+TEXT_PARSER_INSTANCE(Word)+TEXT_PARSER_INSTANCE(Word8)+TEXT_PARSER_INSTANCE(Word16)+TEXT_PARSER_INSTANCE(Word32)+TEXT_PARSER_INSTANCE(Word64)+TEXT_PARSER_INSTANCE(Double)+TEXT_PARSER_INSTANCE(Scientific)+TEXT_PARSER_INSTANCE(TimeOfDay)+TEXT_PARSER_INSTANCE(Day)+TEXT_PARSER_INSTANCE(TimeZone)+TEXT_PARSER_INSTANCE(UTCTime)++#undef INSTANCE+#undef TEXT_PARSER_INSTANCE
+ library/Strelka/RequestBodyParsing/Parser.hs view
@@ -0,0 +1,266 @@+module Strelka.RequestBodyParsing.Parser+where++import Strelka.Prelude hiding (fail)+import qualified Data.Attoparsec.ByteString+import qualified Data.Attoparsec.Text+import qualified Data.Attoparsec.Types+import qualified Data.ByteString+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Lazy.Internal+import qualified Data.ByteString.Builder+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Data.Text.Encoding.Error+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Encoding+import qualified Data.Text.Lazy.Builder+import qualified Data.Text.Internal.Lazy+import qualified Data.HashMap.Strict as C+import qualified Strelka.ParamsParsing.Params as A+import qualified URLDecoders as B+import qualified Text.Builder as D+import qualified ByteString.TreeBuilder as E+++{-|+A specification of how to consume the request body byte-stream.+-}+newtype Parser a =+  Parser (IO ByteString -> IO (Either Text a))+  deriving (Functor)++instance Applicative Parser where+  pure =+    return+  (<*>) =+    ap++instance Monad Parser where+  return x =+    Parser (\_ -> pure (Right x))+  (>>=) (Parser def1) cont2 =+    Parser def+    where+      def input =+        def1 input >>= \case+          Right result -> case cont2 result of Parser def2 -> def2 input+          Left failure -> return (Left failure)++{-|+Result of a folding step.+-}+data Folded a =+  Unfinished !a |+  Finished !a |+  Failed Text+  deriving (Functor)++{-|+Fail with a message.+-}+{-# INLINE fail #-}+fail :: Text -> Parser a+fail message =+  Parser (\_ -> return (Left message))++{-|+Fold with support for early termination and failure.+-}+{-# INLINABLE foldBytes #-}+foldBytes :: (a -> ByteString -> Folded a) -> a -> Parser a+foldBytes step init =+  Parser consumer+  where+    consumer getChunk =+      recur init+      where+        recur !state =+          getChunk >>= onChunk+          where+            onChunk chunk =+              if Data.ByteString.null chunk+                then return (Right state)+                else case step state chunk of+                  Unfinished newState -> recur newState+                  Finished newState -> return (Right newState)+                  Failed failure -> return (Left failure)++{-|+Fold with support for early termination and failure.+-}+{-# INLINABLE foldText #-}+foldText :: (a -> Text -> Folded a) -> a -> Parser a+foldText step init =+  Parser consumer+  where+    consumer getChunk =+      recur Data.Text.Encoding.streamDecodeUtf8 init+      where+        recur !decode !accumulator =+          do+            chunk <- getChunk+            if Data.ByteString.null chunk+              then return (Right accumulator)+              else catch (decodeChunk chunk) fail+          where+            decodeChunk chunk =+              case decode chunk of+                Data.Text.Encoding.Some textChunk leftovers newDecode ->+                  if Data.Text.null textChunk+                    then recur newDecode accumulator+                    else case step accumulator textChunk of+                      Unfinished newAccumulator -> recur newDecode newAccumulator+                      Finished newAccumulator -> return (Right accumulator)+                      Failed failure -> return (Left failure)+            fail (Data.Text.Encoding.Error.DecodeError message byte) =+              return (Left ("UTF8 decoding failure: " <> fromString message))++{- |+Fold over the input chunks, projecting them into a monoid.+Similar to "Foldable"\'s 'foldMap'.+-}+{-# INLINE buildFromBytes #-}+buildFromBytes :: Monoid a => (ByteString -> a) -> Parser a+buildFromBytes proj =+  foldBytes (\l r -> Unfinished (mappend l (proj r))) mempty++{- |+Fold over the input chunks, projecting them into a monoid.+Similar to "Foldable"\'s 'foldMap'.+-}+{-# INLINE buildFromText #-}+buildFromText :: Monoid a => (Text -> a) -> Parser a+buildFromText proj =+  foldText (\l r -> Unfinished (mappend l (proj r))) mempty++{-|+Consume as ByteString.+-}+{-# INLINE bytes #-}+bytes :: Parser ByteString+bytes =+  fmap E.toByteString bytesBuilder++{-|+Consume as a strict ByteString builder.+-}+{-# INLINE bytesBuilder #-}+bytesBuilder :: Parser E.Builder+bytesBuilder =+  buildFromBytes E.byteString++{-|+Consume as lazy ByteString.+-}+{-# INLINE lazyBytes #-}+lazyBytes :: Parser Data.ByteString.Lazy.ByteString+lazyBytes =+  fmap fromAccumulator (buildFromBytes toAccumulator)+  where+    toAccumulator chunk =+      Endo (Data.ByteString.Lazy.Internal.Chunk chunk)+    fromAccumulator (Endo fn) =+      fn Data.ByteString.Lazy.Internal.Empty++{-|+Consume as a lazy ByteString builder.+-}+{-# INLINE lazyBytesBuilder #-}+lazyBytesBuilder :: Parser Data.ByteString.Builder.Builder+lazyBytesBuilder =+  buildFromBytes Data.ByteString.Builder.byteString++{-|+Consume as Text.+-}+{-# INLINE text #-}+text :: Parser Text+text =+  fmap D.run textBuilder++{-|+Consume as a strict Text builder.+-}+{-# INLINE textBuilder #-}+textBuilder :: Parser D.Builder+textBuilder =+  buildFromText D.text++{-|+Consume as lazy Text.+-}+{-# INLINE lazyText #-}+lazyText :: Parser Data.Text.Lazy.Text+lazyText =+  fmap fromAccumulator (buildFromText toAccumulator)+  where+    toAccumulator chunk =+      Endo (Data.Text.Internal.Lazy.Chunk chunk)+    fromAccumulator (Endo fn) =+      fn Data.Text.Internal.Lazy.Empty++{-|+Consume as a lazy Text builder.+-}+{-# INLINE lazyTextBuilder #-}+lazyTextBuilder :: Parser Data.Text.Lazy.Builder.Builder+lazyTextBuilder =+  buildFromText Data.Text.Lazy.Builder.fromText++{-|+Lift an Attoparsec ByteString parser.++Consumption is non-greedy and terminates when the parser is done.+-}+{-# INLINE parseBytes #-}+parseBytes :: Data.Attoparsec.ByteString.Parser a -> Parser a+parseBytes parser =+  processParserResult foldBytes (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.+-}+{-# INLINE parseText #-}+parseText :: Data.Attoparsec.Text.Parser a -> Parser a+parseText parser =+  processParserResult foldText (Data.Attoparsec.Text.Partial (Data.Attoparsec.Text.parse parser))++{-|+Given a chunk-specialized terminating fold implementation lifts a generic Attoparsec result.+-}+{-# INLINE processParserResult #-}+processParserResult :: Monoid chunk => (forall a. (a -> chunk -> Folded a) -> a -> Parser a) -> Data.Attoparsec.Types.IResult chunk a -> Parser a+processParserResult fold result =+  fold step result >>= finalise+  where+    step result chunk =+      case result of+        Data.Attoparsec.Types.Partial chunkToResult ->+          Unfinished (chunkToResult chunk)+        _ ->+          Finished result+    finalise =+      \case+        Data.Attoparsec.Types.Done leftovers resultValue ->+          Parser (\_ -> return (Right resultValue))+        Data.Attoparsec.Types.Fail leftovers contexts message ->+          Parser (\_ -> return (Left (fromString (intercalate " > " contexts <> ": " <> message))))+        Data.Attoparsec.Types.Partial chunkToResult ->+          finalise (chunkToResult mempty)++{-|+Parses the input stream as \"application/x-www-form-urlencoded\".+-}+{-# INLINE parseParams #-}+parseParams :: A.Params a -> Parser a+parseParams parser =+  do+    queryBytes <- bytes+    case B.utf8Query queryBytes of+      Right query -> case A.run parser (flip C.lookup query) of+        Right result -> return result+        Left message -> fail ("Query params parsing error: " <> message)+      Left message -> fail ("Query parsing error: " <> message)
− library/Strelka/RequestParser.hs 
@@ -1,302 +0,0 @@-{-|-DSL for parsing the request.--}-module Strelka.RequestParser-(-  RequestParser,-  -- * Errors-  fail,-  liftEither,-  liftMaybe,-  unliftEither,-  -- * Path Segments-  consumeSegment,-  consumeSegmentWithParser,-  consumeSegmentIfIs,-  ensureThatNoSegmentsIsLeft,-  -- * Params-  getParam,-  -- * Methods-  getMethod,-  ensureThatMethodIs,-  ensureThatMethodIsGet,-  ensureThatMethodIsPost,-  ensureThatMethodIsPut,-  ensureThatMethodIsDelete,-  ensureThatMethodIsHead,-  ensureThatMethodIsTrace,-  -- * Headers-  getHeader,-  ensureThatAccepts,-  ensureThatAcceptsText,-  ensureThatAcceptsHTML,-  ensureThatAcceptsJSON,-  checkIfAccepts,-  getAuthorization,-  -- * Body Consumption-  consumeBody,-)-where--import Strelka.Prelude hiding (fail)-import Strelka.Core.Model-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString.Lazy.Builder as C-import qualified Data.Text as E-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as M-import qualified Data.Attoparsec.ByteString as F-import qualified Data.Attoparsec.Text as Q-import qualified Data.HashMap.Strict as G-import qualified Network.HTTP.Media as K-import qualified Strelka.Core.RequestParser as A-import qualified Strelka.RequestBodyConsumer as P-import qualified Strelka.HTTPAuthorizationParser as D---{-|-Parser of an HTTP request.-Analyzes its meta information, consumes the path segments and the body.--}-type RequestParser =-  A.RequestParser----- * Errors----------------------------{-|-Fail with a text message.--}-fail :: Monad m => Text -> RequestParser m a-fail message =-  A.RequestParser $-  lift $-  lift $-  ExceptT $-  return $-  Left $-  message--{-|-Lift Either, interpreting Left as a failure.--}-liftEither :: Monad m => Either Text a -> RequestParser m a-liftEither =-  A.RequestParser .-  lift .-  lift .-  ExceptT .-  return--{-|-Lift Maybe, interpreting Nothing as a failure.--}-liftMaybe :: Monad m => Maybe a -> RequestParser m a-liftMaybe =-  liftEither .-  maybe (Left "Unexpected Nothing") Right--{-|-Try a parser, extracting the error as Either.--}-unliftEither :: Monad m => RequestParser m a -> RequestParser m (Either Text a)-unliftEither =-  tryError----- * Path Segments----------------------------{-|-Consume the next segment of the path.--}-consumeSegment :: Monad m => RequestParser m Text-consumeSegment =-  A.RequestParser $-  lift $-  StateT $-  \case-    PathSegment segmentText : segmentsTail ->-      return (segmentText, segmentsTail)-    _ ->-      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 =-  A.RequestParser (lift (gets null)) >>= guard----- * Params----------------------------{-|-Get a parameter\'s value by its name, failing if the parameter is not present. --@Maybe@ encodes whether a value was specified at all, i.e. @?name=value@ vs @?name@.--}-getParam :: Monad m => ByteString -> RequestParser m (Maybe ByteString)-getParam name =-  do-    Request _ _ params _ _ <- A.RequestParser ask-    liftMaybe (liftM (\(ParamValue value) -> value) (G.lookup (ParamName name) params))----- * Methods----------------------------{-|-Get the request method.--}-getMethod :: Monad m => RequestParser m ByteString-getMethod =-  do-    Request (Method method) _ _ _ _ <- A.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"@.--}-ensureThatMethodIsGet :: Monad m => RequestParser m ()-ensureThatMethodIsGet =-  ensureThatMethodIs "get"--{-|-Same as @'ensureThatMethodIs' "post"@.--}-ensureThatMethodIsPost :: Monad m => RequestParser m ()-ensureThatMethodIsPost =-  ensureThatMethodIs "post"--{-|-Same as @'ensureThatMethodIs' "put"@.--}-ensureThatMethodIsPut :: Monad m => RequestParser m ()-ensureThatMethodIsPut =-  ensureThatMethodIs "put"--{-|-Same as @'ensureThatMethodIs' "delete"@.--}-ensureThatMethodIsDelete :: Monad m => RequestParser m ()-ensureThatMethodIsDelete =-  ensureThatMethodIs "delete"--{-|-Same as @'ensureThatMethodIs' "head"@.--}-ensureThatMethodIsHead :: Monad m => RequestParser m ()-ensureThatMethodIsHead =-  ensureThatMethodIs "head"--{-|-Same as @'ensureThatMethodIs' "trace"@.--}-ensureThatMethodIsTrace :: Monad m => RequestParser m ()-ensureThatMethodIsTrace =-  ensureThatMethodIs "trace"----- * Headers----------------------------{-|-Lookup a header by name __in lower-case__.--}-getHeader :: Monad m => ByteString -> RequestParser m ByteString-getHeader name =-  do-    Request _ _ _ headers _ <- A.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__.--}-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"@.--}-ensureThatAcceptsText :: Monad m => RequestParser m ()-ensureThatAcceptsText =-  ensureThatAccepts "text/plain"--{-|-Same as @'ensureThatAccepts' "text/html"@.--}-ensureThatAcceptsHTML :: Monad m => RequestParser m ()-ensureThatAcceptsHTML =-  ensureThatAccepts "text/html"--{-|-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__.--}-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.--}-getAuthorization :: Monad m => RequestParser m (Text, Text)-getAuthorization =-  getHeader "authorization" >>= liftEither . D.basicCredentials----- * Body Consumption----------------------------{-|-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) <- A.RequestParser ask-    liftIO (consume getChunk)
+ library/Strelka/RequestParsing.hs view
@@ -0,0 +1,401 @@+{-|+DSL for parsing the request.+-}+module Strelka.RequestParsing+(+  Parser,+  -- * Errors+  fail,+  try,+  -- * Path Segments+  segment,+  segmentWithParser,+  segmentIs,+  noSegmentsLeft,+  -- * Query+  query1,+  query2,+  query3,+  query4,+  query5,+  query6,+  query7,+  queryWithParser,+  -- * Methods+  method,+  methodIs,+  methodIsGet,+  methodIsPost,+  methodIsPut,+  methodIsDelete,+  methodIsHead,+  methodIsTrace,+  -- * Headers+  header,+  accepts,+  acceptsText,+  acceptsHTML,+  acceptsJSON,+  authorization,+  -- * Body Consumption+  body,+  bodyWithParser,+)+where++import Strelka.Prelude hiding (fail, try)+import Strelka.Core.Model+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Builder as C+import qualified Data.Text as E+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as M+import qualified Data.Attoparsec.ByteString as F+import qualified Data.Attoparsec.Text as Q+import qualified Data.HashMap.Strict as G+import qualified Network.HTTP.Media as K+import qualified Strelka.Core.RequestParser as A+import qualified Strelka.RequestBodyParsing.Parser as P+import qualified Strelka.RequestBodyParsing as N+import qualified Strelka.HTTPAuthorizationParsing as D+import qualified Strelka.ParamsParsing.Params as H+import qualified Strelka.ParamsParsing as O+import qualified URLDecoders as I+import qualified Attoparsec.Data.Implicit as J+++{-|+Parser of an HTTP request.+Analyzes its meta information, consumes the path segments and the body.+-}+type Parser =+  A.RequestParser+++-- * Errors+-------------------------++{-|+Fail with a text message.+-}+fail :: Monad m => Text -> Parser m a+fail message =+  A.RequestParser $+  lift $+  lift $+  ExceptT $+  return $+  Left $+  message++{-|+Lift Either, interpreting Left as a failure.+-}+liftEither :: Monad m => Either Text a -> Parser m a+liftEither =+  A.RequestParser .+  lift .+  lift .+  ExceptT .+  return++{-|+Lift Maybe, interpreting Nothing as a failure.+-}+liftMaybe :: Monad m => Maybe a -> Parser m a+liftMaybe =+  liftEither .+  maybe (Left "Unexpected Nothing") Right++{-|+Try a parser, extracting the error as Either.+-}+try :: Monad m => Parser m a -> Parser m (Either Text a)+try =+  tryError+++-- * Path Segments+-------------------------++{-|+Consume the next segment of the path as Text.+If you need Text it's more efficient than using 'segment'.+-}+segmentText :: Monad m => Parser m Text+segmentText =+  A.RequestParser $+  lift $+  StateT $+  \case+    PathSegment segmentText : segmentsTail ->+      return (segmentText, segmentsTail)+    _ ->+      ExceptT (return (Left "No segments left"))++{-|+Consume the next segment if it matches the provided value and fail otherwise.+-}+segmentIs :: Monad m => Text -> Parser m ()+segmentIs expectedSegment =+  do+    segment <- segmentText+    guard (segment == expectedSegment)++{-|+Consume the next segment of the path with an explicit Attoparsec parser.+-}+segmentWithParser :: Monad m => Q.Parser a -> Parser m a+segmentWithParser parser =+  A.RequestParser $+  lift $+  StateT $+  \case+    PathSegment segmentText : segmentsTail ->+      case Q.parseOnly parser segmentText of+        Right result -> return (result, segmentsTail)+        Left failure -> ExceptT (return (Left ("Segment \"" <> segmentText <> "\" parsing failure: " <> E.pack failure)))+    _ ->+      ExceptT (return (Left "No segments left"))++{-|+Consume the next segment of the path with an implicit lenient Attoparsec parser.+-}+segment :: (Monad m, J.LenientParser a) => Parser m a+segment =+  segmentWithParser (J.lenientParser <* Q.endOfInput)++{-|+Fail if there's any path segments left unconsumed.+-}+noSegmentsLeft :: Monad m => Parser m ()+noSegmentsLeft =+  A.RequestParser (lift (gets null)) >>= guard+++-- * Query+-------------------------++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query1 #-}+query1 :: (Monad m, O.DefaultValue a) => Text -> Parser m a+query1 name1 =+  queryWithParser (O.defaultParams1 name1)++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query2 #-}+query2 :: (Monad m, O.DefaultValue a, O.DefaultValue b) => Text -> Text -> Parser m (a, b)+query2 name1 name2 =+  queryWithParser (O.defaultParams2 name1 name2)++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query3 #-}+query3 :: (Monad m, O.DefaultValue a, O.DefaultValue b, O.DefaultValue c) => Text -> Text -> Text -> Parser m (a, b, c)+query3 name1 name2 name3 =+  queryWithParser (O.defaultParams3 name1 name2 name3)++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query4 #-}+query4 :: (Monad m, O.DefaultValue a, O.DefaultValue b, O.DefaultValue c, O.DefaultValue d) => Text -> Text -> Text -> Text -> Parser m (a, b, c, d)+query4 name1 name2 name3 name4 =+  queryWithParser (O.defaultParams4 name1 name2 name3 name4)++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query5 #-}+query5 :: (Monad m, O.DefaultValue a, O.DefaultValue b, O.DefaultValue c, O.DefaultValue d, O.DefaultValue e) => Text -> Text -> Text -> Text -> Text -> Parser m (a, b, c, d, e)+query5 name1 name2 name3 name4 name5 =+  queryWithParser (O.defaultParams5 name1 name2 name3 name4 name5)++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query6 #-}+query6 :: (Monad m, O.DefaultValue a, O.DefaultValue b, O.DefaultValue c, O.DefaultValue d, O.DefaultValue e, O.DefaultValue f) => Text -> Text -> Text -> Text -> Text -> Text -> Parser m (a, b, c, d, e, f)+query6 name1 name2 name3 name4 name5 name6 =+  queryWithParser (O.defaultParams6 name1 name2 name3 name4 name5 name6)++{-|+Parse the query using implicit parsers by specifying the names of parameters.+-}+{-# INLINE query7 #-}+query7 :: (Monad m, O.DefaultValue a, O.DefaultValue b, O.DefaultValue c, O.DefaultValue d, O.DefaultValue e, O.DefaultValue f, O.DefaultValue g) => Text -> Text -> Text -> Text -> Text -> Text -> Text -> Parser m (a, b, c, d, e, f, g)+query7 name1 name2 name3 name4 name5 name6 name7 =+  queryWithParser (O.defaultParams7 name1 name2 name3 name4 name5 name6 name7)++{-|+Parse the request query,+i.e. the URL part that is between the \"?\" and \"#\" characters,+with an explicitly specified parser.+-}+{-# INLINE queryWithParser #-}+queryWithParser :: Monad m => H.Params a -> Parser m a+queryWithParser parser =+  do+    Request _ _ (Query queryBytes) _ _ <- A.RequestParser ask+    case I.utf8Query queryBytes of+      Right query -> case H.run parser (flip G.lookup query) of+        Right result -> return result+        Left message -> fail ("Query params parsing error: " <> message)+      Left message -> fail ("Query parsing error: " <> message)+++-- * Methods+-------------------------++{-|+Get the request method.+-}+method :: Monad m => Parser m ByteString+method =+  do+    Request (Method method) _ _ _ _ <- A.RequestParser ask+    return method++{-|+Ensure that the method matches the provided value __in lower-case__.+-}+methodIs :: Monad m => ByteString -> Parser m ()+methodIs expectedMethod =+  do+    method <- method+    guard (expectedMethod == method)++{-|+Same as @'methodIs' "get"@.+-}+methodIsGet :: Monad m => Parser m ()+methodIsGet =+  methodIs "get"++{-|+Same as @'methodIs' "post"@.+-}+methodIsPost :: Monad m => Parser m ()+methodIsPost =+  methodIs "post"++{-|+Same as @'methodIs' "put"@.+-}+methodIsPut :: Monad m => Parser m ()+methodIsPut =+  methodIs "put"++{-|+Same as @'methodIs' "delete"@.+-}+methodIsDelete :: Monad m => Parser m ()+methodIsDelete =+  methodIs "delete"++{-|+Same as @'methodIs' "head"@.+-}+methodIsHead :: Monad m => Parser m ()+methodIsHead =+  methodIs "head"++{-|+Same as @'methodIs' "trace"@.+-}+methodIsTrace :: Monad m => Parser m ()+methodIsTrace =+  methodIs "trace"+++-- * Headers+-------------------------++{-|+Lookup a header by name __in lower-case__.+-}+header :: Monad m => ByteString -> Parser m ByteString+header name =+  do+    Request _ _ _ headers _ <- A.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__.+-}+accepts :: Monad m => ByteString -> Parser m ()+accepts contentType =+  checkIfAccepts contentType >>=+  liftEither . bool (Left ("Unacceptable content-type: " <> fromString (show contentType))) (Right ())++{-|+Same as @'accepts' "text/plain"@.+-}+acceptsText :: Monad m => Parser m ()+acceptsText =+  accepts "text/plain"++{-|+Same as @'accepts' "text/html"@.+-}+acceptsHTML :: Monad m => Parser m ()+acceptsHTML =+  accepts "text/html"++{-|+Same as @'accepts' "application/json"@.+-}+acceptsJSON :: Monad m => Parser m ()+acceptsJSON =+  accepts "application/json"++{-|+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 -> Parser m Bool+checkIfAccepts contentType =+  liftM (isJust . K.matchAccept [contentType]) (header "accept")++{-|+Parse the username and password from the basic authorization header.+-}+authorization :: Monad m => Parser m (Text, Text)+authorization =+  header "authorization" >>= liftEither . D.basicCredentials+++-- * Body Consumption+-------------------------++{-|+Consume the request body using an implicit parser.++[NOTICE]+Since the body is consumed as a stream,+you can only consume it once regardless of the Alternative branching.+-}+body :: (MonadIO m, N.DefaultParser a) => Parser m a+body =+  bodyWithParser N.defaultParser++{-|+Consume the request body using the explicitly specified parser.++[NOTICE]+Since the body is consumed as a stream,+you can only consume it once regardless of the Alternative branching.+-}+bodyWithParser :: MonadIO m => P.Parser a -> Parser m a+bodyWithParser (P.Parser consume) =+  do+    Request _ _ _ _ (InputStream getChunk) <- A.RequestParser ask+    liftIO (consume getChunk) >>= liftEither
− library/Strelka/ResponseBodyBuilder.hs 
@@ -1,82 +0,0 @@-module Strelka.ResponseBodyBuilder where--import Strelka.Prelude-import qualified Data.ByteString as C-import qualified Data.ByteString.Lazy as D-import qualified Data.ByteString.Builder as E-import qualified Data.Text.Encoding as H-import qualified Data.Text.Lazy as F-import qualified Data.Text.Lazy.Encoding as I-import qualified Data.Text.Lazy.Builder as J---{-|-A builder of the response body.--}-newtype ResponseBodyBuilder =-  ResponseBodyBuilder ((ByteString -> IO ()) -> IO () -> IO ())--instance IsString ResponseBodyBuilder where-  fromString string =-    bytesBuilder (E.stringUtf8 string)--instance Monoid ResponseBodyBuilder where-  mempty =-    ResponseBodyBuilder (\_ flush -> flush)-  mappend (ResponseBodyBuilder cont1) (ResponseBodyBuilder cont2) =-    ResponseBodyBuilder (\feed flush -> cont1 feed (pure ()) *> cont2 feed flush)--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-  where-    impl feed flush =-      F.foldlChunks step (pure ()) text *> flush-      where-        step io textChunk =-          io *> feed bytesChunk-          where-            bytesChunk =-              H.encodeUtf8 textChunk--{-|-Lift ByteString Builder.--}-textBuilder :: J.Builder -> ResponseBodyBuilder-textBuilder =-  lazyText . J.toLazyText-
+ library/Strelka/ResponseBodyBuilding.hs view
@@ -0,0 +1,18 @@+{-|+DSL for building of the response body.+-}+module Strelka.ResponseBodyBuilding+(+  Builder,+  bytes,+  lazyBytes,+  lazyBytesBuilder,+  text,+  lazyText,+  lazyTextBuilder,+  actions,+)+where++import Strelka.ResponseBodyBuilding.Builder+
+ library/Strelka/ResponseBodyBuilding/Builder.hs view
@@ -0,0 +1,88 @@+module Strelka.ResponseBodyBuilding.Builder where++import Strelka.Prelude+import qualified Data.ByteString as C+import qualified Data.ByteString.Lazy as D+import qualified Data.ByteString.Builder as E+import qualified Data.Text.Encoding as H+import qualified Data.Text.Lazy as F+import qualified Data.Text.Lazy.Encoding as I+import qualified Data.Text.Lazy.Builder as J+++{-|+A builder of the response body.+-}+newtype Builder =+  Builder ((ByteString -> IO ()) -> IO () -> IO ())++instance IsString Builder where+  fromString string =+    lazyBytesBuilder (E.stringUtf8 string)++instance Monoid Builder where+  mempty =+    Builder (\_ flush -> flush)+  mappend (Builder cont1) (Builder cont2) =+    Builder (\feed flush -> cont1 feed (pure ()) *> cont2 feed flush)++instance Semigroup Builder+++{-|+Lift ByteString.+-}+bytes :: ByteString -> Builder+bytes x =+  Builder (\feed flush -> feed x *> flush)++{-|+Lift lazy ByteString.+-}+lazyBytes :: D.ByteString -> Builder+lazyBytes x =+  Builder (\feed flush -> D.foldlChunks (\io chunk -> io >> feed chunk) (pure ()) x >> flush)++{-|+Lift a ByteString builder.+-}+lazyBytesBuilder :: E.Builder -> Builder+lazyBytesBuilder =+  lazyBytes . E.toLazyByteString++{-|+Lift Text.+-}+text :: Text -> Builder+text text =+  bytes (H.encodeUtf8 text)++{-|+Lift lazy Text.+-}+lazyText :: F.Text -> Builder+lazyText text =+  Builder impl+  where+    impl feed flush =+      F.foldlChunks step (pure ()) text *> flush+      where+        step io textChunk =+          io *> feed bytesChunk+          where+            bytesChunk =+              H.encodeUtf8 textChunk++{-|+Lift a Text builder.+-}+lazyTextBuilder :: J.Builder -> Builder+lazyTextBuilder =+  lazyText . J.toLazyText++{-|+Lift a handler of the feeding and flushing actions.+-}+actions :: ((ByteString -> IO ()) -> IO () -> IO ()) -> Builder+actions =+  Builder
− library/Strelka/ResponseBuilder.hs 
@@ -1,218 +0,0 @@-module Strelka.ResponseBuilder where--import Strelka.Prelude-import Strelka.Core.Model-import qualified Strelka.ResponseBodyBuilder as A-import qualified Strelka.Core.ResponseBuilder as B---{- |-A composable abstraction for building an HTTP response.--}-type ResponseBuilder =-  B.ResponseBuilder----- * Headers----------------------------{- |-Add a header by name and value.--}-header :: ByteString -> ByteString -> ResponseBuilder-header name value =-  B.ResponseBuilder (\(Response status headers body) -> Response status (Header (HeaderName name) (HeaderValue value) : headers) body)--{- |-Add a @Content-type@ header.--}-contentTypeHeader :: ByteString -> ResponseBuilder-contentTypeHeader x =-  header "content-type" x--{- |-Add a @Location@ header.--}-locationHeader :: ByteString -> ResponseBuilder-locationHeader x =-  header "location" x----- * Statuses----------------------------{- |-Set the status code.--}-status :: Int -> ResponseBuilder-status x =-  B.ResponseBuilder (\(Response _ headers body) -> Response (Status x) headers body)---- ** 2xx Successful Statuses----------------------------{- |-Set the status code to @200@. Following is the description of this status.--The request has succeeded. The information returned with the response is dependent on the method used in the request, for example:--GET an entity corresponding to the requested resource is sent in the response;--HEAD the entity-header fields corresponding to the requested resource are sent in the response without any message-body;--POST an entity describing or containing the result of the action;--TRACE an entity containing the request message as received by the end server.--}-okayStatus :: ResponseBuilder-okayStatus =-  status 200---- ** 3xx Redirection Statuses----------------------------{- |-Set the status code to @301@. Following is the description of this status.--The requested resource has been assigned a new permanent URI and any future references to this resource SHOULD use one of the returned URIs. Clients with link editing capabilities ought to automatically re-link references to the Request-URI to one or more of the new references returned by the server, where possible. This response is cacheable unless indicated otherwise.--The new permanent URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).--If the 301 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.--      Note: When automatically redirecting a POST request after-      receiving a 301 status code, some existing HTTP/1.0 user agents-      will erroneously change it into a GET request.--}-movedPermanentlyStatus :: ResponseBuilder-movedPermanentlyStatus =-  status 301---- ** 4xx Statuses----------------------------{- |-Set the status code to @400@. Following is the description of this status.--The request could not be understood by the server due to malformed syntax. The client SHOULD NOT repeat the request without modifications.--}-badRequestStatus :: ResponseBuilder-badRequestStatus =-  status 400--{- |-Set the status code to @401@. Following is the description of this status.--The request requires user authentication. The response MUST include a WWW-Authenticate header field (section 14.47) containing a challenge applicable to the requested resource. The client MAY repeat the request with a suitable Authorization header field (section 14.8). If the request already included Authorization credentials, then the 401 response indicates that authorization has been refused for those credentials. If the 401 response contains the same challenge as the prior response, and the user agent has already attempted authentication at least once, then the user SHOULD be presented the entity that was given in the response, since that entity might include relevant diagnostic information. HTTP access authentication is explained in "HTTP Authentication: Basic and Digest Access Authentication".--}-unauthorizedStatus :: ResponseBuilder-unauthorizedStatus =-  status 401--{- |-Set the status code to @403@. Following is the description of this status.--The server understood the request, but is refusing to fulfill it. Authorization will not help and the request SHOULD NOT be repeated. If the request method was not HEAD and the server wishes to make public why the request has not been fulfilled, it SHOULD describe the reason for the refusal in the entity. If the server does not wish to make this information available to the client, the status code 404 (Not Found) can be used instead.--}-forbiddenStatus :: ResponseBuilder-forbiddenStatus =-  status 403--{- |-Set the status code to @404@. Following is the description of this status.--The server has not found anything matching the Request-URI. No indication is given of whether the condition is temporary or permanent. The 410 (Gone) status code SHOULD be used if the server knows, through some internally configurable mechanism, that an old resource is permanently unavailable and has no forwarding address. This status code is commonly used when the server does not wish to reveal exactly why the request has been refused, or when no other response is applicable.--}-notFoundStatus :: ResponseBuilder-notFoundStatus =-  status 404--{- |-Set the status code to @405@. Following is the description of this status.--The method specified in the Request-Line is not allowed for the resource identified by the Request-URI. The response MUST include an Allow header containing a list of valid methods for the requested resource.--}-methodNotAllowedStatus :: ResponseBuilder-methodNotAllowedStatus =-  status 405--{- |-Set the status code to @406@. Following is the description of this status.--The resource identified by the request is only capable of generating response entities which have content characteristics not acceptable according to the accept headers sent in the request.--Unless it was a HEAD request, the response SHOULD include an entity containing a list of available entity characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.--      Note: HTTP/1.1 servers are allowed to return responses which are-      not acceptable according to the accept headers sent in the-      request. In some cases, this may even be preferable to sending a-      406 response. User agents are encouraged to inspect the headers of-      an incoming response to determine if it is acceptable.--If the response could be unacceptable, a user agent SHOULD temporarily stop receipt of more data and query the user for a decision on further actions.--}-notAcceptableStatus :: ResponseBuilder-notAcceptableStatus =-  status 406---- ** 5xx Server Error Statuses----------------------------{- |-Set the status code to @500@. Following is the description of this status.--The server encountered an unexpected condition which prevented it from fulfilling the request.--}-internalErrorStatus :: ResponseBuilder-internalErrorStatus =-  status 500----- * Bodies----------------------------{- |-Set the body.--}-body :: A.ResponseBodyBuilder -> ResponseBuilder-body (A.ResponseBodyBuilder x) =-  B.ResponseBuilder (\(Response status headers _) -> Response status headers (OutputStream x)) --{- |-Add a @Content-type@ header with the value of @text/plain@ and set the body.--}-text :: A.ResponseBodyBuilder -> ResponseBuilder-text x =-  contentTypeHeader "text/plain" <> body x--{- |-Add a @Content-type@ header with the value of @text/html@ and set the body.--}-html :: A.ResponseBodyBuilder -> ResponseBuilder-html x =-  contentTypeHeader "text/html" <> body x--{- |-Add a @Content-type@ header with the value of @application/json@ and set the body.--}-json :: A.ResponseBodyBuilder -> ResponseBuilder-json x =-  contentTypeHeader "application/json" <> body x----- * Misc----------------------------{- |-Set the status code to 401, adding a @WWW-Authenticate@ header with specified Realm.--}-unauthorized :: ByteString -> ResponseBuilder-unauthorized realm =-  unauthorizedStatus <> header "WWW-Authenticate" ("Basic realm=\"" <> realm <> "\"")--{- |-Set the status code to 301, adding a @Location@ header with the specified URL.--}-redirect :: ByteString -> ResponseBuilder-redirect url =-  movedPermanentlyStatus <> locationHeader url
+ library/Strelka/ResponseBuilding.hs view
@@ -0,0 +1,218 @@+module Strelka.ResponseBuilding where++import Strelka.Prelude+import Strelka.Core.Model+import qualified Strelka.ResponseBodyBuilding.Builder as A+import qualified Strelka.Core.ResponseBuilder as B+++{- |+A composable abstraction for building an HTTP response.+-}+type Builder =+  B.ResponseBuilder+++-- * Headers+-------------------------++{- |+Add a header by name and value.+-}+header :: ByteString -> ByteString -> Builder+header name value =+  B.ResponseBuilder (\(Response status headers body) -> Response status (Header (HeaderName name) (HeaderValue value) : headers) body)++{- |+Add a @Content-type@ header.+-}+contentTypeHeader :: ByteString -> Builder+contentTypeHeader x =+  header "content-type" x++{- |+Add a @Location@ header.+-}+locationHeader :: ByteString -> Builder+locationHeader x =+  header "location" x+++-- * Statuses+-------------------------++{- |+Set the status code.+-}+status :: Int -> Builder+status x =+  B.ResponseBuilder (\(Response _ headers body) -> Response (Status x) headers body)++-- ** 2xx Successful Statuses+-------------------------++{- |+Set the status code to @200@. Following is the description of this status.++The request has succeeded. The information returned with the response is dependent on the method used in the request, for example:++GET an entity corresponding to the requested resource is sent in the response;++HEAD the entity-header fields corresponding to the requested resource are sent in the response without any message-body;++POST an entity describing or containing the result of the action;++TRACE an entity containing the request message as received by the end server.+-}+okayStatus :: Builder+okayStatus =+  status 200++-- ** 3xx Redirection Statuses+-------------------------++{- |+Set the status code to @301@. Following is the description of this status.++The requested resource has been assigned a new permanent URI and any future references to this resource SHOULD use one of the returned URIs. Clients with link editing capabilities ought to automatically re-link references to the Request-URI to one or more of the new references returned by the server, where possible. This response is cacheable unless indicated otherwise.++The new permanent URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).++If the 301 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.++      Note: When automatically redirecting a POST request after+      receiving a 301 status code, some existing HTTP/1.0 user agents+      will erroneously change it into a GET request.+-}+movedPermanentlyStatus :: Builder+movedPermanentlyStatus =+  status 301++-- ** 4xx Client Error Statuses+-------------------------++{- |+Set the status code to @400@. Following is the description of this status.++The request could not be understood by the server due to malformed syntax. The client SHOULD NOT repeat the request without modifications.+-}+badRequestStatus :: Builder+badRequestStatus =+  status 400++{- |+Set the status code to @401@. Following is the description of this status.++The request requires user authentication. The response MUST include a WWW-Authenticate header field (section 14.47) containing a challenge applicable to the requested resource. The client MAY repeat the request with a suitable Authorization header field (section 14.8). If the request already included Authorization credentials, then the 401 response indicates that authorization has been refused for those credentials. If the 401 response contains the same challenge as the prior response, and the user agent has already attempted authentication at least once, then the user SHOULD be presented the entity that was given in the response, since that entity might include relevant diagnostic information. HTTP access authentication is explained in "HTTP Authentication: Basic and Digest Access Authentication".+-}+unauthorizedStatus :: Builder+unauthorizedStatus =+  status 401++{- |+Set the status code to @403@. Following is the description of this status.++The server understood the request, but is refusing to fulfill it. Authorization will not help and the request SHOULD NOT be repeated. If the request method was not HEAD and the server wishes to make public why the request has not been fulfilled, it SHOULD describe the reason for the refusal in the entity. If the server does not wish to make this information available to the client, the status code 404 (Not Found) can be used instead.+-}+forbiddenStatus :: Builder+forbiddenStatus =+  status 403++{- |+Set the status code to @404@. Following is the description of this status.++The server has not found anything matching the Request-URI. No indication is given of whether the condition is temporary or permanent. The 410 (Gone) status code SHOULD be used if the server knows, through some internally configurable mechanism, that an old resource is permanently unavailable and has no forwarding address. This status code is commonly used when the server does not wish to reveal exactly why the request has been refused, or when no other response is applicable.+-}+notFoundStatus :: Builder+notFoundStatus =+  status 404++{- |+Set the status code to @405@. Following is the description of this status.++The method specified in the Request-Line is not allowed for the resource identified by the Request-URI. The response MUST include an Allow header containing a list of valid methods for the requested resource.+-}+methodNotAllowedStatus :: Builder+methodNotAllowedStatus =+  status 405++{- |+Set the status code to @406@. Following is the description of this status.++The resource identified by the request is only capable of generating response entities which have content characteristics not acceptable according to the accept headers sent in the request.++Unless it was a HEAD request, the response SHOULD include an entity containing a list of available entity characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.++      Note: HTTP/1.1 servers are allowed to return responses which are+      not acceptable according to the accept headers sent in the+      request. In some cases, this may even be preferable to sending a+      406 response. User agents are encouraged to inspect the headers of+      an incoming response to determine if it is acceptable.++If the response could be unacceptable, a user agent SHOULD temporarily stop receipt of more data and query the user for a decision on further actions.+-}+notAcceptableStatus :: Builder+notAcceptableStatus =+  status 406++-- ** 5xx Server Error Statuses+-------------------------++{- |+Set the status code to @500@. Following is the description of this status.++The server encountered an unexpected condition which prevented it from fulfilling the request.+-}+internalErrorStatus :: Builder+internalErrorStatus =+  status 500+++-- * Bodies+-------------------------++{- |+Set the body.+-}+body :: A.Builder -> Builder+body (A.Builder x) =+  B.ResponseBuilder (\(Response status headers _) -> Response status headers (OutputStream x)) ++{- |+Add a @Content-type@ header with the value of @text/plain@ and set the body.+-}+text :: A.Builder -> Builder+text x =+  contentTypeHeader "text/plain" <> body x++{- |+Add a @Content-type@ header with the value of @text/html@ and set the body.+-}+html :: A.Builder -> Builder+html x =+  contentTypeHeader "text/html" <> body x++{- |+Add a @Content-type@ header with the value of @application/json@ and set the body.+-}+json :: A.Builder -> Builder+json x =+  contentTypeHeader "application/json" <> body x+++-- * Misc+-------------------------++{- |+Set the status code to 401, adding a @WWW-Authenticate@ header with specified Realm.+-}+unauthorized :: ByteString -> Builder+unauthorized realm =+  unauthorizedStatus <> header "WWW-Authenticate" ("Basic realm=\"" <> realm <> "\"")++{- |+Set the status code to 301, adding a @Location@ header with the specified URL.+-}+redirect :: ByteString -> Builder+redirect url =+  movedPermanentlyStatus <> locationHeader url
strelka.cabal view
@@ -1,18 +1,22 @@ name:   strelka version:-  1+  2 category:   Web synopsis:   A simple, flexible and composable web-router description:   An HTTP server can be defined as a request parser, which produces a response,-  while managing some state.+  while managing the application state.   As simple as that.   This library exploits that fact to produce a very simple and flexible API,-  which can then be used on top of any server implementation.+  which can be executed on top of any specific HTTP-server implementation (e.g., Warp).   .+  [Library Structure]+  The API is split into a set of DSLs targeted at solving specific problems in isolation,+  thus facilitating a proper separation of concerns.+  .   [Server Bindings]   Currently only a binding to WAI and Warp is known:   <http://hackage.haskell.org/package/strelka-wai>.@@ -52,26 +56,40 @@   hs-source-dirs:     library   exposed-modules:-    Strelka.RequestParser-    Strelka.RequestBodyConsumer-    Strelka.ResponseBuilder-    Strelka.ResponseBodyBuilder+    Strelka.RequestParsing+    Strelka.RequestBodyParsing+    Strelka.ResponseBuilding+    Strelka.ResponseBodyBuilding+    Strelka.ParamsParsing   other-modules:     Strelka.Prelude-    Strelka.HTTPAuthorizationParser+    Strelka.HTTPAuthorizationParsing+    Strelka.ParamsParsing.Value+    Strelka.ParamsParsing.Params+    Strelka.ParamsParsing.DefaultValue+    Strelka.ResponseBodyBuilding.Builder+    Strelka.RequestBodyParsing.Parser+    Strelka.RequestBodyParsing.DefaultParser   default-extensions:     Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples   default-language:     Haskell2010   build-depends:     -- -    strelka-core == 0.1.*,+    strelka-core == 0.3.*,     -- codecs:     base64-bytestring == 1.*,     -- parsing:     attoparsec >= 0.13 && < 0.14,+    attoparsec-data >= 0.1.1 && < 0.2,     http-media >= 0.6.4 && < 0.7,+    url-decoders == 0.2.*,+    -- building:+    text-builder == 0.4.*,+    bytestring-tree-builder == 0.2.*,     -- +    time == 1.*,+    scientific == 0.3.*,     bytestring >= 0.10.8 && < 0.11,     text >= 1 && < 2,     unordered-containers >= 0.2 && < 0.3,