module Strelka.RequestParsing
(
Parser,
fail,
try,
segment,
segmentWithParser,
segmentIs,
noSegmentsLeft,
query1,
query2,
query3,
query4,
query5,
query6,
query7,
queryWithParser,
method,
methodIs,
methodIsGet,
methodIsPost,
methodIsPut,
methodIsDelete,
methodIsHead,
methodIsTrace,
header,
accepts,
acceptsText,
acceptsHTML,
acceptsJSON,
authorization,
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 as J
type Parser =
A.RequestParser
fail :: Monad m => Text -> Parser m a
fail message =
A.RequestParser $
lift $
lift $
ExceptT $
return $
Left $
message
liftEither :: Monad m => Either Text a -> Parser m a
liftEither =
A.RequestParser .
lift .
lift .
ExceptT .
return
liftMaybe :: Monad m => Maybe a -> Parser m a
liftMaybe =
liftEither .
maybe (Left "Unexpected Nothing") Right
try :: Monad m => Parser m a -> Parser m (Either Text a)
try =
tryError
segmentText :: Monad m => Parser m Text
segmentText =
A.RequestParser $
lift $
StateT $
\case
PathSegment segmentText : segmentsTail ->
return (segmentText, segmentsTail)
_ ->
ExceptT (return (Left "No segments left"))
segmentIs :: Monad m => Text -> Parser m ()
segmentIs expectedSegment =
do
segment <- segmentText
guard (segment == expectedSegment)
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"))
segment :: (Monad m, J.LenientParser a) => Parser m a
segment =
segmentWithParser (J.lenientParser <* Q.endOfInput)
noSegmentsLeft :: Monad m => Parser m ()
noSegmentsLeft =
A.RequestParser (lift (gets null)) >>= guard
{-# INLINE query1 #-}
query1 :: (Monad m, O.DefaultValue a) => Text -> Parser m a
query1 name1 =
queryWithParser (O.defaultParams1 name1)
{-# 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)
{-# 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)
{-# 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)
{-# 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)
{-# 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)
{-# 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)
{-# 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)
method :: Monad m => Parser m ByteString
method =
do
Request (Method method) _ _ _ _ <- A.RequestParser ask
return method
methodIs :: Monad m => ByteString -> Parser m ()
methodIs expectedMethod =
do
method <- method
guard (expectedMethod == method)
methodIsGet :: Monad m => Parser m ()
methodIsGet =
methodIs "get"
methodIsPost :: Monad m => Parser m ()
methodIsPost =
methodIs "post"
methodIsPut :: Monad m => Parser m ()
methodIsPut =
methodIs "put"
methodIsDelete :: Monad m => Parser m ()
methodIsDelete =
methodIs "delete"
methodIsHead :: Monad m => Parser m ()
methodIsHead =
methodIs "head"
methodIsTrace :: Monad m => Parser m ()
methodIsTrace =
methodIs "trace"
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))
accepts :: Monad m => ByteString -> Parser m ()
accepts contentType =
checkIfAccepts contentType >>=
liftEither . bool (Left ("Unacceptable content-type: " <> fromString (show contentType))) (Right ())
acceptsText :: Monad m => Parser m ()
acceptsText =
accepts "text/plain"
acceptsHTML :: Monad m => Parser m ()
acceptsHTML =
accepts "text/html"
acceptsJSON :: Monad m => Parser m ()
acceptsJSON =
accepts "application/json"
checkIfAccepts :: Monad m => ByteString -> Parser m Bool
checkIfAccepts contentType =
liftM (isJust . K.matchAccept [contentType]) (header "accept")
authorization :: Monad m => Parser m (Text, Text)
authorization =
header "authorization" >>= liftEither . D.basicCredentials
body :: (MonadIO m, N.DefaultParser a) => Parser m a
body =
bodyWithParser N.defaultParser
bodyWithParser :: MonadIO m => P.Parser a -> Parser m a
bodyWithParser (P.Parser consume) =
do
Request _ _ _ _ (InputStream getChunk) <- A.RequestParser ask
liftIO (consume getChunk) >>= liftEither