rfc 0.0.0.10 → 0.0.0.11

raw patch · 4 files changed

+50/−6 lines, 4 filesdep +binaryPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: binary

API changes (from Hackage documentation)

Files

• rfc.cabal +2/−1
• src/RFC/JSON.hs +3/−1
• src/RFC/Servant.hs +2/−2
• src/RFC/Servant/ApiDoc.hs +43/−2

@@ -1,5 +1,5 @@ name:                rfc-version:             0.0.0.10+version:             0.0.0.11 synopsis:            Robert Fischer's Common library description:         An enhanced Prelude and various utilities for Aeson, Servant, PSQL, and Redis that Robert Fischer uses. homepage:            https://github.com/RobertFischer/rfc#README.md@@ -74,6 +74,7 @@                      , wreq                      , servant-swagger                      , swagger2+                     , binary                      , markdown    exposed-modules:     RFC.Prelude

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -22,7 +23,7 @@ import           ClassyPrelude import           Data.Aeson       as JSON import           Data.Aeson.TH    (deriveJSON)-import           Data.Aeson.Types (Options (..), SumEncoding (..))+import           Data.Aeson.Types (Options (..), SumEncoding (..), Value (..)) import           Data.Char import           RFC.String @@ -56,3 +57,4 @@   case decodeEither' input of     Left err -> throwM $ DecodeError (input, err)     Right a  -> return a+

@@ -74,11 +74,11 @@ type FetchImpl a = UUID -> ApiCtx (IdAnd a) type FetchAPI a = Capture "id" UUID :> Get '[JSON] (IdAnd a) type CreateImpl a = a -> ApiCtx (IdAnd a)-type CreateAPI a = ReqBody '[JSON,FormUrlEncoded] a :> Post '[JSON] (IdAnd a)+type CreateAPI a = ReqBody '[JSON] a :> Post '[JSON] (IdAnd a) type PatchImpl a = UUID -> JSON.Patch -> ApiCtx (IdAnd a) -- type PatchAPI a = Capture "id" UUID :> ReqBody '[JSON] JSON.Patch :> Patch '[JSON] (IdAnd a) type ReplaceImpl a = UUID -> a -> ApiCtx (IdAnd a)-type ReplaceAPI a = Capture "id" UUID :> ReqBody '[JSON,FormUrlEncoded] a :> Post '[JSON] (IdAnd a)+type ReplaceAPI a = Capture "id" UUID :> ReqBody '[JSON] a :> Post '[JSON] (IdAnd a)  type ServerImpl a =   (FetchAllImpl a)

@@ -1,19 +1,28 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE RecordWildCards       #-}  module RFC.Servant.ApiDoc   ( apiToHtml   , apiToAscii   , apiToSwagger+  , apiApplication   ) where -import           Data.Default    (def)+import           Data.Aeson.Types                (fromEncoding, toEncoding)+import qualified Data.Binary.Builder             as Builder+import           Data.Char                       as Char+import           Data.Default                    (def)+import           Network.HTTP.Types.Header       (hContentType)+import           Network.HTTP.Types.Status+import           Network.Wai import           RFC.Prelude import           RFC.Servant import           RFC.String import           Servant.Swagger-import qualified Text.Markdown   as MD+import qualified Text.Blaze.Html.Renderer.String as Blaze+import qualified Text.Markdown                   as MD  apiToHtml :: (HasDocs a) => Proxy a -> Html apiToHtml = preEscapedToHtml . (MD.markdown mdSettings) . cs . markdown . docs@@ -28,3 +37,35 @@  apiToSwagger :: (HasSwagger a) => Proxy a -> Swagger apiToSwagger = toSwagger++apiApplication :: (HasDocs a, HasSwagger a) => Proxy a -> Application+apiApplication api request callback =+  case reqMethod of+    "GET" -> checkPath+    _     -> failMethodNotAllowed+  where+    html = Blaze.renderHtml $ apiToHtml api+    ascii = apiToAscii api+    swaggerToLbs = Builder.toLazyByteString . fromEncoding . toEncoding+    swagger = swaggerToLbs $ apiToSwagger api+    reqMethod = map Char.toUpper $ cs $ requestMethod request+    pathInfo = map Char.toLower $ cs $ rawPathInfo request+    checkPath =+      case map Char.toLower (cs $ rawPathInfo request) of+        "swagger.json"  -> serveSwagger+        "/swagger.json" -> serveSwagger+        "api.html"      -> serveHtml+        "/api.html"     -> serveHtml+        "api.txt"       -> serveTxt+        "/api.txt"      -> serveTxt+        _               -> failPathNotFound+    response contentType body = callback $+      responseLBS status200 [(hContentType, cs contentType)] body+    serveHtml = response "text/html" (cs html)+    serveTxt = response "text/plain" ascii+    serveSwagger = response "application/json" swagger+    failMethodNotAllowed = callback $+      responseLBS status405 [(hContentType, cs "text/plain")] (cs $ "Unsupported HTTP method: " ++ reqMethod)+    failPathNotFound = callback $+      responseLBS status404 [(hContentType, cs "text/plain")] (cs $ "Path not found: " ++ pathInfo)+