diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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