summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorphadej <>2018-06-13 15:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-06-13 15:05:00 (GMT)
commit1f9aa2ae606f5bb5290559571e7b5faf5a929f44 (patch)
tree078db4f8107e8a7743b4f3392eddcce319e38d7e
version 0.10.1
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--example/Main.hs37
-rw-r--r--servant-dhall.cabal63
-rw-r--r--src/Servant/Dhall.hs128
5 files changed, 260 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..e9d0ea7
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2018, Servant Contributors
+
+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 Julian K. Arni 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
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/example/Main.hs b/example/Main.hs
new file mode 100644
index 0000000..8b50562
--- /dev/null
+++ b/example/Main.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+module Main (main) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Maybe (fromMaybe)
+import Network.Wai (Application)
+import Servant
+import Servant.Dhall
+import System.Environment (getArgs, lookupEnv)
+import Text.Read (readMaybe)
+
+import qualified Network.Wai.Handler.Warp as Warp
+
+type API = "post" :> ReqBody '[DHALL] [Integer] :> Post '[DHALL] [Integer]
+ :<|> "get" :> Get '[DHALL] [Integer]
+
+api :: Proxy API
+api = Proxy
+
+server :: Server API
+server = pure . map (+1) :<|> pure [1..10]
+
+app :: Application
+app = serve api server
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ("run":_) -> do
+ port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
+ Warp.run port app
+ _ -> putStrLn "To run, pass run argument"
diff --git a/servant-dhall.cabal b/servant-dhall.cabal
new file mode 100644
index 0000000..9932bf7
--- /dev/null
+++ b/servant-dhall.cabal
@@ -0,0 +1,63 @@
+name: servant-dhall
+version: 0.1
+synopsis: Servant Dhall content-type
+description:
+ Servant Dhall bindings.
+ .
+ Provides @MineRender@ and @MimeUnrender@ instances.
+ So you can accept and return Dhall expressions.
+ .
+ /Note:/ Reading (and evaluating) Dhall expressions from untrust4ed source is a security risk.
+homepage: http://haskell-servant.readthedocs.org/
+license: BSD3
+license-file: LICENSE
+author: Servant Contributors
+maintainer: haskell-servant-maintainers@googlegroups.com
+copyright: 2015-2016 Servant Contributors
+category: Web, Servant, Dhall
+build-type: Simple
+cabal-version: >=1.10
+bug-reports: http://github.com/haskell-servant/servant-dhall/issues
+tested-with:
+ GHC==8.0.2,
+ GHC==8.2.2,
+ GHC==8.4.3
+
+source-repository head
+ type: git
+ location: http://github.com/haskell-servant/servant-dhall.git
+
+library
+ exposed-modules: Servant.Dhall
+ build-depends: base >=4.9 && <4.12
+ , base-compat >=0.10.1 && <0.11
+ , bytestring >=0.10.4.0 && <0.11
+ , dhall >=1.14.0 && <1.15
+ , formatting >=6.3.4 && <6.4
+ , megaparsec >=6.5.0 && <6.6
+ , prettyprinter >=1.2.0.1 && <1.3
+ , servant >=0.13 && <0.14
+ , text >=1.2.3.0 && <1.3
+ , http-media
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+test-suite example
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs:
+ example
+ ghc-options: -Wall
+ build-depends:
+ base
+ , base-compat
+ , bytestring
+ , dhall
+ , http-media
+ , servant
+ , servant-dhall
+ , servant-server >=0.12 && <0.15
+ , wai >=3.0.3.0 && <3.3
+ , warp >=3.0.13.1 && <3.3
+ default-language: Haskell2010
diff --git a/src/Servant/Dhall.hs b/src/Servant/Dhall.hs
new file mode 100644
index 0000000..75c3a33
--- /dev/null
+++ b/src/Servant/Dhall.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | A @DHALL@ empty datatype with `MimeRender` and `MimeUnrender` instances for
+-- /Dhall/'s 'Interpret' and 'Inject' classes.
+--
+-- >>> type Eg = Get '[DHALL] Integer
+--
+-- /Note:/ reading and executing Dhall expressions from untrusted source is
+-- a security risk.
+--
+module Servant.Dhall (
+ DHALL,
+ DHALL',
+ HasInterpretOptions,
+ DefaultInterpretOptions,
+ ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad
+ (unless)
+import Data.Proxy
+ (Proxy (..))
+import Data.Text.Encoding.Error
+ (lenientDecode)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Data.Text.Lazy.Encoding as TLE
+import Data.Text.Prettyprint.Doc
+ (defaultLayoutOptions, layoutPretty, layoutSmart, line)
+import Data.Text.Prettyprint.Doc.Render.String
+ (renderString)
+import Data.Text.Prettyprint.Doc.Render.Text
+ (renderLazy)
+import Data.Traversable
+ (for)
+import Data.Typeable
+ (Typeable)
+import Dhall
+ (Inject (..), InputType (..), Interpret (..),
+ InterpretOptions, Type (..), defaultInterpretOptions)
+import qualified Dhall.Core
+import Dhall.Parser
+ (exprFromText, unwrap)
+import Dhall.Pretty
+ (prettyExpr)
+import qualified Dhall.TypeCheck
+import Formatting.Buildable
+ (Buildable (..))
+import qualified Network.HTTP.Media as M
+import Servant.API
+ (Accept (..), MimeRender (..), MimeUnrender (..))
+import qualified Text.Megaparsec as MP
+
+type DHALL = DHALL' DefaultInterpretOptions
+data DHALL' opt deriving (Typeable)
+
+instance Accept (DHALL' opts) where
+ contentType _ = "application" M.// "x-dhall"
+
+-------------------------------------------------------------------------------
+-- Encoding
+-------------------------------------------------------------------------------
+
+instance (Inject a, HasInterpretOptions opts) => MimeRender (DHALL' opts) a where
+ mimeRender _ x
+ = TLE.encodeUtf8
+ $ renderLazy
+ $ layoutSmart defaultLayoutOptions
+ $ (`mappend` line)
+ $ prettyExpr
+ $ embed ty x
+ where
+ ty :: InputType a
+ ty = injectWith (interpretOptions (Proxy :: Proxy opts))
+
+-------------------------------------------------------------------------------
+-- Decoding
+-------------------------------------------------------------------------------
+
+instance (Interpret a, HasInterpretOptions opts) => MimeUnrender (DHALL' opts) a where
+ mimeUnrender _ lbs = do
+ expr0 <- firstEither showParseError $ exprFromText "(input)" te
+ expr1 <- for expr0 $ \i -> Left $ "Import found: " ++ fromBuildable i
+ tyExpr <- firstEither showTypeError $ Dhall.TypeCheck.typeOf expr1
+ unless (Dhall.Core.judgmentallyEqual tyExpr $ expected ty) $
+ Left $ "Expected and actual types don't match : "
+ ++ ppExpr (expected ty) ++ " /= " ++ ppExpr tyExpr
+ case extract ty (Dhall.Core.normalizeWith (const Nothing) expr1) of
+ Just x -> Right x
+ Nothing -> Left "Invalid type"
+ where
+ showParseError = MP.parseErrorPretty . unwrap
+ showTypeError e = "Type error: " ++ fromBuildable e
+
+ te = TLE.decodeUtf8With lenientDecode lbs
+
+ ty :: Type a
+ ty = autoWith (interpretOptions (Proxy :: Proxy opts))
+
+ ppExpr = renderString . layoutPretty defaultLayoutOptions . prettyExpr
+
+ fromBuildable :: Buildable b => b -> String
+ fromBuildable = TL.unpack . TLB.toLazyText . build
+
+firstEither :: (a -> b) -> Either a c -> Either b c
+firstEither f (Left a) = Left (f a)
+firstEither _ (Right c) = Right c
+
+-------------------------------------------------------------------------------
+-- Options
+-------------------------------------------------------------------------------
+
+class HasInterpretOptions opts where
+ interpretOptions :: Proxy opts -> InterpretOptions
+
+-- | 'defaultInterpretOptions'
+data DefaultInterpretOptions deriving (Typeable)
+
+instance HasInterpretOptions DefaultInterpretOptions where
+ interpretOptions _ = defaultInterpretOptions