strelka 0.4.0.1 → 1
raw patch · 7 files changed
+121/−256 lines, 7 filesdep +strelka-coredep −monad-controldep −transformers-base
Dependencies added: strelka-core
Dependencies removed: monad-control, transformers-base
Files
- library/Strelka/Executor.hs +0/−19
- library/Strelka/Model.hs +0/−55
- library/Strelka/Prelude.hs +0/−8
- library/Strelka/RequestBodyConsumer.hs +20/−14
- library/Strelka/RequestParser.hs +77/−124
- library/Strelka/ResponseBuilder.hs +7/−22
- strelka.cabal +17/−14
− library/Strelka/Executor.hs
@@ -1,19 +0,0 @@-module Strelka.Executor where--import Strelka.Prelude-import Strelka.Model-import qualified Strelka.RequestParser as A-import qualified Strelka.ResponseBuilder as B-import qualified Data.Text as C-import qualified Data.Text.Encoding as D-import qualified Data.Text.Encoding.Error as E---route :: Monad m => Request -> A.RequestParser m B.ResponseBuilder -> m (Either Text Response)-route request route =- (liftM . liftM) (B.run . fst) (A.run route request segments)- where- segments =- case request of- Request _ (Path pathBytes) _ _ _ ->- filter (not . C.null) (C.splitOn "/" (D.decodeUtf8With E.lenientDecode pathBytes))
− library/Strelka/Model.hs
@@ -1,55 +0,0 @@-module Strelka.Model where--import Strelka.Prelude---data Request =- Request !Method !Path !(HashMap ParamName ParamValue) !(HashMap HeaderName HeaderValue) !InputStream--data Response =- Response !Status ![Header] !OutputStream---- |--- HTTP Method in lower-case.-newtype Method =- Method ByteString- deriving (IsString, Show, Eq, Ord, Hashable)--newtype Path =- Path ByteString- deriving (IsString, Show, Eq, Ord, Hashable)--newtype ParamName =- ParamName ByteString- deriving (IsString, Show, Eq, Ord, Hashable)--newtype ParamValue =- ParamValue (Maybe ByteString)- deriving (Show, Eq, Ord, Hashable)--data Header =- Header !HeaderName !HeaderValue---- |--- Header name in lower-case.-newtype HeaderName =- HeaderName ByteString- deriving (IsString, Show, Eq, Ord, Hashable)--newtype HeaderValue =- HeaderValue ByteString- deriving (IsString, Show, Eq, Ord, Hashable)--newtype Status =- Status Int---- |--- IO action, which produces the next chunk.--- An empty chunk signals the end of the stream.-newtype InputStream =- InputStream (IO ByteString)---- |--- A function on a chunk consuming and flushing IO actions.-newtype OutputStream =- OutputStream ((ByteString -> IO ()) -> IO () -> IO ())
library/Strelka/Prelude.hs view
@@ -22,14 +22,6 @@ import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT) import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT) --- transformers-base---------------------------import Control.Monad.Base as Exports---- monad-control---------------------------import Control.Monad.Trans.Control as Exports- -- mtl ------------------------- import Control.Monad.Cont.Class as Exports
library/Strelka/RequestBodyConsumer.hs view
@@ -2,7 +2,6 @@ where import Strelka.Prelude-import Strelka.Model import qualified Data.Attoparsec.ByteString import qualified Data.Attoparsec.Text import qualified Data.Attoparsec.Types@@ -18,7 +17,7 @@ {-|-A specification of how to consume the request body.+A specification of how to consume the request body byte-stream. -} newtype RequestBodyConsumer a = RequestBodyConsumer (IO ByteString -> IO a)@@ -26,10 +25,10 @@ {-| Fold with support for early termination,-which is interpreted from Left.+which is interpreted from "Left". -}-foldBytesTerminating :: (a -> ByteString -> Either a a) -> a -> RequestBodyConsumer a-foldBytesTerminating step init =+foldBytesWithTermination :: (a -> ByteString -> Either a a) -> a -> RequestBodyConsumer a+foldBytesWithTermination step init = RequestBodyConsumer consumer where consumer getChunk =@@ -47,11 +46,11 @@ {-| Fold with support for early termination,-which is interpreted from Left.+which is interpreted from "Left". -}-foldTextTerminating :: (a -> Text -> Either a a) -> a -> RequestBodyConsumer a-foldTextTerminating step init =- fmap snd (foldBytesTerminating bytesStep bytesInit)+foldTextWithTermination :: (a -> Text -> Either a a) -> a -> RequestBodyConsumer a+foldTextWithTermination step init =+ fmap snd (foldBytesWithTermination bytesStep bytesInit) where bytesInit = (decode, init)@@ -105,10 +104,17 @@ {- | Similar to "Foldable"\'s 'foldMap'. -}-build :: Monoid a => (ByteString -> a) -> RequestBodyConsumer a-build proj =+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. -}@@ -128,7 +134,7 @@ -} bytesBuilder :: RequestBodyConsumer Data.ByteString.Builder.Builder bytesBuilder =- build Data.ByteString.Builder.byteString+ buildFromBytes Data.ByteString.Builder.byteString {-| Consume as Text.@@ -165,7 +171,7 @@ -} bytesParser :: Data.Attoparsec.ByteString.Parser a -> RequestBodyConsumer (Either Text a) bytesParser parser =- parserResult foldBytesTerminating (Data.Attoparsec.ByteString.Partial (Data.Attoparsec.ByteString.parse parser))+ parserResult foldBytesWithTermination (Data.Attoparsec.ByteString.Partial (Data.Attoparsec.ByteString.parse parser)) {-| Lift an Attoparsec Text parser.@@ -174,7 +180,7 @@ -} textParser :: Data.Attoparsec.Text.Parser a -> RequestBodyConsumer (Either Text a) textParser parser =- parserResult foldTextTerminating (Data.Attoparsec.Text.Partial (Data.Attoparsec.Text.parse parser))+ parserResult foldTextWithTermination (Data.Attoparsec.Text.Partial (Data.Attoparsec.Text.parse parser)) {-| Given a chunk-specialized terminating fold implementation lifts a generic Attoparsec result.
library/Strelka/RequestParser.hs view
@@ -1,7 +1,45 @@-module Strelka.RequestParser where+{-|+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-import Strelka.Model+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@@ -11,43 +49,28 @@ 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.-Consumes path segments, analyzes +Analyzes its meta information, consumes the path segments and the body. -}-newtype RequestParser m a =- RequestParser (ReaderT Request (StateT [Text] (ExceptT Text m)) a)- deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadError Text)+type RequestParser =+ A.RequestParser -instance MonadIO m => MonadIO (RequestParser m) where- liftIO io =- RequestParser ((lift . lift . ExceptT . liftM (either (Left . fromString . show) Right) . liftIO . trySE) io)- where- trySE :: IO a -> IO (Either SomeException a)- trySE =- Strelka.Prelude.try -instance MonadTrans RequestParser where- 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)+-- * Errors+------------------------- {-| Fail with a text message. -} fail :: Monad m => Text -> RequestParser m a fail message =- RequestParser $+ A.RequestParser $ lift $ lift $ ExceptT $@@ -60,7 +83,7 @@ -} liftEither :: Monad m => Either Text a -> RequestParser m a liftEither =- RequestParser .+ A.RequestParser . lift . lift . ExceptT .@@ -82,7 +105,7 @@ tryError --- * Path segments+-- * Path Segments ------------------------- {-|@@ -90,12 +113,12 @@ -} consumeSegment :: Monad m => RequestParser m Text consumeSegment =- RequestParser $+ A.RequestParser $ lift $ StateT $ \case- segmentsHead : segmentsTail ->- return (segmentsHead, segmentsTail)+ PathSegment segmentText : segmentsTail ->+ return (segmentText, segmentsTail) _ -> ExceptT (return (Left "No segments left")) @@ -120,9 +143,24 @@ -} ensureThatNoSegmentsIsLeft :: Monad m => RequestParser m () ensureThatNoSegmentsIsLeft =- RequestParser (lift (gets null)) >>= guard+ 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 ------------------------- @@ -132,11 +170,11 @@ getMethod :: Monad m => RequestParser m ByteString getMethod = do- Request (Method method) _ _ _ _ <- RequestParser ask+ Request (Method method) _ _ _ _ <- A.RequestParser ask return method {-|-Ensure that the method matches the provided value in lower-case.+Ensure that the method matches the provided value __in lower-case__. -} ensureThatMethodIs :: Monad m => ByteString -> RequestParser m () ensureThatMethodIs expectedMethod =@@ -191,18 +229,18 @@ ------------------------- {-|-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+ 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.+Content type must be __in lower-case__. -} ensureThatAccepts :: Monad m => ByteString -> RequestParser m () ensureThatAccepts contentType =@@ -233,7 +271,7 @@ {-| Check whether the request provides an Accept header, which includes the specified content type.-Content type must be in lower-case.+Content type must be __in lower-case__. -} checkIfAccepts :: Monad m => ByteString -> RequestParser m Bool checkIfAccepts contentType =@@ -247,22 +285,7 @@ getHeader "authorization" >>= liftEither . D.basicCredentials --- * 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@.--}-getParam :: Monad m => ByteString -> RequestParser m (Maybe ByteString)-getParam name =- do- Request _ _ params _ _ <- RequestParser ask- liftMaybe (liftM (\(ParamValue value) -> value) (G.lookup (ParamName name) params))----- * Body+-- * Body Consumption ------------------------- {-|@@ -275,75 +298,5 @@ consumeBody :: MonadIO m => P.RequestBodyConsumer a -> RequestParser m a consumeBody (P.RequestBodyConsumer consume) = do- Request _ _ _ _ (InputStream getChunk) <- RequestParser ask+ Request _ _ _ _ (InputStream getChunk) <- A.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/ResponseBuilder.hs view
@@ -1,31 +1,16 @@ module Strelka.ResponseBuilder where import Strelka.Prelude-import Strelka.Model+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. -}-newtype ResponseBuilder =- ResponseBuilder (Response -> Response)--instance Monoid ResponseBuilder where- mempty =- ResponseBuilder id- mappend (ResponseBuilder fn1) (ResponseBuilder fn2) =- ResponseBuilder (fn2 . fn1)--instance Semigroup ResponseBuilder---{- |-Execute the builder producing Response.--}-run :: ResponseBuilder -> Response-run (ResponseBuilder fn) =- fn (Response (Status 200) [] (OutputStream (const (const (pure ())))))+type ResponseBuilder =+ B.ResponseBuilder -- * Headers@@ -36,7 +21,7 @@ -} header :: ByteString -> ByteString -> ResponseBuilder header name value =- ResponseBuilder (\(Response status headers body) -> Response status (Header (HeaderName name) (HeaderValue value) : headers) body)+ B.ResponseBuilder (\(Response status headers body) -> Response status (Header (HeaderName name) (HeaderValue value) : headers) body) {- | Add a @Content-type@ header.@@ -61,7 +46,7 @@ -} status :: Int -> ResponseBuilder status x =- ResponseBuilder (\(Response _ headers body) -> Response (Status x) headers body)+ B.ResponseBuilder (\(Response _ headers body) -> Response (Status x) headers body) -- ** 2xx Successful Statuses -------------------------@@ -191,7 +176,7 @@ -} body :: A.ResponseBodyBuilder -> ResponseBuilder body (A.ResponseBodyBuilder x) =- ResponseBuilder (\(Response status headers _) -> Response status headers (OutputStream 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.
strelka.cabal view
@@ -1,20 +1,25 @@ name: strelka version:- 0.4.0.1+ 1+category:+ Web synopsis:- A flexible and composable HTTP-router+ A simple, flexible and composable web-router description:- An HTTP server can be defined as a request parser, which produces a response.+ An HTTP server can be defined as a request parser, which produces a response,+ while managing some state. As simple as that.- This library exploits that fact to produce a very simple API,+ This library exploits that fact to produce a very simple and flexible API, which can then be used on top of any server implementation. .- [Warning]- This library is currently in active development.- The API can change rapidly.+ [Server Bindings]+ Currently only a binding to WAI and Warp is known:+ <http://hackage.haskell.org/package/strelka-wai>. . [Demo]+ For a thorough demonstration of the library and suggested usage patterns+ check out the following project: <https://github.com/nikita-volkov/strelka-demo>. homepage: https://github.com/nikita-volkov/strelka@@ -46,21 +51,21 @@ library hs-source-dirs: library- other-modules:- Strelka.Prelude- Strelka.HTTPAuthorizationParser exposed-modules:- Strelka.Model Strelka.RequestParser Strelka.RequestBodyConsumer Strelka.ResponseBuilder Strelka.ResponseBodyBuilder- Strelka.Executor+ other-modules:+ Strelka.Prelude+ Strelka.HTTPAuthorizationParser 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.*, -- codecs: base64-bytestring == 1.*, -- parsing:@@ -75,8 +80,6 @@ bifunctors == 5.*, semigroups >= 0.18 && < 0.19, mtl == 2.*,- monad-control >= 1 && < 2,- transformers-base >= 0.4 && < 0.5, transformers >= 0.4 && < 0.6, base-prelude < 2, base < 5