trasa-server 0.1 → 0.2
raw patch · 3 files changed
+29/−22 lines, 3 filesdep +http-mediadep ~trasa
Dependencies added: http-media
Dependency ranges changed: trasa
Files
- src/Trasa/Server.hs +14/−9
- test/Main.hs +12/−11
- trasa-server.cabal +3/−2
src/Trasa/Server.hs view
@@ -22,7 +22,9 @@ import Data.Functor.Identity import Network.HTTP.Types.Header (hAccept,hContentType)-import qualified Network.HTTP.Types.Status as S+import qualified Network.HTTP.Types.Status as N+import qualified Network.HTTP.Media.Accept 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@@ -75,14 +77,14 @@ -> WAI.Application -- ^ WAI Application serveWith toQuerys toReqBody toRespBody makeResponse router = \req respond ->- case TE.decodeUtf8' (WAI.requestMethod req) of- Left _ -> respond (WAI.responseLBS S.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 S.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 S.status415 [] "Accept header missing")+ Nothing -> respond (WAI.responseLBS N.status415 [] "Accept header missing or malformed") Just accepts -> do- content <- for (M.lookup hContentType headers) $ \typ ->+ 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)) dispatch = dispatchWith toQuerys toReqBody toRespBody makeResponse router method accepts url content@@ -91,9 +93,12 @@ Left (TrasaErr stat errBody) -> respond (WAI.responseLBS stat (encodeHeaders newHeaders) errBody) Right (Content typ lbs) -> do- let encodedHeaders = encodeHeaders (M.insert hContentType typ newHeaders)- respond (WAI.responseLBS S.status200 encodedHeaders lbs)+ let cType = TE.decodeUtf8 (N.renderHeader typ)+ encodedHeaders = encodeHeaders (M.insert hContentType cType newHeaders)+ respond (WAI.responseLBS N.status200 encodedHeaders lbs) where encodeHeaders = M.toList . fmap TE.encodeUtf8 parseHeaders = traverse TE.decodeUtf8' . M.fromList . WAI.requestHeaders- parseAccepts = fmap (fmap T.strip . T.splitOn (T.singleton ',')) . M.lookup hAccept+ parseAccepts headers = do+ accept <- M.lookup hAccept headers+ (traverse N.parseAccept . fmap (TE.encodeUtf8 . T.dropAround (' '==)) . T.splitOn ",") accept
test/Main.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleContexts #-} import Trasa.Core+import qualified Trasa.Method as M import Trasa.Server import Data.Vinyl import Data.Functor.Identity@@ -29,7 +30,7 @@ withApplication (return app) $ \port -> do manager <- HC.newManager HC.defaultManagerSettings attempt manager ("GET http://127.0.0.1:" ++ show port ++ "/") $ \x -> x- { HC.requestHeaders = [("Accept","text/plain"),("ContentType","text/plain")]+ { HC.requestHeaders = [("Accept","text/plain"),("ContentType","*/*")] } attempt manager ("GET http://127.0.0.1:" ++ show port ++ "/hello") $ \x -> x { HC.requestHeaders = [("Accept","text/plain"),("ContentType","text/plain")]@@ -71,11 +72,11 @@ (mapQuery captureCodecToCaptureDecoding . metaQuery . meta) (mapRequestBody (Many . pure . bodyCodecToBodyDecoding) . metaRequestBody . meta) router- "GET"+ M.get (decodeUrl url) allRoutes :: [Constructed Route]-allRoutes = +allRoutes = [ Constructed HelloR , Constructed AdditionR , Constructed IdentityR@@ -96,7 +97,7 @@ , metaQuery :: Rec (Query CaptureCodec) qs , metaRequestBody :: RequestBody BodyCodec rq , metaResponseBody :: ResponseBody BodyCodec rp- , metaMethod :: T.Text+ , metaMethod :: Method } meta :: Route ps qs rq rp -> Meta ps qs rq rp@@ -104,31 +105,31 @@ EmptyR -> Meta end qend- bodyless (resp bodyInt) "GET"+ bodyless (resp bodyInt) M.get HelloR -> Meta (match "hello" ./ end) qend- bodyless (resp bodyInt) "GET"+ bodyless (resp bodyInt) M.get AdditionR -> Meta (match "add" ./ capture int ./ capture int ./ end) (optional "more" int .& qend)- bodyless (resp bodyInt) "GET"+ bodyless (resp bodyInt) M.get IdentityR -> Meta (match "identity" ./ capture string ./ end) qend- bodyless (resp bodyString) "GET"+ bodyless (resp bodyString) M.get LeftPadR -> Meta (match "pad" ./ match "left" ./ capture int ./ end) qend- (body bodyString) (resp bodyString) "GET"+ (body bodyString) (resp bodyString) M.get TrickyOneR -> Meta (match "tricky" ./ capture int ./ match "one" ./ end) qend- bodyless (resp bodyString) "GET"+ bodyless (resp bodyString) M.get TrickyTwoR -> Meta (capture int ./ capture int ./ match "two" ./ end) qend- bodyless (resp bodyString) "GET"+ bodyless (resp bodyString) M.get int :: CaptureCodec Int
trasa-server.cabal view
@@ -1,5 +1,5 @@ name: trasa-server-version: 0.1+version: 0.2 synopsis: Type safe web server homepage: https://github.com/haskell-trasa/trasa#readme license: BSD3@@ -22,10 +22,11 @@ , text == 1.2.* , wai == 3.2.* , http-types == 0.9.*+ , http-media == 0.6.* , case-insensitive == 1.2.* , containers == 0.5.* , mtl == 2.2.*- , trasa+ , trasa == 0.2.* default-language: Haskell2010 test-suite test