servant-proto-lens (empty) → 0.1.0.0

raw patch · 8 files changed

+227/−0 lines, 8 filesdep +HUnitdep +asyncdep +basesetup-changed

Dependencies added: HUnit, async, base, bytestring, data-default-class, http-client, http-media, lens, proto-lens, proto-lens-protobuf-types, servant, servant-client, servant-proto-lens, servant-server, test-framework, test-framework-hunit, warp

Files

ChangeLog.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
servant-proto-lens.cabal +44/−0
src/Servant/API/ContentTypes/Proto.hs +26/−0
test/Spec.hs +50/−0
test/TestClient.hs +21/−0
test/TestServer.hs +49/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for servant-proto-lens++## 0.1.0.0  -- 2017-12-25++* First version.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2017, PLR++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of PLR nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ servant-proto-lens.cabal view

@@ -0,0 +1,44 @@+name:                servant-proto-lens+version:             0.1.0.0+synopsis:            servant API Content-Type instances for use with proto-lens generated modules+license:             BSD3+license-file:        LICENSE+author:              PLR+maintainer:          plredmond@gmail.com+category:            Web+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Servant.API.ContentTypes.Proto+  build-depends:       base >=4.10 && <4.11+                     , bytestring+                     , http-media+                     , proto-lens+                     , servant+  default-language:    Haskell2010++test-suite servant-proto-lens-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:       TestServer+                       TestClient+  build-depends:       base >=4.10 && <4.11+                     , HUnit+                     , async+                     , data-default-class+                     , http-client+                     , lens+                     , proto-lens+                     , proto-lens-protobuf-types+                     , servant-client+                     , servant-proto-lens+                     , servant-server+                     , test-framework+                     , test-framework-hunit+                     , warp+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N1+  default-language:    Haskell2010

+ src/Servant/API/ContentTypes/Proto.hs view

@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Servant.API.ContentTypes.Proto where++import Network.HTTP.Media ((//), (/:))+import qualified Data.ByteString.Lazy as BS+import qualified Data.List.NonEmpty as NE+import qualified Data.ProtoLens as P+import qualified Servant.API.ContentTypes as S++data Proto++instance S.Accept Proto where+    contentTypes _ = NE.fromList+        [ "application" // "protobuf"+        , "application" // "x-protobuf"+        , "application" // "vnd.google.protobuf"+        ]++instance P.Message m => S.MimeRender Proto m where+    mimeRender _ = BS.fromStrict . P.encodeMessage++instance P.Message m => S.MimeUnrender Proto m where+    mimeUnrender _ = P.decodeMessage . BS.toStrict+    -- XXX: there's also mimeUnrenderWithType

+ test/Spec.hs view

@@ -0,0 +1,50 @@+import Control.Lens ((+~))+import Data.Default.Class (def)+import Test.Framework (defaultMain, Test()) +import Test.Framework.Providers.HUnit (testCase)+import qualified Control.Concurrent.Async as A+import qualified Control.Concurrent.MVar as M+import qualified Data.ProtoLens as P+import qualified Proto.Google.Protobuf.Duration as D+import qualified Servant as S+import qualified Servant.Client as SC+import qualified Test.HUnit as HU++import qualified TestServer+import qualified TestClient++-- XXX: Since tests run in paralell by default, but are configured with the+-- same port, this must be run with the single threaded runtime. This is+-- acceptable because the goal here is to test the protobuf de/serialization,+-- not servant.+main = let d = (D.Duration 12 34) in defaultMain+    [ getDur def+    , getDur d+    , exSec  def 0+    , exNSec def 0+    , exSec  d 12+    , exNSec d 34+    ]++-- | Helper to run a client function against a server running in another thread.+againstServer :: D.Duration -> (SC.ClientM a) -> IO (Either SC.ServantError a)+againstServer served action = let port = 8080 in do+    ready <- M.newEmptyMVar+    A.withAsync (TestServer.run port ready served) $ \_ -> do+        () <- M.takeMVar ready+        TestClient.run port action++getDur :: D.Duration -> Test+getDur expect = testCase ("getDur: " ++ show expect) $ do+    result <- againstServer expect $ TestClient.getDur+    HU.assertEqual "Client received what server served" (pure expect) result++exSec :: D.Duration -> Int -> Test+exSec sent expect = testCase ("exSec: " ++ show sent) $ do+    result <- againstServer undefined $ TestClient.exSec sent+    HU.assertEqual "Client received seconds component of posted value" (pure expect) result++exNSec :: D.Duration -> Int -> Test+exNSec sent expect = testCase ("exNSec: " ++ show sent) $ do+    result <- againstServer undefined $ TestClient.exNSec sent+    HU.assertEqual "Client received nanoseconds component of posted value" (pure expect) result

+ test/TestClient.hs view

@@ -0,0 +1,21 @@+module TestClient where++import Servant ((:>)(..), (:<|>)(..))+import qualified Network.HTTP.Client as H+import qualified Proto.Google.Protobuf.Duration as D+import qualified Servant.Client as S++import TestServer (api)++getDur :: S.ClientM D.Duration+exSec :: D.Duration -> S.ClientM Int+exNSec :: D.Duration -> S.ClientM Int++getDur :<|> exSec :<|> exNSec = S.client api++run :: Int -> S.ClientM a -> IO (Either S.ServantError a)+run port action = do+    mgr <- H.newManager H.defaultManagerSettings+    S.runClientM action (S.ClientEnv mgr baseUrl)+    where+        baseUrl = S.BaseUrl S.Http "localhost" port ""

+ test/TestServer.hs view

@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-} -- for string types and type lists+{-# LANGUAGE TypeOperators #-} -- for api appenders in types+module TestServer where++import Control.Lens ((^.))+import Servant ((:>)(..), (:<|>)(..))+import qualified Control.Concurrent.MVar as M+import qualified Network.Wai.Handler.Warp as W+import qualified Proto.Google.Protobuf.Duration as D+import qualified Servant as S++import qualified Servant.API.ContentTypes.Proto as P++-- A test server which returns protobuf from one endpoint, and receives+-- protobuf in two others.++type GetDur = "dur" :> S.Get '[P.Proto] D.Duration+type ExSec = "dur" :> "sec" :> S.ReqBody '[P.Proto] D.Duration :> S.Post '[S.JSON] Int+type ExNSec = "dur" :> "nsec" :> S.ReqBody '[P.Proto] D.Duration :> S.Post '[S.JSON] Int++type API = GetDur :<|> ExSec :<|> ExNSec++server :: D.Duration -> S.Server API+server expect = getDur expect :<|> exSec :<|> exNSec++api :: S.Proxy API+api = S.Proxy++app :: D.Duration -> S.Application+app expect = S.serve api $ server expect++run :: W.Port -> M.MVar () -> D.Duration -> IO ()+run port ready expect = W.runSettings settings $ app expect+    where+        settings+            = W.setPort port+            . W.setBeforeMainLoop (M.putMVar ready ())+            $ W.defaultSettings++-- handlers++getDur :: D.Duration -> S.Handler D.Duration+getDur expect = return expect++exSec :: D.Duration -> S.Handler Int+exSec dur = return . fromIntegral $ dur ^. D.seconds++exNSec :: D.Duration -> S.Handler Int+exNSec dur = return . fromIntegral $ dur ^. D.nanos