packages feed

strelka (empty) → 0.4

raw patch · 11 files changed

+1024/−0 lines, 11 filesdep +attoparsecdep +basedep +base-preludesetup-changed

Dependencies added: attoparsec, base, base-prelude, base64-bytestring, bifunctors, bytestring, hashable, http-media, monad-control, mtl, semigroups, text, transformers, transformers-base, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2016, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ library/Strelka/Executor.hs view
@@ -0,0 +1,19 @@+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/HTTPAuthorizationParser.hs view
@@ -0,0 +1,38 @@+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/Model.hs view
@@ -0,0 +1,55 @@+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
@@ -0,0 +1,87 @@+module Strelka.Prelude+( +  module Exports,+  lowerCaseBytes_iso_8859_1,+  tryError,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (First(..), Last(..), (<>))++-- transformers+-------------------------+import Control.Monad.IO.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)+import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT)+import Control.Monad.Trans.Maybe as Exports+import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)+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+import Control.Monad.Error.Class as Exports hiding (Error(..))+import Control.Monad.Reader.Class as Exports+import Control.Monad.State.Class as Exports+import Control.Monad.Writer.Class as Exports++-- semigroups+-------------------------+import Data.Semigroup as Exports++-- bifunctors+-------------------------+import Data.Bifunctor as Exports++-- unordered-containers+-------------------------+import Data.HashMap.Strict as Exports (HashMap)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- hashable+-------------------------+import Data.Hashable as Exports++-- Utils+-------------------------+import qualified Data.ByteString as ByteString++-- |+-- Lowercase according to ISO-8859-1.+lowerCaseBytes_iso_8859_1 :: ByteString -> ByteString+lowerCaseBytes_iso_8859_1 =+  ByteString.map byteTransformation+  where+    byteTransformation w =+      if transformable+        then w + 32+        else w+      where+        transformable =+          65 <= w && w <=  90 ||+          192 <= w && w <= 214 ||+          216 <= w && w <= 222++tryError :: MonadError e m => m a -> m (Either e a)+tryError m =+  catchError (liftM Right m) (return . Left)
+ library/Strelka/RequestBodyConsumer.hs view
@@ -0,0 +1,160 @@+module Strelka.RequestBodyConsumer where++import Strelka.Prelude+import Strelka.Model+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+++newtype RequestBodyConsumer a =+  RequestBodyConsumer (IO ByteString -> IO a)+  deriving (Functor)++-- |+-- Fold with support for early termination,+-- which is interpreted from Left.+foldBytesTerminating :: (a -> ByteString -> Either a a) -> a -> RequestBodyConsumer a+foldBytesTerminating step init =+  RequestBodyConsumer consumer+  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.+foldTextTerminating :: (a -> Text -> Either a a) -> a -> RequestBodyConsumer a+foldTextTerminating step init =+  fmap snd (foldBytesTerminating 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)++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)++-- |+-- A UTF8 text chunks decoding consumer.+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'.+-}+build :: Monoid a => (ByteString -> a) -> RequestBodyConsumer a+build proj =+  foldBytes (\l r -> mappend l (proj r)) mempty++bytes :: RequestBodyConsumer ByteString+bytes =+  fmap Data.ByteString.Lazy.toStrict lazyBytes++lazyBytes :: RequestBodyConsumer Data.ByteString.Lazy.ByteString+lazyBytes =+  fmap Data.ByteString.Builder.toLazyByteString bytesBuilder++bytesBuilder :: RequestBodyConsumer Data.ByteString.Builder.Builder+bytesBuilder =+  build Data.ByteString.Builder.byteString++text :: RequestBodyConsumer Text+text =+  fmap Data.Text.Lazy.toStrict lazyText++lazyText :: RequestBodyConsumer Data.Text.Lazy.Text+lazyText =+  fmap Data.Text.Lazy.Builder.toLazyText textBuilder++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)++-- |+-- Turn a bytes parser into an input stream consumer.+bytesParser :: Data.Attoparsec.ByteString.Parser a -> RequestBodyConsumer (Either Text a)+bytesParser parser =+  parserResult foldBytesTerminating (Data.Attoparsec.ByteString.Partial (Data.Attoparsec.ByteString.parse parser))++textParser :: Data.Attoparsec.Text.Parser a -> RequestBodyConsumer (Either Text a)+textParser parser =+  parserResult foldTextTerminating (Data.Attoparsec.Text.Partial (Data.Attoparsec.Text.parse parser))++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/RequestParser.hs view
@@ -0,0 +1,268 @@+module Strelka.RequestParser where++import Strelka.Prelude+import Strelka.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.RequestBodyConsumer as P+import qualified Strelka.HTTPAuthorizationParser as D+++newtype RequestParser m a =+  RequestParser (ReaderT Request (StateT [Text] (ExceptT Text m)) a)+  deriving (Functor, Applicative, Monad, Alternative, MonadPlus, MonadError Text)++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)))++run :: RequestParser m a -> Request -> [Text] -> m (Either Text (a, [Text]))+run (RequestParser impl) request segments =+  runExceptT (runStateT (runReaderT impl request) segments)++fail :: Monad m => Text -> RequestParser m a+fail message =+  RequestParser $+  lift $+  lift $+  ExceptT $+  return $+  Left $+  message++liftEither :: Monad m => Either Text a -> RequestParser m a+liftEither =+  RequestParser .+  lift .+  lift .+  ExceptT .+  return++-- |+-- +liftMaybe :: Monad m => Maybe a -> RequestParser m a+liftMaybe =+  liftEither .+  maybe (Left "Unexpected Nothing") Right++-- |+-- Extract the error from RequestParser.+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 =+  RequestParser $+  lift $+  StateT $+  \case+    segmentsHead : segmentsTail ->+      return (segmentsHead, segmentsTail)+    _ ->+      ExceptT (return (Left "No segments left"))++consumeSegmentWithParser :: Monad m => Q.Parser a -> RequestParser m a+consumeSegmentWithParser parser =+  consumeSegment >>= liftEither . first E.pack . Q.parseOnly parser++consumeSegmentIfIs :: Monad m => Text -> RequestParser m ()+consumeSegmentIfIs expectedSegment =+  do+    segment <- consumeSegment+    guard (segment == expectedSegment)++ensureThatNoSegmentsIsLeft :: Monad m => RequestParser m ()+ensureThatNoSegmentsIsLeft =+  RequestParser (lift (gets null)) >>= guard+++-- * Methods+-------------------------++getMethod :: Monad m => RequestParser m ByteString+getMethod =+  do+    Request (Method method) _ _ _ _ <- RequestParser ask+    return method++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 _ <- 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+++-- * 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+-------------------------++consumeBody :: MonadIO m => P.RequestBodyConsumer a -> RequestParser m a+consumeBody (P.RequestBodyConsumer consume) =+  do+    Request _ _ _ _ (InputStream getChunk) <- RequestParser ask+    liftIO (consume getChunk)++consumeBodyFolding :: MonadIO m => (a -> ByteString -> a) -> a -> RequestParser m a+consumeBodyFolding step init =+  consumeBody (P.foldBytes step init)++consumeBodyBuilding :: (MonadIO m, Monoid a) => (ByteString -> a) -> RequestParser m a+consumeBodyBuilding proj =+  consumeBody (P.build proj)++consumeBodyAsBytes :: MonadIO m => RequestParser m ByteString+consumeBodyAsBytes =+  consumeBody P.bytes++consumeBodyAsLazyBytes :: MonadIO m => RequestParser m B.ByteString+consumeBodyAsLazyBytes =+  consumeBody P.lazyBytes++consumeBodyAsBytesBuilder :: MonadIO m => RequestParser m C.Builder+consumeBodyAsBytesBuilder =+  consumeBody P.bytesBuilder++consumeBodyAsText :: MonadIO m => RequestParser m Text+consumeBodyAsText =+  consumeBody P.text++consumeBodyAsLazyText :: MonadIO m => RequestParser m L.Text+consumeBodyAsLazyText =+  consumeBody P.lazyText++consumeBodyAsTextBuilder :: MonadIO m => RequestParser m M.Builder+consumeBodyAsTextBuilder =+  consumeBody P.textBuilder++consumeBodyWithBytesParser :: MonadIO m => F.Parser a -> RequestParser m a+consumeBodyWithBytesParser parser =+  consumeBody (P.bytesParser parser) >>= liftEither++consumeBodyWithTextParser :: MonadIO m => Q.Parser a -> RequestParser m a+consumeBodyWithTextParser parser =+  consumeBody (P.textParser parser) >>= liftEither
+ library/Strelka/ResponseBodyBuilder.hs view
@@ -0,0 +1,61 @@+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+++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+++bytes :: ByteString -> ResponseBodyBuilder+bytes x =+  ResponseBodyBuilder (\feed flush -> feed x *> flush)++lazyBytes :: D.ByteString -> ResponseBodyBuilder+lazyBytes x =+  ResponseBodyBuilder (\feed flush -> D.foldlChunks (\io chunk -> io >> feed chunk) (pure ()) x >> flush)++bytesBuilder :: E.Builder -> ResponseBodyBuilder+bytesBuilder =+  lazyBytes . E.toLazyByteString++text :: Text -> ResponseBodyBuilder+text text =+  bytes (H.encodeUtf8 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++textBuilder :: J.Builder -> ResponseBodyBuilder+textBuilder =+  lazyText . J.toLazyText+
+ library/Strelka/ResponseBuilder.hs view
@@ -0,0 +1,233 @@+module Strelka.ResponseBuilder where++import Strelka.Prelude+import Strelka.Model+import qualified Strelka.ResponseBodyBuilder as A+++{- |+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 ())))))+++-- * Headers+-------------------------++{- |+Add a header by name and value.+-}+header :: ByteString -> ByteString -> ResponseBuilder+header name value =+  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 =+  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) =+  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
+ strelka.cabal view
@@ -0,0 +1,79 @@+name:+  strelka+version:+  0.4+synopsis:+  Extremely flexible and composable router+description:+  An HTTP server can be defined as a request parser, which produces a response.+  As simple as that.+  This library exploits that fact to produce a very simple 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.+homepage:+  https://github.com/nikita-volkov/strelka+bug-reports:+  https://github.com/nikita-volkov/strelka/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2016, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/strelka.git+++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+  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:+    -- codecs:+    base64-bytestring == 1.*,+    -- parsing:+    attoparsec >= 0.13 && < 0.14,+    http-media >= 0.6.4 && < 0.7,+    -- +    bytestring >= 0.10.8 && < 0.11,+    text >= 1 && < 2,+    unordered-containers >= 0.2 && < 0.3,+    hashable == 1.*,+    -- +    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