servant-server-namedargs 0.1.0.0 → 0.1.1.0

raw patch · 3 files changed

+46/−10 lines, 3 filesdep +bytestringdep ~servant-namedargs

Dependencies added: bytestring

Dependency ranges changed: servant-namedargs

Files

• CHANGELOG.md +4/−0
• servant-server-namedargs.cabal +5/−3
• src/Servant/Server/NamedArgs.hs +37/−7

@@ -3,3 +3,7 @@ ## 0.1.0.0 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.++## 0.1.1.0 -- 2019-02-25++* Support for NamedBody'

@@ -1,8 +1,9 @@ name:                servant-server-namedargs-version:             0.1.0.0+version:             0.1.1.0 synopsis:            Automatically derive API server functions with named and optional parameters+homepage:            https://gitlab.com/sciencei/servant-server-namedargs+bug-reports:         https://gitlab.com/sciencei/servant-server-namedargs/issues -- description:--- homepage:             license:             BSD3 license-file:        LICENSE author:              Cullin Poresky@@ -20,12 +21,13 @@   build-depends:       base                >= 4.11    && < 4.13                      , servant             >= 0.14.1  && < 0.16                      , servant-server      >= 0.14.1  && < 0.16-                     , servant-namedargs   >= 0.1     && < 0.2+                     , servant-namedargs   >= 0.1.1   && < 0.2                      , named               >= 0.2     && < 0.3                      , text                >= 1.2     && < 1.3                      , wai                 >= 3.2.1.2 && <3.3                      , http-types          >= 0.12.2  && <0.13                      , string-conversions  >= 0.4.0.1 && <0.5                      , http-api-data       >= 0.4     && <0.4.1+                     , bytestring          >= 0.10.4  && <0.11   hs-source-dirs:      src   default-language:    Haskell2010

@@ -18,27 +18,31 @@ import Named.Internal (pattern Arg) import Data.Functor.Identity (Identity) import Servant.API ( (:>), SBoolI, FromHttpApiData, toQueryParam, toUrlPiece-                   , parseQueryParam, parseHeader )+                   , parseQueryParam, parseHeader, If, SBool(..), sbool) import Servant.API.Modifiers (FoldRequired, FoldLenient) import Servant.API.NamedArgs ( foldRequiredNamedArgument, NamedCapture', NamedFlag                              , NamedParam, NamedParams, RequiredNamedArgument                              , NamedCaptureAll, RequestNamedArgument, NamedHeader'-                             , unfoldRequestNamedArgument)+                             , unfoldRequestNamedArgument, NamedBody')+import Servant.API.ContentTypes (AllCTUnrender(..)) import Data.Either (partitionEithers)-import Data.Maybe (mapMaybe)-import Servant.Server (HasServer(..), errBody, err400)+import Data.Maybe (mapMaybe, fromMaybe)+import Servant.Server (HasServer(..), errBody, err400, err415) import Servant.Server.Internal ( passToServer, addParameterCheck, withRequest, delayedFailFatal-                               , Router'(..), addCapture, delayedFail, DelayedIO, addHeaderCheck)+                               , Router'(..), addCapture, delayedFail, DelayedIO, addHeaderCheck+                               , addBodyCheck) import Web.HttpApiData (parseUrlPieceMaybe, parseUrlPieces) import Data.String.Conversions (cs)-import Network.HTTP.Types (parseQueryText)-import Network.Wai (rawQueryString, Request, requestHeaders)+import Network.HTTP.Types (parseQueryText, hContentType)+import Network.Wai (rawQueryString, Request, requestHeaders, lazyRequestBody) import Data.Text (Text) import qualified Data.Text as T import Data.String (IsString(..)) import Control.Monad (join) import GHC.TypeLits (KnownSymbol, symbolVal) import Data.Proxy (Proxy(..))+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString.Lazy as BL  -- | 'NamedFlag's are converted to required named arguments instance (KnownSymbol name, HasServer api context)@@ -209,4 +213,30 @@        delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req +instance ( KnownSymbol name, AllCTUnrender list a, HasServer api context+         , SBoolI (FoldLenient mods)+         ) => HasServer (NamedBody' mods name list a :> api) context where+  +  type ServerT (NamedBody' mods name list a :> api) m =+    (name :! (If (FoldLenient mods) (Either String a) a)) -> ServerT api m +  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s++  route _ context subserver = +    route (Proxy @api) context $+      addBodyCheck subserver ctCheck bodyCheck+    where+      ctCheck = withRequest $ \req -> do+        let contentTypeH = fromMaybe "application/octet-stream"+                            $ lookup hContentType  $ requestHeaders req+        case canHandleCTypeH (Proxy @list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of+          Nothing -> delayedFail err415+          Just f -> pure f++      bodyCheck f = withRequest $ \req -> do+        mrqbody <- f <$> liftIO (lazyRequestBody req)+        case sbool :: SBool (FoldLenient mods) of+          STrue -> pure . Arg $ mrqbody+          SFalse -> case mrqbody of+            Left e  -> delayedFailFatal err400 { errBody = cs e }+            Right v -> pure . Arg $ v