servant-rawm 0.1.0.0 → 0.2.0.0

raw patch · 9 files changed

+157/−167 lines, 9 filesdep +containersdep +lensdep ~basedep ~servantdep ~servant-docsnew-component:exe:servant-rawm-example-docsPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, lens

Dependency ranges changed: base, servant, servant-docs

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• example/Docs.hs +34/−0
• example/Server.hs +3/−3
• servant-rawm.cabal +18/−18
• src/Servant/RawM.hs +2/−0
• src/Servant/RawM/Internal/API.hs +5/−1
• src/Servant/RawM/Internal/Client.hs +7/−4
• src/Servant/RawM/Internal/Docs.hs +69/−129
• src/Servant/RawM/Internal/Server.hs +12/−12

@@ -1,4 +1,11 @@ +## 0.2.0.0++*   (commit 30a2cd48488d) Add a phantom type to `RawM` to allow the user to+    change the output documentation.+*   (commit 30a2cd48488d) Add a `HasDocs` instance for `RawM` that uses+    the `HasDocs` instance for the phantom type.+ ## 0.1.0.0  *   Initial release.

@@ -0,0 +1,34 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Data.Proxy (Proxy(Proxy))+import Data.Text (Text)+import Servant.Docs (ToSample(toSamples), docs, markdown)++import Servant.RawM ()++import Api (Api)++instance ToSample Int where+  toSamples :: Proxy Int -> [(Text, Int)]+  toSamples Proxy = [("example Int", 3)]++-- | Print the documentation rendered as markdown to stdout.+main :: IO ()+main = putStrLn . markdown $ docs (Proxy :: Proxy Api)

@@ -21,6 +21,9 @@   , configDir :: FilePath   } deriving Show +config :: Config+config = Config {configInt1 = 3, configInt2 = 4, configDir = "./example/files"}+ serverRoot :: ServerT Api (ReaderT Config IO) serverRoot = getOtherEndpoint1 :<|> rawEndpoint :<|> getOtherEndpoint2 @@ -50,9 +53,6 @@      transformation :: ReaderT Config IO a -> Handler a     transformation readerT = liftIO $ runReaderT readerT conf--config :: Config-config = Config {configInt1 = 3, configInt2 = 4, configDir = "./example/files"}  -- | Run the WAI 'Application' using 'run' on the port defined by 'port'. main :: IO ()

@@ -1,5 +1,5 @@ name:                servant-rawm-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Embed a raw 'Application' in a Servant API description:         Please see <https://github.com/cdepillabout/servant-rawm#readme README.md>. homepage:            https://github.com/cdepillabout/servant-rawm@@ -29,10 +29,12 @@                      , Servant.RawM.Internal.Server   build-depends:       base >= 4.8 && < 5                      , bytestring >= 0.10+                     , containers >= 0.5                      , filepath >= 1.4                      , http-client >= 0.5                      , http-media >= 0.6                      , http-types >= 0.9+                     , lens >= 4.0                      , resourcet >= 1.0                      , servant >= 0.9                      , servant-client >= 0.9@@ -67,24 +69,22 @@   else     buildable:         False --- executable servant-rawm-example-docs---   main-is:             Docs.hs---   other-modules:       Api---   hs-source-dirs:      example---   build-depends:       base---                      , aeson---                      , http-api-data---                      , servant---                      , servant-rawm---                      , servant-docs---                      , text---   default-language:    Haskell2010---   ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists -threaded -rtsopts -with-rtsopts=-N+executable servant-rawm-example-docs+  main-is:             Docs.hs+  other-modules:       Api+  hs-source-dirs:      example+  build-depends:       base+                     , servant+                     , servant-rawm+                     , servant-docs+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists -threaded -rtsopts -with-rtsopts=-N ---   if flag(buildexample)---     buildable:         True---   else---     buildable:         False+  if flag(buildexample)+    buildable:         True+  else+    buildable:         False  executable servant-rawm-example-server   main-is:             Server.hs

@@ -14,6 +14,8 @@   (   -- * 'RawM' API parameter     RawM+  , RawM'+  , FileServer   -- * Helper functions for writing simple file servers   , serveDirectoryWebApp   , serveDirectoryFileServer

@@ -12,4 +12,8 @@  import Data.Typeable (Typeable) -data RawM deriving Typeable+type RawM = RawM' FileServer++data RawM' serverType deriving Typeable++data FileServer deriving Typeable

@@ -25,10 +25,13 @@ import Servant.Client (Client, ClientM, HasClient(clientWithRoute)) import Servant.Common.Req (Req, performRequest) -import Servant.RawM.Internal.API (RawM)+import Servant.RawM.Internal.API (RawM') -instance HasClient RawM where-  type Client RawM = Method -> (Req -> Req) -> ClientM (Int, ByteString, MediaType, [Header], Response ByteString)+instance HasClient (RawM' serverType) where+  type Client (RawM' serverType) =+        Method+    -> (Req -> Req)+    -> ClientM (Int, ByteString, MediaType, [Header], Response ByteString) -  clientWithRoute :: Proxy RawM -> Req -> Client RawM+  clientWithRoute :: Proxy (RawM' serverType) -> Req -> Client (RawM' serverType)   clientWithRoute Proxy req method f = performRequest method $ f req

@@ -1,3 +1,7 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  {- |@@ -15,136 +19,72 @@  module Servant.RawM.Internal.Docs where --- import Data.Proxy (Proxy(Proxy))--- import Data.ByteString.Lazy (ByteString)--- import Data.Function ((&))--- import Data.Monoid ((<>))--- import Data.Text (Text)--- import Network.HTTP.Media (MediaType)--- import Servant.API (Verb, (:>))--- import Servant.API.ContentTypes (AllMimeRender(allMimeRender))--- import Servant.Docs---        (Action, API, DocOptions, Endpoint, HasDocs(docsFor),---         ToSample(toSamples))+import Control.Lens ((.~), (<>~))+import Data.Function ((&))+import Data.Proxy (Proxy(Proxy))+import Data.Semigroup ((<>))+import Network.HTTP.Media ((//))+import Network.HTTP.Types (methodGet)+import Servant.Docs+       (Action, API, DocCapture(DocCapture), DocNote(DocNote), DocOptions,+        Endpoint, HasDocs(docsFor), captures, defResponse, method, notes,+        path, respBody, respStatus, respTypes, response, single) -- import Servant.Docs.Internal (apiEndpoints, respBody, response) --- import Servant.RawM.Internal.Envelope---        (Envelope, toErrEnvelope, toSuccEnvelope)--- import Servant.RawM.Internal.Prism ((<>~))--- import Servant.RawM.Internal.Servant.API---        (NoThrow, Throws, Throwing)--- import Servant.RawM.Internal.Util (Snoc)---- -- TODO: Make sure to also account for when headers are being used.---- -- | Change a 'Throws' into 'Throwing'.--- instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where---   docsFor---     :: Proxy (Throws e :> api)---     -> (Endpoint, Action)---     -> DocOptions---     -> API---   docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[e] :> api))---- -- | When @'Throwing' es@ comes before a 'Verb', generate the documentation for--- -- the same 'Verb', but returning an @'Envelope' es@.  Also add documentation--- -- for the potential @es@.--- instance---        ( CreateRespBodiesFor es ctypes---        , HasDocs (Verb method status ctypes (Envelope es a))---        )---     => HasDocs (Throwing es :> Verb method status ctypes a) where---   docsFor---     :: Proxy (Throwing es :> Verb method status ctypes a)---     -> (Endpoint, Action)---     -> DocOptions---     -> API---   docsFor Proxy (endpoint, action) docOpts =---     let api =---           docsFor---             (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))---             (endpoint, action)---             docOpts---     in api & apiEndpoints . traverse . response . respBody <>~---         createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes)---- -- | When 'NoThrow' comes before a 'Verb', generate the documentation for--- -- the same 'Verb', but returning an @'Envelope' \'[]@.--- instance (HasDocs (Verb method status ctypes (Envelope '[] a)))---     => HasDocs (NoThrow :> Verb method status ctypes a) where---   docsFor---     :: Proxy (NoThrow :> Verb method status ctypes a)---     -> (Endpoint, Action)---     -> DocOptions---     -> API---   docsFor Proxy (endpoint, action) docOpts =---     docsFor---       (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))---       (endpoint, action)---       docOpts---- -- | Create samples for a given @list@ of types, under given @ctypes@.--- ----- -- Additional instances of this class should not need to be created.--- class CreateRespBodiesFor list ctypes where---   createRespBodiesFor---     :: Proxy list---     -> Proxy ctypes---     -> [(Text, MediaType, ByteString)]---- -- | An empty list of types has no samples.--- instance CreateRespBodiesFor '[] ctypes where---   createRespBodiesFor---     :: Proxy '[]---     -> Proxy ctypes---     -> [(Text, MediaType, ByteString)]---   createRespBodiesFor Proxy Proxy = []---- -- | Create a response body for each of the error types.--- instance---        ( AllMimeRender ctypes (Envelope '[e] ())---        , CreateRespBodiesFor es ctypes---        , ToSample e---        )---     => CreateRespBodiesFor (e ': es) ctypes where---   createRespBodiesFor---     :: Proxy (e ': es)---     -> Proxy ctypes---     -> [(Text, MediaType, ByteString)]---   createRespBodiesFor Proxy ctypes =---     createRespBodyFor (Proxy :: Proxy e) ctypes <>---     createRespBodiesFor (Proxy :: Proxy es) ctypes---- -- | Create a sample for a given @e@ under given @ctypes@.--- createRespBodyFor---   :: forall e ctypes.---      (AllMimeRender ctypes (Envelope '[e] ()), ToSample e)---   => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]--- createRespBodyFor Proxy ctypes = concatMap enc samples---     where---       samples :: [(Text, Envelope '[e] ())]---       samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e)----       enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]---       enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s+import Servant.RawM.Internal.API (FileServer, RawM') --- -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the--- -- @e@ onto the @es@.--- instance (HasDocs (Throwing (Snoc es e) :> api)) =>---     HasDocs (Throwing es :> Throws e :> api) where---   docsFor---     :: Proxy (Throwing es :> Throws e :> api)---     -> (Endpoint, Action)---     -> DocOptions---     -> API---   docsFor Proxy =---     docsFor (Proxy :: Proxy (Throwing (Snoc es e) :> api))+instance (HasDocs serverType) => HasDocs (RawM' serverType) where+  docsFor :: Proxy (RawM' serverType) -> (Endpoint, Action) -> DocOptions -> API+  docsFor Proxy (endpoint, action) docOpts =+    docsFor (Proxy :: Proxy serverType) (endpoint, action) docOpts --- -- | We can generate a sample of an @'Envelope' es a@ as long as there is a way--- -- to generate a sample of the @a@.--- ----- -- This doesn't need to worry about generating a sample of @es@, because that is--- -- taken care of in the 'HasDocs' instance for @'Throwing' es@.--- instance ToSample a => ToSample (Envelope es a) where---   toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]---   toSamples Proxy = fmap toSuccEnvelope <$> toSamples (Proxy :: Proxy a)+instance HasDocs FileServer where+  docsFor :: Proxy FileServer -> (Endpoint, Action) -> DocOptions -> API+  docsFor Proxy (endpoint, action) _ =+    let captureSymbol = ":filename"+        captureDesc = "the name of the file to GET"+        capture = DocCapture captureSymbol captureDesc+        htmlMediaType = "text" // "html"+        jsMediaType = "application" // "javascript"+        possibleRespMediaTypes =+          [ jsMediaType+          , "application" // "xml"+          , "application" // "zip"+          , "application" // "pdf"+          , "audio" // "mpeg"+          , "text" // "css"+          , htmlMediaType+          , "text" // "csv"+          , "text" // "plain"+          , "image" // "png"+          , "image" // "jpeg"+          , "image" // "gif"+          ]+        sampleHtml = "<html><body><p>Hello World</p></body></html>"+        sampleHtmlResp = ("example HTML response", htmlMediaType, sampleHtml)+        sampleJs = "alert(\"Hello World\");"+        sampleJsResp = ("example JS response", jsMediaType, sampleJs)+        noteBody1 =+          "This route is a file server.  If you specify the filename, it " <>+          "will serve up the file with the appropriate content type.  If " <>+          "the file doesn't exist, it will return a 404."+        noteBody2 =+          "The supported content types below are just examples.  A full " <>+          "list of recognized MIME types can be found " <>+          "[here](https://hackage.haskell.org/package/mime-types-0.1.0.7/docs/src/Network.Mime.html#defaultMimeMap)."+        note = DocNote "File Server" [noteBody1, noteBody2]+        resp =+          defResponse+            & respStatus .~ 200+            & respTypes .~ possibleRespMediaTypes+            & respBody .~ [sampleHtmlResp, sampleJsResp]+        newEndpoint =+          endpoint+            & method .~ methodGet+            & path <>~ [captureSymbol]+        newAction =+          action+            & captures <>~ [capture]+            & notes <>~ [note]+            & response .~ resp+    in single newEndpoint newAction

@@ -16,7 +16,7 @@ Stability   :  experimental Portability :  unknown -This module exports 'HasServer' instances for 'RawM', as well as some helper+This module exports 'HasServer' instances for 'RawM'', as well as some helper functions for serving directories of files. -} @@ -38,13 +38,13 @@ import System.FilePath (addTrailingPathSeparator) import WaiAppStatic.Storage.Filesystem (ETagLookup) -import Servant.RawM.Internal.API (RawM)+import Servant.RawM.Internal.API (RawM') -instance HasServer RawM context where-  type ServerT RawM m = m Application+instance HasServer (RawM' serverType) context where+  type ServerT (RawM' serverType) m = m Application   route     :: forall env.-       Proxy RawM+       Proxy (RawM' serverType)     -> Context context     -> Delayed env (Handler Application)     -> Router' env (Request -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived)@@ -69,10 +69,10 @@                   Right app -> app request (respond . Route)  --- | Serve anything under the specified directory as a 'RawM' endpoint.+-- | Serve anything under the specified directory as a 'RawM'' endpoint. -- -- @--- type MyApi = "static" :> RawM+-- type MyApi = "static" :> RawM' -- -- server :: ServerT MyApi m -- server = serveDirectoryWebApp "\/var\/www"@@ -91,24 +91,24 @@ -- in order. -- -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.-serveDirectoryWebApp :: Applicative m => FilePath -> ServerT RawM m+serveDirectoryWebApp :: Applicative m => FilePath -> ServerT (RawM' serverType) m serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . addTrailingPathSeparator  -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.-serveDirectoryFileServer :: Applicative m => FilePath -> ServerT RawM m+serveDirectoryFileServer :: Applicative m => FilePath -> ServerT (RawM' serverType) m serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . addTrailingPathSeparator  -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.-serveDirectoryWebAppLookup :: Applicative m => ETagLookup -> FilePath -> ServerT RawM m+serveDirectoryWebAppLookup :: Applicative m => ETagLookup -> FilePath -> ServerT (RawM' serverType) m serveDirectoryWebAppLookup etag =   serveDirectoryWith . flip webAppSettingsWithLookup etag . addTrailingPathSeparator  -- | Uses 'embeddedSettings'.-serveDirectoryEmbedded :: Applicative m => [(FilePath, ByteString)] -> ServerT RawM m+serveDirectoryEmbedded :: Applicative m => [(FilePath, ByteString)] -> ServerT (RawM' serverType) m serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)  -- | Alias for 'staticApp'. Lets you serve a directory with arbitrary -- 'StaticSettings'. Useful when you want particular settings not covered by -- the four other variants. This is the most flexible method.-serveDirectoryWith :: Applicative m => StaticSettings -> ServerT RawM m+serveDirectoryWith :: Applicative m => StaticSettings -> ServerT (RawM' serverType) m serveDirectoryWith = pure . staticApp