diff --git a/library/Strelka/Executor.hs b/library/Strelka/Executor.hs deleted file mode 100644 --- a/library/Strelka/Executor.hs +++ /dev/null @@ -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)) diff --git a/library/Strelka/Model.hs b/library/Strelka/Model.hs deleted file mode 100644 --- a/library/Strelka/Model.hs +++ /dev/null @@ -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 ()) diff --git a/library/Strelka/Prelude.hs b/library/Strelka/Prelude.hs --- a/library/Strelka/Prelude.hs +++ b/library/Strelka/Prelude.hs @@ -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 diff --git a/library/Strelka/RequestBodyConsumer.hs b/library/Strelka/RequestBodyConsumer.hs --- a/library/Strelka/RequestBodyConsumer.hs +++ b/library/Strelka/RequestBodyConsumer.hs @@ -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. diff --git a/library/Strelka/RequestParser.hs b/library/Strelka/RequestParser.hs --- a/library/Strelka/RequestParser.hs +++ b/library/Strelka/RequestParser.hs @@ -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 diff --git a/library/Strelka/ResponseBuilder.hs b/library/Strelka/ResponseBuilder.hs --- a/library/Strelka/ResponseBuilder.hs +++ b/library/Strelka/ResponseBuilder.hs @@ -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. diff --git a/strelka.cabal b/strelka.cabal --- a/strelka.cabal +++ b/strelka.cabal @@ -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: + . . [Demo] + For a thorough demonstration of the library and suggested usage patterns + check out the following project: . 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