trasa-server 0.5 → 0.5.1
raw patch · 2 files changed
+35/−29 lines, 2 filesdep +wai-extradep ~wai
Dependencies added: wai-extra
Dependency ranges changed: wai
Files
- src/Trasa/Server.hs +32/−27
- trasa-server.cabal +3/−2
src/Trasa/Server.hs view
@@ -14,25 +14,26 @@ , serveWith ) where -import Control.Monad (join, MonadPlus(..))+ import Control.Applicative (liftA2, Alternative(..))-import Data.Traversable (for)+import Control.Monad (join, MonadPlus(..))+import Control.Monad.Except (ExceptT,runExceptT,mapExceptT,MonadError(..),MonadIO(..))+import Control.Monad.Reader (ReaderT,runReaderT,mapReaderT,MonadReader(..),MonadTrans(..))+import Control.Monad.State.Strict (StateT,runStateT,mapStateT,MonadState(..))+import Data.CaseInsensitive (CI) import Data.Functor.Identity-+import Data.Traversable (for) import Network.HTTP.Types.Header (hAccept,hContentType)-import qualified Network.HTTP.Types.Status as N-import qualified Network.HTTP.Media.Accept as N-import qualified Network.HTTP.Media.MediaType as N-import qualified Network.HTTP.Media.RenderHeader as N-import Data.CaseInsensitive (CI)-import qualified Network.Wai as WAI import qualified Data.ByteString as BS+import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Data.Map.Strict as M-import Control.Monad.Reader (ReaderT,runReaderT,mapReaderT,MonadReader(..),MonadTrans(..))-import Control.Monad.Except (ExceptT,runExceptT,mapExceptT,MonadError(..),MonadIO(..))-import Control.Monad.State.Strict (StateT,runStateT,mapStateT,MonadState(..))+import qualified Network.HTTP.Media.Accept as N+import qualified Network.HTTP.Media.MediaType as N+import qualified Network.HTTP.Media.RenderHeader as N+import qualified Network.HTTP.Types.Status as N+import qualified Network.Wai as Wai+import qualified Network.Wai.Parse as Wai import Trasa.Core @@ -42,6 +43,7 @@ { trasaHeaders :: Headers , trasaQueryString :: QueryString , trasaRequestBody :: BS.ByteString+ , trasaRequestBodyType :: Maybe Wai.RequestBodyType } newtype TrasaT m a = TrasaT@@ -76,8 +78,9 @@ -> M.Map (CI BS.ByteString) T.Text -- ^ Headers -> QueryString -- ^ Query string parameters -> BS.ByteString -- ^ Request body+ -> Maybe Wai.RequestBodyType -- ^ Request body type from @wai-extra@ -> m (Either TrasaErr a, M.Map (CI BS.ByteString) T.Text)-runTrasaT trasa headers queryStrings requestBody = (flip runReaderT (TrasaEnv headers queryStrings requestBody) . flip runStateT M.empty . runExceptT . unTrasaT) trasa+runTrasaT trasa headers queryStrings requestBody mrequestBodyType = (flip runReaderT (TrasaEnv headers queryStrings requestBody mrequestBodyType) . 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@@ -92,35 +95,37 @@ -> TrasaT IO resp) -- ^ Actions to perform when requests come in -> Router route -- ^ Router- -> WAI.Application -- ^ WAI Application+ -> Wai.Application -- ^ Wai Application serveWith toMeta makeResponse madeRouter = \req respond ->- case decodeMethod <$> TE.decodeUtf8' (WAI.requestMethod req) of- Left _ -> respond (WAI.responseLBS N.status400 [] "Non utf8 encoded request method")+ case decodeMethod <$> TE.decodeUtf8' (Wai.requestMethod req) of+ Left _ -> respond (Wai.responseLBS N.status400 [] "Non utf8 encoded request method") Right method -> case parseHeaders req of- Left _ -> respond (WAI.responseLBS N.status400 [] "Non utf8 encoded headers")+ Left _ -> respond (Wai.responseLBS N.status400 [] "Non utf8 encoded headers") Right headers -> case parseAccepts headers of- Nothing -> respond (WAI.responseLBS N.status415 [] "Accept header missing or malformed")+ Nothing -> respond (Wai.responseLBS N.status415 [] "Accept header missing or malformed") Just accepts -> do content <- for (M.lookup hContentType headers >>= N.parseAccept . TE.encodeUtf8) $ \typ ->- Content typ <$> WAI.strictRequestBody req- requestBody <- WAI.getRequestBodyChunk req- let queryStrings = decodeQuery (WAI.queryString req)- url = Url (WAI.pathInfo req) queryStrings+ Content typ <$> Wai.strictRequestBody 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 queryStrings requestBody >>= \case+ mrequestBodyType = Wai.getRequestBodyType req+ runTrasaT dispatch headers queryStrings requestBody mrequestBodyType >>= \case (resErr,newHeaders) -> case join resErr of Left (TrasaErr stat errBody) ->- respond (WAI.responseLBS stat (encodeHeaders newHeaders) errBody)+ respond (Wai.responseLBS stat (encodeHeaders newHeaders) errBody) Right (Content typ lbs) -> do let cType = TE.decodeUtf8 (N.renderHeader typ) encodedHeaders = encodeHeaders (M.insert hContentType cType newHeaders)- respond (WAI.responseLBS N.status200 encodedHeaders lbs)+ respond (Wai.responseLBS N.status200 encodedHeaders lbs) where encodeHeaders = M.toList . fmap TE.encodeUtf8- parseHeaders = traverse TE.decodeUtf8' . M.fromList . WAI.requestHeaders+ parseHeaders = traverse TE.decodeUtf8' . M.fromList . Wai.requestHeaders parseAccepts :: Headers -> Maybe [N.MediaType] parseAccepts headers = case M.lookup hAccept headers of Nothing -> Just ["*/*"] Just accept -> (traverse N.parseAccept . fmap (TE.encodeUtf8 . T.dropAround (' '==)) . T.splitOn ",") accept+
trasa-server.cabal view
@@ -2,7 +2,7 @@ name: trasa-server version:- 0.5+ 0.5.1 synopsis: Type safe web server description:@@ -44,7 +44,8 @@ , mtl == 2.2.* , text == 1.2.* , trasa == 0.4.*- , wai == 3.2.*+ , wai == 3.2.2.*+ , wai-extra default-language: Haskell2010