trasa-server 0.4 → 0.5

raw patch · 2 files changed

+32/−7 lines, 2 filesnew-uploader

Files

• src/Trasa/Server.hs +31/−6
• trasa-server.cabal +1/−1

@@ -8,12 +8,14 @@ {-# OPTIONS_GHC -Wall -Werror #-} module Trasa.Server   ( TrasaT+  , TrasaEnv(..)   , runTrasaT   , mapTrasaT   , serveWith   ) where -import Control.Monad (join)+import Control.Monad (join, MonadPlus(..))+import Control.Applicative (liftA2, Alternative(..)) import Data.Traversable (for) import Data.Functor.Identity @@ -36,8 +38,14 @@  type Headers = M.Map (CI BS.ByteString) T.Text +data TrasaEnv = TrasaEnv+  { trasaHeaders :: Headers+  , trasaQueryString :: QueryString+  , trasaRequestBody :: BS.ByteString+  }+ newtype TrasaT m a = TrasaT-  { unTrasaT :: ExceptT TrasaErr (StateT Headers (ReaderT Headers m)) a+  { unTrasaT :: ExceptT TrasaErr (StateT Headers (ReaderT TrasaEnv m)) a   } deriving   ( Functor   , Applicative@@ -45,16 +53,31 @@   , MonadError TrasaErr   , MonadIO   , MonadState (M.Map (CI BS.ByteString) T.Text)-  , MonadReader (M.Map (CI BS.ByteString) T.Text))+  , MonadReader TrasaEnv+  ) +instance (Monad m, Semigroup a) => Semigroup (TrasaT m a) where+  (<>) = liftA2 (<>)++instance (Monad m, Monoid a) => Monoid (TrasaT m a) where+  mempty = pure mempty++instance (Alternative m, Monad m) => Alternative (TrasaT m) where+  empty = lift empty+  a <|> b = catchError a (const b)++instance (Monad m, Alternative m) => MonadPlus (TrasaT m)+ instance MonadTrans TrasaT where   lift = TrasaT . lift . lift . lift  runTrasaT   :: TrasaT m a   -> M.Map (CI BS.ByteString) T.Text -- ^ Headers+  -> QueryString -- ^ Query string parameters+  -> BS.ByteString -- ^ Request body   -> m (Either TrasaErr a, M.Map (CI BS.ByteString) T.Text)-runTrasaT trasa headers = (flip runReaderT headers . flip runStateT M.empty . runExceptT  . unTrasaT) trasa+runTrasaT trasa headers queryStrings requestBody = (flip runReaderT (TrasaEnv headers queryStrings requestBody) . flip runStateT M.empty . runExceptT  . unTrasaT) trasa  mapTrasaT :: (forall x. m x -> n x) -> TrasaT m a -> TrasaT n a mapTrasaT eta = TrasaT . mapExceptT (mapStateT (mapReaderT eta)) . unTrasaT@@ -81,9 +104,11 @@           Just accepts -> do             content <- for (M.lookup hContentType headers >>= N.parseAccept . TE.encodeUtf8) $ \typ ->               Content typ <$> WAI.strictRequestBody req-            let url = Url (WAI.pathInfo req) (decodeQuery (WAI.queryString req))+            requestBody <- WAI.getRequestBodyChunk req+            let queryStrings = decodeQuery (WAI.queryString req)+                url = Url (WAI.pathInfo req) queryStrings                 dispatch = dispatchWith toMeta makeResponse madeRouter method accepts url content-            runTrasaT dispatch headers >>= \case+            runTrasaT dispatch headers queryStrings requestBody >>= \case               (resErr,newHeaders) -> case join resErr of                 Left (TrasaErr stat errBody) ->                   respond (WAI.responseLBS stat (encodeHeaders newHeaders) errBody)

@@ -2,7 +2,7 @@ name:   trasa-server version:-  0.4+  0.5 synopsis:   Type safe web server description: