diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/example/Docs.hs b/example/Docs.hs new file mode 100644 --- /dev/null +++ b/example/Docs.hs @@ -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) diff --git a/example/Server.hs b/example/Server.hs --- a/example/Server.hs +++ b/example/Server.hs @@ -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 () diff --git a/servant-rawm.cabal b/servant-rawm.cabal --- a/servant-rawm.cabal +++ b/servant-rawm.cabal @@ -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 . 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 diff --git a/src/Servant/RawM.hs b/src/Servant/RawM.hs --- a/src/Servant/RawM.hs +++ b/src/Servant/RawM.hs @@ -14,6 +14,8 @@ ( -- * 'RawM' API parameter RawM + , RawM' + , FileServer -- * Helper functions for writing simple file servers , serveDirectoryWebApp , serveDirectoryFileServer diff --git a/src/Servant/RawM/Internal/API.hs b/src/Servant/RawM/Internal/API.hs --- a/src/Servant/RawM/Internal/API.hs +++ b/src/Servant/RawM/Internal/API.hs @@ -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 diff --git a/src/Servant/RawM/Internal/Client.hs b/src/Servant/RawM/Internal/Client.hs --- a/src/Servant/RawM/Internal/Client.hs +++ b/src/Servant/RawM/Internal/Client.hs @@ -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 diff --git a/src/Servant/RawM/Internal/Docs.hs b/src/Servant/RawM/Internal/Docs.hs --- a/src/Servant/RawM/Internal/Docs.hs +++ b/src/Servant/RawM/Internal/Docs.hs @@ -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 = "

Hello World

" + 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 diff --git a/src/Servant/RawM/Internal/Server.hs b/src/Servant/RawM/Internal/Server.hs --- a/src/Servant/RawM/Internal/Server.hs +++ b/src/Servant/RawM/Internal/Server.hs @@ -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