diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Revision history for servant-waargonaut + +## 0.5.0.0 -- 2019-01-08 + +* Bump waargonaut to version 0.5.2.1 +* Use nix overlays instead of manually composed overrides. + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,31 @@ +Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +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 QFPL 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-waargonaut.cabal b/servant-waargonaut.cabal new file mode 100644 --- /dev/null +++ b/servant-waargonaut.cabal @@ -0,0 +1,87 @@ +-- Initial servant-waargonaut.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: servant-waargonaut +version: 0.5.0.1 +synopsis: Servant Integration for Waargonaut JSON Package +description: Provides the types and instances necessary to utilise Waargonaut as the JSON handling library for your Servant API. +-- license: +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENCE + +-- The package author(s). +author: QFPL @ Data61 + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: oᴉ˙ldɟb@uɐǝs + +-- A copyright notice. +copyright: Copyright (C) 2017 Commonwealth Scientific and Industrial Research Organisation (CSIRO) + +category: Web, JSON + +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +tested-with: GHC==8.0.2 + , GHC==8.2.2 + , GHC==8.4.4 + , GHC==8.6.3 + +source-repository head + type: git + location: git@github.com/qfpl/servant-waargonaut.git + +library + exposed-modules: Servant.API.ContentTypes.Waargonaut + -- other-modules: + -- other-extensions: + build-depends: base >= 4.9 && < 4.13 + , servant >= 0.14.1 && < 0.16 + , waargonaut >= 0.5 && < 0.6 + , attoparsec >= 0.13.2 && < 0.14 + , bytestring >= 0.10.8 && < 0.11 + , text >= 1.2.3 && < 1.3 + , http-media >= 0.7.1 && < 0.8 + , lens >= 4.16.1 && < 4.18 + , wl-pprint-annotated >= 0.1.0 && < 0.2 + + hs-source-dirs: src + + default-language: Haskell2010 + ghc-options: -Wall + +test-suite saarg + -- Base language which the package is written in. + default-language: Haskell2010 + + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + ghc-options: -Wall + + other-modules: TestAPI + + build-depends: base >= 4.9 && < 4.13 + , servant-waargonaut + , servant-server + , servant >= 0.14.1 && < 0.16 + , waargonaut >= 0.5 && < 0.6 + + , attoparsec >= 0.13.2 && < 0.14 + , bytestring >= 0.10.8 && < 0.11 + , text >= 1.2.3 && < 1.3 + , http-media >= 0.7.1 && < 0.8 + , lens >= 4.16.1 && < 4.18 + , wl-pprint-annotated >= 0.1.0 && < 0.2 + + , wai + , tasty + , tasty-wai + , http-types + , transformers diff --git a/src/Servant/API/ContentTypes/Waargonaut.hs b/src/Servant/API/ContentTypes/Waargonaut.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/ContentTypes/Waargonaut.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Integrate Waargonaut with Servant, including support for the tagged typeclass encoder/decoder functionality. +module Servant.API.ContentTypes.Waargonaut ( WaargJSON ) where + +import Control.Category ((.)) +import Control.Lens (over, _Left) + +import Prelude (show) + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Encoding as TextLE + +import Data.Function (($)) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) + +import qualified Data.List.NonEmpty as NE +import qualified Network.HTTP.Media as M + +import Data.Attoparsec.ByteString (eitherResult, parse) + +import Servant.API.ContentTypes (Accept (..), MimeRender (..), + MimeUnrender (..)) + +import qualified Text.PrettyPrint.Annotated.WL as WL +import Waargonaut (parseWaargonaut) +import Waargonaut.Decode (ppCursorHistory, simpleDecode) +import Waargonaut.Decode.Error (DecodeError (ParseFailed)) + +import Waargonaut.Encode (simplePureEncodeNoSpaces) + +import Waargonaut.Generic (JsonDecode, JsonEncode, + mkDecoder, mkEncoder, proxy) + +-- | Replacement for 'Servant.API.ContentTypes.JSON' that will use the relevant instances from +-- Waargonaut that are tagged with the type @t@. +-- +-- This allows you to have separate typeclass implementations for the same type for different routes +-- and have it be evident in the types. Without the need for creating a 'newtype' for each one. +-- +-- Where you would use 'JSON' to use 'aeson' for encoding or decoding, you use 'WaargJSON t', with +-- the @t@ denoting the tag type. Refer to the +-- package for more information about why this is so. +-- +-- A hello world example: +-- +-- >>> -- GET /hello/world +-- >>> -- returning a JSON encoded World value +-- >>> data MyTag = MyTag +-- >>> type MyApi = "hello" :> "world" :> Get '[WaargJSON MyTag] World +-- +data WaargJSON t + deriving Typeable + +instance Accept (WaargJSON t) where + contentTypes _ = "application" M.// "json" M./: ("charset", "utf-8") NE.:| [ "application" M.// "json" ] + +instance JsonDecode t a => MimeUnrender (WaargJSON t) a where + mimeUnrender _ = over _Left handleErr + . simpleDecode (proxy mkDecoder (Proxy :: Proxy t)) parser + . BSL.toStrict + + where + parser = + over _Left (ParseFailed . Text.pack) + . eitherResult + . parse parseWaargonaut + + handleErr (dErr, hist) = WL.display . WL.renderPrettyDefault $ + WL.text (show dErr) WL.<##> ppCursorHistory hist + +instance JsonEncode t a => MimeRender (WaargJSON t) a where + mimeRender _ = TextLE.encodeUtf8 . simplePureEncodeNoSpaces (proxy mkEncoder (Proxy :: Proxy t)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.Proxy (Proxy (..)) + +import qualified Data.Text.Lazy.Encoding as TextLE + +import qualified Data.ByteString.Lazy as BSL +import Network.HTTP.Types (StdMethod (POST), status200) + +import qualified Waargonaut.Encode as W +import qualified Waargonaut.Generic as W + +import TestAPI (TestAARG, app, testPerson, + testPersonBS) + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.Wai (assertBody, assertStatus', + buildRequestWithHeaders, get, + srequest, testWai) + +main :: IO () +main = defaultMain $ testGroup "Servant Waargonaut" + + [ testWai app "GET '/' - 200 and contains a Waarg Encoded Person" $ do + res <- get "/" + assertBody (BSL.fromStrict testPersonBS) res + + , testWai app "POST '/' - 200 and accepts a Waarg Decoded Person" $ do + let bdy = W.simplePureEncodeNoSpaces (W.proxy W.mkEncoder (Proxy :: Proxy TestAARG)) testPerson + + res <- srequest $ buildRequestWithHeaders POST "/" + (TextLE.encodeUtf8 bdy) + [("Content-Type", "application/json")] + + assertBody "OMG" res + assertStatus' status200 res + ] diff --git a/test/TestAPI.hs b/test/TestAPI.hs new file mode 100644 --- /dev/null +++ b/test/TestAPI.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +module TestAPI + ( TestAPI + , TestAARG + , Person (..) + , testPersonBS + , testPerson + , app + ) where + +import qualified GHC.Generics as GHC + +import Data.Bool (bool) +import Data.Proxy (Proxy (..)) +import Servant.API ((:<|>) ((:<|>)), (:>), + Get, PlainText, Post, + ReqBody) +import Servant.Server (Server, serve) + +import Network.Wai (Application) + +import Data.ByteString (ByteString) +import qualified Data.Char as Char +import Data.Text (Text) +import qualified Data.Text as Text + +import Waargonaut.Generic (Generic, + HasDatatypeInfo, + JsonDecode (..), + JsonEncode (..), + Options (..), defaultOpts, + gDecoder, gEncoder) + +import Servant.API.ContentTypes.Waargonaut (WaargJSON) + +data TestAARG + +data Person = Person + { _personName :: Text + , _personAge :: Int + , _personAddress :: Text + , _personFavouriteLotteryNumbers :: [Int] + } + deriving (Eq, Show, GHC.Generic) + +instance HasDatatypeInfo Person +instance Generic Person + +personWaargOpts :: Options +personWaargOpts = defaultOpts + { _optionsFieldName = + (\n -> + maybe n (\(h',t') -> Text.unpack $ Text.cons (Char.toLower h') t') + $ Text.uncons + =<< Text.stripPrefix "_person" (Text.pack n) + ) + } + +instance JsonEncode TestAARG Person where mkEncoder = gEncoder personWaargOpts +instance JsonDecode TestAARG Person where mkDecoder = gDecoder personWaargOpts + +testPersonBS :: ByteString +testPersonBS = "{\"name\":\"Krag\",\"age\":88,\"address\":\"Red House 4, Three Neck Lane, Greentown.\",\"favouriteLotteryNumbers\":[86,3,32,42,73]}" + +testPerson :: Person +testPerson = Person "Krag" 88 "Red House 4, Three Neck Lane, Greentown." [86,3,32,42,73] + +type TestAPI = + {- | Test Encoding -} Get '[WaargJSON TestAARG] Person :<|> + {- | Test Decoding -} ReqBody '[WaargJSON TestAARG] Person :> Post '[PlainText] Text + +simpleApi :: Proxy TestAPI +simpleApi = Proxy + +server :: Server TestAPI +server = + pure testPerson :<|> + pure . bool "NOOO" "OMG" . (== testPerson) + +app :: Application +app = serve simpleApi server