apiary 1.1.2 → 1.1.3
raw patch · 4 files changed
+45/−9 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +12/−0
- apiary.cabal +2/−2
- src/Control/Monad/Apiary/Filter.hs +23/−5
- test/Application.hs +8/−2
CHANGELOG.md view
@@ -1,3 +1,15 @@+# 1.1.3+* wildcard, parameter Accept header.++## apiary-mongoDB(1.1.1)+* MongoAccess class++## apiary-logger(1.1.1)+* Logging class++## apiary-persistent(1.1.1)+* RunSQL class+ # 1.1.2 * re-export Web.Apiary from Web.Apiary.Heroku.
apiary.cabal view
@@ -1,5 +1,5 @@ name: apiary-version: 1.1.2+version: 1.1.3 synopsis: Simple and type safe web framework that can be automatically generate API documentation. description: Simple and type safe web framework that can be automatically generate API documentation.@@ -40,7 +40,7 @@ . * Auto generate API documentation(example: <http://best-haskell.herokuapp.com/api/documentation>). .- more examples: <https://github.com/philopon/apiary/blob/v1.1.2/examples/>+ more examples: <https://github.com/philopon/apiary/blob/v1.1.3/examples/> . live demo: <http://best-haskell.herokuapp.com/> (source code: <https://github.com/philopon/best-haskell>)
src/Control/Monad/Apiary/Filter.hs view
@@ -46,11 +46,10 @@ , function, function', function_, focus , Doc(..)- ) where import Network.Wai as Wai-import Network.Wai.Parse (parseContentType)+import Network.Wai.Parse (parseContentType, parseHttpAccept) import qualified Network.HTTP.Types as Http import Control.Applicative@@ -234,6 +233,25 @@ accept ect = focus (DocAccept ect) $ (lookup "Accept" . requestHeaders <$> getRequest) >>= \case Nothing -> mzero- Just ac -> if parseContentType ect `elem` map (parseContentType . SC.dropWhile (== ' ')) (SC.split ',' ac)- then contentType ect >> getParams- else mzero+ Just ac -> + let ex@(et, _) = parseContentType ect+ accepts = map parseContentType (parseHttpAccept ac)+ in case filter (matchContentType ex) accepts of+ [] -> mzero+ (_,p):_ -> contentType (prettyContentType et p) >> getParams++matchContentType :: (SC.ByteString, [(SC.ByteString, SC.ByteString)])+ -> (SC.ByteString, [(SC.ByteString, SC.ByteString)])+ -> Bool+matchContentType (ct, ep) (acc, ip) = case SC.break (== '/') acc of+ ("*", "/*") -> prmCheck+ (a, "/*") -> a == SC.takeWhile (/= '/') ct && prmCheck+ _ -> acc == ct && prmCheck+ where+ prmCheck = all (\(k,v) -> Just v == lookup k ip) ep++prettyContentType :: SC.ByteString -> [(SC.ByteString, SC.ByteString)] -> SC.ByteString+prettyContentType ct prms =+ let pprms = SC.concat $ concatMap (\(k,v) -> [";", k, "=", v]) prms+ in ct `SC.append` pprms+
test/Application.hs view
@@ -283,14 +283,20 @@ acceptApp :: Application acceptApp = runApp $ [capture|/|] $ do accept "application/json" . action $ bytes "json"+ accept "text/html;prm=t" . action $ bytes "html+prm" accept "text/html" . action $ bytes "html" action $ bytes "other" acceptTest :: Test acceptTest = testGroup "accept" $ map ($ acceptApp)- [ testReq "GET / application/json" . (\a r -> assertJson200 "json" a $ addA "application/json" r)- , testReq "GET / text/html" . (\a r -> assertHtml200 "html" a $ addA "text/html" r)+ [ testReq "GET / application/json" . (\a r -> assertJson200 "json" a $ addA "application/json" r)+ , testReq "GET / text/html" . (\a r -> assertHtml200 "html" a $ addA "text/html" r)+ , testReq "GET / text/html;p=a" . (\a r -> assertHtml200 "html" a $ addA "text/html;p=a" r)+ , testReq "GET / text/html;prm=t" . (\a r -> assertHtml200 "html+prm" a $ addA "text/html;prm=t" r) , testReq "GET / text/plain" . (\a r -> assertRequest 200 Nothing "other" a $ addA "text/plain" r)+ , testReq "GET / text/*" . (\a r -> assertHtml200 "html" a $ addA "text/*" r)+ , testReq "GET / text/*;p=a" . (\a r -> assertHtml200 "html" a $ addA "text/*;p=a" r)+ , testReq "GET / */*" . (\a r -> assertJson200 "json" a $ addA "*/*" r) , testReq "GET /" . assertRequest 200 Nothing "other" ] where