diff --git a/API.md b/API.md
deleted file mode 100644
--- a/API.md
+++ /dev/null
@@ -1,131 +0,0 @@
-## Mellon API
-
-
-## GET /state
-
-#### Authentication
-
-
-
-Clients must supply the following data
-
-
-#### Response:
-
-- Status code 200
-- Headers: []
-
-- Supported content types are:
-
- - `application/json`
- - `text/html;charset=utf-8`
-
-- Locked
-
-```javascript
-{"state":"Locked","until":[]}
-```
-
-- Locked
-
-```html
-Mellon stateLocked
-```
-
-- Unlocked until a given date
-
-```javascript
-{"state":"Unlocked","until":"2015-10-06T00:00:00Z"}
-```
-
-- Unlocked until a given date
-
-```html
-Mellon stateUnlocked until 2015-10-06 00:00:00 UTC
-```
-
-## PUT /state
-
-#### Authentication
-
-
-
-Clients must supply the following data
-
-
-#### Request:
-
-- Supported content types are:
-
- - `application/json`
-
-- Example: `application/json`
-
-```javascript
-{"state":"Locked","until":[]}
-```
-
-#### Response:
-
-- Status code 200
-- Headers: []
-
-- Supported content types are:
-
- - `application/json`
- - `text/html;charset=utf-8`
-
-- Locked
-
-```javascript
-{"state":"Locked","until":[]}
-```
-
-- Locked
-
-```html
-Mellon stateLocked
-```
-
-- Unlocked until a given date
-
-```javascript
-{"state":"Unlocked","until":"2015-10-06T00:00:00Z"}
-```
-
-- Unlocked until a given date
-
-```html
-Mellon stateUnlocked until 2015-10-06 00:00:00 UTC
-```
-
-## GET /time
-
-#### Authentication
-
-
-
-Clients must supply the following data
-
-
-#### Response:
-
-- Status code 200
-- Headers: []
-
-- Supported content types are:
-
- - `application/json`
- - `text/html;charset=utf-8`
-
-- 2015-10-06
-
-```javascript
-"2015-10-06T00:00:00Z"
-```
-
-- 2015-10-06
-
-```html
-Server timeServer time is 2015-10-06 00:00:00 UTC
-```
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,3 +1,9 @@
+## 0.7.1.0 (2017-04-28)
+
+- Now requires servant-client >= 0.9.
+
+- Bump various dependency upper bounds.
+
## 0.7.0.3 (2016-09-23)
- Bump servant upper bounds.
diff --git a/examples/GpioServer.hs b/examples/GpioServer.hs
--- a/examples/GpioServer.hs
+++ b/examples/GpioServer.hs
@@ -6,10 +6,11 @@
module Main where
import Control.Monad.IO.Class (liftIO)
+import Data.Monoid ((<>))
import Data.Time.Clock (NominalDiffTime)
import Mellon.Controller (Device(..), controller)
import Mellon.Device.GPIO (sysfsGpioDevice)
-import Mellon.Web.Server.DocsAPI (docsApp)
+import Mellon.Web.Server (swaggerApp)
import Network (PortID(..), listenOn)
import Network.Wai.Handler.Warp (defaultSettings, runSettingsSocket, setHost, setPort)
import Options.Applicative
@@ -70,7 +71,7 @@
runTCPServer minUnlock device port =
do cc <- controller (Just minUnlock) device
sock <- listenOn (PortNumber (fromIntegral port))
- runSettingsSocket (setPort port $ setHost "*" defaultSettings) sock (docsApp cc)
+ runSettingsSocket (setPort port $ setHost "*" defaultSettings) sock (swaggerApp cc)
run :: GlobalOptions -> IO ()
run (GlobalOptions listenPort minUnlockTime activeLow (Sysfs (SysfsOptions pinNumber))) =
diff --git a/examples/MockServer.hs b/examples/MockServer.hs
--- a/examples/MockServer.hs
+++ b/examples/MockServer.hs
@@ -4,7 +4,7 @@
import Mellon.Controller (controller)
import Mellon.Device (mockLock, mockLockDevice)
-import Mellon.Web.Server (docsApp)
+import Mellon.Web.Server (swaggerApp)
import Network.Wai.Handler.Warp (run)
main :: IO ()
@@ -12,4 +12,4 @@
do ml <- mockLock
cc <- controller Nothing $ mockLockDevice ml
putStrLn "Running on port 8081"
- run 8081 $ docsApp cc
+ run 8081 $ swaggerApp cc
diff --git a/examples/ScheduleUnlock.hs b/examples/ScheduleUnlock.hs
--- a/examples/ScheduleUnlock.hs
+++ b/examples/ScheduleUnlock.hs
@@ -17,8 +17,8 @@
module Main where
import Control.Monad.Catch.Pure (runCatch)
-import Control.Monad.Trans.Except (runExceptT)
import Data.ByteString.Char8 as C8 (unpack)
+import Data.Monoid ((<>))
import Data.Time.Clock
(NominalDiffTime, UTCTime(..), addUTCTime)
import qualified Data.Time.LocalTime as Time
@@ -29,7 +29,9 @@
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (Status(..))
import Options.Applicative
-import Servant.Client (BaseUrl, ServantError(..), parseBaseUrl)
+import Servant.Client
+ (BaseUrl, ClientEnv(..), ServantError(..), parseBaseUrl,
+ runClientM)
import System.Exit (ExitCode(..), exitWith)
data GlobalOptions =
@@ -100,13 +102,14 @@
then Unlocked end
else Locked
in do manager <- newManager tlsManagerSettings
- runExceptT (putState state manager url) >>= \case
- Right status ->
- do putStrLn $ show status
- exitWith ExitSuccess
- Left e ->
- do putStrLn $ "Mellon service error: " ++ prettyServantError e
- exitWith $ ExitFailure 1
+ let clientEnv = ClientEnv manager url
+ runClientM (putState state) clientEnv >>= \case
+ Right status ->
+ do putStrLn $ show status
+ exitWith ExitSuccess
+ Left e ->
+ do putStrLn $ "Mellon service error: " ++ prettyServantError e
+ exitWith $ ExitFailure 1
prettyServantError :: ServantError -> String
prettyServantError (FailureResponse status _ _) =
show (statusCode status) ++ " " ++ (C8.unpack $ statusMessage status)
diff --git a/mellon-web.cabal b/mellon-web.cabal
--- a/mellon-web.cabal
+++ b/mellon-web.cabal
@@ -1,5 +1,5 @@
Name: mellon-web
-Version: 0.7.0.3
+Version: 0.7.1.0
Cabal-Version: >= 1.10
Build-Type: Simple
Author: Drew Hess
@@ -10,7 +10,7 @@
License: BSD3
License-File: LICENSE
Copyright: Copyright (c) 2016, Drew Hess
-Tested-With: GHC == 7.10.3, GHC == 8.0.1
+Tested-With: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2
Category: Web
Synopsis: A REST web service for Mellon controllers
Description:
@@ -39,12 +39,17 @@
Note that the @mellon-web@ server does not provide an authentication
mechanism! You should proxy it behind a secure, authenticating HTTPS
server such as Nginx.
-Extra-Doc-Files: API.md
- , README.md
+Extra-Doc-Files: README.md
+ , swagger.json
Extra-Source-Files: changelog.md
, examples/*.hs
, mellon-web.paw
+-- Build doctests
+Flag test-doctests
+ Default: True
+ Manual: True
+
-- Build hlint test
Flag test-hlint
Default: True
@@ -74,24 +79,29 @@
Exposed-Modules: Mellon.Web.Client
, Mellon.Web.Server
, Mellon.Web.Server.API
- , Mellon.Web.Server.DocsAPI
+ , Mellon.Web.Server.SwaggerAPI
Other-Extensions: DataKinds
, DeriveGeneric
, MultiParamTypeClasses
, OverloadedStrings
, TypeOperators
- Build-Depends: base >= 4.8 && < 5
- , aeson == 0.11.*
+ Build-Depends: base >= 4.8 && < 5
+ , aeson >= 0.11 && < 1.3
+ , aeson-pretty
, bytestring == 0.10.*
- , http-client == 0.4.*
+ , http-client >= 0.4 && < 0.6
, http-types == 0.9.*
+ , lens
, lucid == 2.9.*
, mellon-core == 0.7.*
- , servant >= 0.7.1 && < 0.10
- , servant-client >= 0.7.1 && < 0.10
- , servant-docs >= 0.7.1 && < 0.10
+ , servant >= 0.9 && < 0.10
+ , servant-client >= 0.9 && < 0.10
+ , servant-docs >= 0.9 && < 0.10
, servant-lucid >= 0.7.1 && < 0.10
- , servant-server >= 0.7.1 && < 0.10
+ , servant-server >= 0.9 && < 0.10
+ , servant-swagger
+ , servant-swagger-ui
+ , swagger2
, text == 1.2.*
, time >= 1.5 && < 2
, transformers >= 0.4.2 && < 0.6
@@ -132,7 +142,7 @@
, mellon-web
, mtl
, network == 2.6.*
- , optparse-applicative >= 0.11.0 && < 0.13
+ , optparse-applicative >= 0.11.0 && < 0.14
, time
, transformers
, warp
@@ -176,6 +186,20 @@
Build-Depends: base
, hlint == 1.9.*
+Test-Suite doctest
+ Type: exitcode-stdio-1.0
+ Default-Language: Haskell2010
+ Hs-Source-Dirs: test
+ Ghc-Options: -Wall -threaded
+ If impl(ghc > 8)
+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints
+ Main-Is: doctest.hs
+ If !flag(test-doctests)
+ Buildable: False
+ Else
+ Build-Depends: base
+ , doctest >= 0.10.1 && < 1
+
Test-Suite spec
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
@@ -185,12 +209,16 @@
Main-Is: Main.hs
Other-Extensions: ScopedTypeVariables
Build-Depends: base
+ , QuickCheck
+ , quickcheck-instances
, aeson
+ , aeson-pretty
, bytestring
- , hspec == 2.2.*
- , hspec-wai >= 0.6.6 && < 0.7
+ , hspec >= 2.2 && < 2.5
+ , hspec-wai >= 0.6.6 && < 0.9
, http-client
, http-types
+ , lens
, lucid
, mellon-core
, network
@@ -199,6 +227,9 @@
, servant-docs
, servant-lucid
, servant-server
+ , servant-swagger
+ , servant-swagger-ui
+ , swagger2
, text
, time
, transformers
@@ -208,10 +239,11 @@
Other-Modules: Mellon.Web.Client
, Mellon.Web.Server
, Mellon.Web.Server.API
- , Mellon.Web.Server.DocsAPI
+ , Mellon.Web.Server.SwaggerAPI
, Spec
, Mellon.Web.ClientSpec
, Mellon.Web.ServerSpec
+ , Mellon.Web.SwaggerAPISpec
Source-Repository head
Type: git
@@ -220,4 +252,4 @@
Source-Repository this
Type: git
Location: git://github.com/dhess/mellon.git
- Tag: v0.7.0.3
+ Tag: v0.7.1.0
diff --git a/src/Mellon/Web/Client.hs b/src/Mellon/Web/Client.hs
--- a/src/Mellon/Web/Client.hs
+++ b/src/Mellon/Web/Client.hs
@@ -41,11 +41,9 @@
, Time(..)
) where
-import Control.Monad.Trans.Except (ExceptT)
import Data.Proxy (Proxy(..))
-import Network.HTTP.Client (Manager)
import Servant.API ((:<|>)(..))
-import Servant.Client (BaseUrl, ServantError, client)
+import Servant.Client (ClientM, client)
import Mellon.Web.Server (MellonAPI, State(..), Time(..))
@@ -55,13 +53,13 @@
-- | Get the server's time. This action is provided chiefly to verify
-- the accuracy of the server's clock.
-getTime :: Manager -> BaseUrl -> ExceptT ServantError IO Time
+getTime :: ClientM Time
-- | Get the current state of the server's
-- 'Mellon.Controller.Controller'.
-getState :: Manager -> BaseUrl -> ExceptT ServantError IO State
+getState :: ClientM State
-- | Lock or unlock the server's 'Mellon.Controller.Controller'.
-putState :: State -> Manager -> BaseUrl -> ExceptT ServantError IO State
+putState :: State -> ClientM State
getTime :<|> getState :<|> putState = client clientAPI
diff --git a/src/Mellon/Web/Server.hs b/src/Mellon/Web/Server.hs
--- a/src/Mellon/Web/Server.hs
+++ b/src/Mellon/Web/Server.hs
@@ -12,11 +12,8 @@
-}
module Mellon.Web.Server
- ( -- * The standard server API
- module Mellon.Web.Server.API
- -- * The standard server API with self-hosted documentation
- , module Mellon.Web.Server.DocsAPI
- ) where
+ ( module X
+ ) where
-import Mellon.Web.Server.API
-import Mellon.Web.Server.DocsAPI
+import Mellon.Web.Server.API as X
+import Mellon.Web.Server.SwaggerAPI as X
diff --git a/src/Mellon/Web/Server/API.hs b/src/Mellon/Web/Server/API.hs
--- a/src/Mellon/Web/Server/API.hs
+++ b/src/Mellon/Web/Server/API.hs
@@ -17,9 +17,13 @@
-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Mellon.Web.Server.API
@@ -34,13 +38,24 @@
, server
) where
+import Control.Lens ((&), (.~), (?~), mapped)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.IO.Class (MonadIO, liftIO)
+import qualified Data.Aeson.Types as Aeson (Value(String))
import Data.Aeson.Types
- (FromJSON(..), ToJSON(..), Options(..), SumEncoding(TaggedObject),
- defaultOptions, genericToJSON, genericParseJSON, tagFieldName,
- contentsFieldName)
+ ((.=), (.:), (.:?), FromJSON(..), Pair, Series, ToJSON(..),
+ Value(Object), defaultOptions, genericToJSON, genericParseJSON,
+ object, pairs, typeMismatch)
+import Data.Data
+import Data.Maybe (maybe)
+import Data.Monoid ((<>))
+import Data.Swagger
+ (NamedSchema(..), Referenced(Inline), SwaggerType(..),
+ ToSchema(..), declareSchemaRef, defaultSchemaOptions, description,
+ enum_, example, genericDeclareNamedSchema, properties, required,
+ schema, type_)
+import Data.Text (Text)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime(..), getCurrentTime)
import GHC.Generics
@@ -56,6 +71,11 @@
import Servant.Docs (ToSample(..))
import Servant.HTML.Lucid (HTML)
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Data.Aeson (eitherDecode, encode)
+-- >>> import Data.Swagger.Schema.Validation
+
wrapBody :: Monad m => HtmlT m () -> HtmlT m a -> HtmlT m a
wrapBody title body =
doctypehtml_ $
@@ -68,24 +88,107 @@
data State
= Locked
| Unlocked !UTCTime
- deriving (Eq,Show,Generic)
+ deriving (Eq, Data, Read, Show, Generic, Typeable)
stateToState :: Controller.State -> State
stateToState Controller.StateLocked = Locked
stateToState (Controller.StateUnlocked date) = Unlocked date
-stateJSONOptions :: Options
-stateJSONOptions = defaultOptions {sumEncoding = taggedObject}
- where taggedObject =
- TaggedObject {tagFieldName = "state"
- ,contentsFieldName = "until"}
+lockedName :: Text
+lockedName = "Locked"
+unlockedName :: Text
+unlockedName = "Unlocked"
+
+untilName :: Text
+untilName = "until"
+
+stateName :: Text
+stateName = "state"
+
+lockedPair :: Pair
+lockedPair = stateName .= lockedName
+
+unlockedPair :: Pair
+unlockedPair = stateName .= unlockedName
+
+untilPair :: UTCTime -> Pair
+untilPair t = untilName .= t
+
+lockedSeries :: Series
+lockedSeries = stateName .= lockedName
+
+unlockedSeries :: Series
+unlockedSeries = stateName .= unlockedName
+
+untilSeries :: UTCTime -> Series
+untilSeries t = untilName .= t
+
+-- $
+-- >>> toJSON Locked
+-- Object (fromList [("state",String "Locked")])
+-- >>> toJSON $ Unlocked sampleDate
+-- Object (fromList [("state",String "Unlocked"),("until",String "2015-10-06T00:00:00Z")])
+-- >>> encode $ toJSON Locked
+-- "{\"state\":\"Locked\"}"
+-- >>> encode $ toJSON $ Unlocked sampleDate
+-- "{\"state\":\"Unlocked\",\"until\":\"2015-10-06T00:00:00Z\"}"
instance ToJSON State where
- toJSON = genericToJSON stateJSONOptions
+ toJSON Locked = object [lockedPair]
+ toJSON (Unlocked time) = object [unlockedPair, untilPair time]
+ toEncoding Locked = pairs lockedSeries
+ toEncoding (Unlocked time) = pairs $ unlockedSeries <> untilSeries time
+-- $
+-- >>> (eitherDecode $ encode $ toJSON $ Unlocked sampleDate) :: Either String State
+-- Right (Unlocked 2015-10-06 00:00:00 UTC)
+-- >>> (eitherDecode $ encode $ toJSON Locked) :: Either String State
+-- Right Locked
+-- >>> eitherDecode $ "{\"state\":\"Unlocked\"}" :: Either String State
+-- Left "Error in $: 'Unlocked' state requires an expiration date"
+-- >>> eitherDecode $ "{\"state\":\"Locked\",\"until\":\"2015-10-06T00:00:00Z\"}" :: Either String State
+-- Left "Error in $: 'Locked' state takes no argument"
+-- >>> eitherDecode $ "{\"state\":\"Unlocked\",\"until\":\"2015\"}" :: Either String State
+-- Left "Error in $.until: could not parse date: '-': not enough input"
+-- >>> eitherDecode $ "{\"state\":\"Lokced\"}" :: Either String State -- note: typo
+-- Left "Error in $: Invalid 'state' value"
instance FromJSON State where
- parseJSON = genericParseJSON stateJSONOptions
+ parseJSON (Object v) = do
+ state :: Text <- v .: stateName
+ until_ :: Maybe Time <- v .:? untilName
+ case state of
+ "Locked" ->
+ maybe
+ (pure Locked)
+ (const $ fail "'Locked' state takes no argument")
+ until_
+ "Unlocked" ->
+ maybe
+ (fail "'Unlocked' state requires an expiration date")
+ (\(Time t) -> pure $ Unlocked t)
+ until_
+ _ -> fail "Invalid 'state' value"
+ parseJSON invalid = typeMismatch "State" invalid
+-- $
+-- >>> validateToJSON Locked
+-- []
+-- >>> validateToJSON $ Unlocked sampleDate
+-- []
+instance ToSchema State where
+ declareNamedSchema _ = do
+ utcTimeSchema <- declareSchemaRef (Proxy :: Proxy UTCTime)
+ let stateSchema =
+ mempty & enum_ ?~ [Aeson.String lockedName, Aeson.String unlockedName]
+ & type_ .~ SwaggerString
+ return $
+ NamedSchema (Just "State") $
+ mempty & type_ .~ SwaggerObject
+ & properties .~ [(stateName, Inline stateSchema), (untilName, utcTimeSchema)]
+ & required .~ [stateName]
+ & description ?~ "The controller state; a variant type."
+ & example ?~ toJSON (Unlocked sampleDate)
+
sampleDate :: UTCTime
sampleDate = UTCTime { utctDay = fromGregorian 2015 10 06, utctDayTime = 0 }
@@ -105,13 +208,24 @@
-- | A newtype wrapper around 'UTCTime', for serving HTML without
-- orphan instances.
-newtype Time = Time UTCTime deriving (Eq, Show, Generic)
+newtype Time =
+ Time UTCTime
+ deriving (Eq, Data, Ord, Read, Show, Generic, Typeable)
instance ToJSON Time where
toJSON = genericToJSON defaultOptions
instance FromJSON Time where
parseJSON = genericParseJSON defaultOptions
+
+-- $
+-- >>> validateToJSON sampleDate
+-- []
+instance ToSchema Time where
+ declareNamedSchema proxy =
+ genericDeclareNamedSchema defaultSchemaOptions proxy
+ & mapped.schema.description ?~ "A UTC date"
+ & mapped.schema.example ?~ toJSON sampleDate
instance ToSample Time where
toSamples _ = [("2015-10-06",Time sampleDate)]
diff --git a/src/Mellon/Web/Server/DocsAPI.hs b/src/Mellon/Web/Server/DocsAPI.hs
deleted file mode 100644
--- a/src/Mellon/Web/Server/DocsAPI.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-|
-Module : Mellon.Web.Server.DocsAPI
-Description : A documentation-annotated REST web service for @mellon-core@ controllers
-Copyright : (c) 2016, Drew Hess
-License : BSD3
-Maintainer : Drew Hess
-Stability : experimental
-Portability : non-portable
-
-This module extends the standard 'MellonAPI' with a documentation
-resource, in case you want to provide on-line documentation for the
-API. In every other way, it is identical to the 'MellonAPI' service.
-
--}
-
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Mellon.Web.Server.DocsAPI
- ( -- * Types
- DocsAPI
-
- -- * Servant / WAI functions
- , docsAPI
- , docsApp
- , docsServer
- ) where
-
-import Data.ByteString.Lazy (ByteString)
-import Data.Text.Lazy (pack)
-import Data.Text.Lazy.Encoding (encodeUtf8)
-import Mellon.Controller (Controller)
-import Network.HTTP.Types (ok200)
-import Network.Wai (Application, responseLBS)
-import Servant ((:>), (:<|>)(..), Raw, Proxy(..), Server, serve)
-import Servant.Docs (DocIntro(..), docsWithIntros, markdown)
-
-import Mellon.Web.Server.API (MellonAPI, mellonAPI, server)
-
--- | Extends 'MellonAPI' with a documentation resource.
---
--- The documentation resource is available via the @GET /docs@ method.
-type DocsAPI = MellonAPI :<|> "docs" :> Raw
-
--- | A 'Proxy' for 'DocsAPI', exported in order to make it possible to
--- extend the API.
-docsAPI :: Proxy DocsAPI
-docsAPI = Proxy
-
-docsBS :: ByteString
-docsBS = encodeUtf8 . pack . markdown $ docsWithIntros [intro] mellonAPI
- where
- intro = DocIntro "Mellon API" []
-
--- | A 'Server' which serves the 'DocsAPI' on the given 'Controller'.
---
--- Normally you will just use 'docsApp', but this function is exported so
--- that you can extend/wrap 'DocsAPI'.
-docsServer :: Controller d -> Server DocsAPI
-docsServer cc = server cc :<|> serveDocs
- where
- serveDocs _ respond =
- respond $ responseLBS ok200 [plain] docsBS
-
- plain = ("Content-Type", "text/plain")
-
--- | A WAI 'Network.Wai.Application' which runs the service, using the
--- given 'Controller'
-docsApp :: Controller d -> Application
-docsApp = serve docsAPI . docsServer
diff --git a/src/Mellon/Web/Server/SwaggerAPI.hs b/src/Mellon/Web/Server/SwaggerAPI.hs
new file mode 100644
--- /dev/null
+++ b/src/Mellon/Web/Server/SwaggerAPI.hs
@@ -0,0 +1,77 @@
+{-|
+Module : Mellon.Web.Server.SwaggerAPI
+Description : A Swagger-enhanced REST web service for @mellon-core@ controllers
+Copyright : (c) 2016, Drew Hess
+License : BSD3
+Maintainer : Drew Hess
+Stability : experimental
+Portability : non-portable
+
+This module extends the standard 'MellonAPI' with a Swagger resource.
+In every other way, it is identical to the 'MellonAPI' service.
+
+-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Mellon.Web.Server.SwaggerAPI
+ ( -- * Types
+ SwaggerAPI
+
+ -- * Servant / WAI functions
+ , swaggerAPI
+ , swaggerApp
+ , swaggerServer
+
+ -- * Swagger meta-data
+ , mellonSwagger
+
+ -- * Convenience functions
+ , writeSwaggerJSON
+ ) where
+
+import Control.Lens ((&), (.~), (?~))
+import Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.ByteString.Lazy.Char8 as C8 (writeFile)
+import Data.Swagger
+ (Swagger, URL(..), description, info, license, title, url, version)
+import Mellon.Controller (Controller)
+import Network.Wai (Application)
+import Servant ((:<|>)(..), Proxy(..), Server, serve)
+import Servant.Swagger (toSwagger)
+import Servant.Swagger.UI (SwaggerSchemaUI, swaggerSchemaUIServer)
+
+import Mellon.Web.Server.API (MellonAPI, mellonAPI, server)
+
+-- | Extends 'MellonAPI' with a Swagger resource.
+type SwaggerAPI = MellonAPI :<|> SwaggerSchemaUI "swagger-ui" "swagger.json"
+
+-- | A 'Proxy' for 'SwaggerAPI', exported in order to make it possible
+-- to extend the API further.
+swaggerAPI :: Proxy SwaggerAPI
+swaggerAPI = Proxy
+
+-- | A 'Server' which serves the 'SwaggerAPI' on the given
+-- 'Controller'.
+--
+-- Normally you will just use 'swaggerApp', but this function is
+-- exported so that you can extend/wrap 'SwaggerAPI'.
+swaggerServer :: Controller d -> Server SwaggerAPI
+swaggerServer cc = server cc :<|> swaggerSchemaUIServer mellonSwagger
+
+-- | A WAI 'Network.Wai.Application' which runs the service, using the
+-- given 'Controller'
+swaggerApp :: Controller d -> Application
+swaggerApp = serve swaggerAPI . swaggerServer
+
+mellonSwagger :: Swagger
+mellonSwagger = toSwagger mellonAPI
+ & info.title .~ "Mellon API"
+ & info.version .~ "1.0"
+ & info.description ?~ "Control physical access devices"
+ & info.license ?~ ("BSD3" & url ?~ URL "https://opensource.org/licenses/BSD-3-Clause")
+
+writeSwaggerJSON :: IO ()
+writeSwaggerJSON = C8.writeFile "swagger.json" (encodePretty mellonSwagger)
diff --git a/swagger.json b/swagger.json
new file mode 100644
--- /dev/null
+++ b/swagger.json
@@ -0,0 +1,112 @@
+{
+ "swagger": "2.0",
+ "info": {
+ "version": "1.0",
+ "title": "Mellon API",
+ "license": {
+ "url": "https://opensource.org/licenses/BSD-3-Clause",
+ "name": "BSD3"
+ },
+ "description": "Control physical access devices"
+ },
+ "definitions": {
+ "State": {
+ "example": {
+ "state": "Unlocked",
+ "until": "2015-10-06T00:00:00Z"
+ },
+ "required": [
+ "state"
+ ],
+ "type": "object",
+ "description": "The controller state; a variant type.",
+ "properties": {
+ "state": {
+ "type": "string",
+ "enum": [
+ "Locked",
+ "Unlocked"
+ ]
+ },
+ "until": {
+ "$ref": "#/definitions/UTCTime"
+ }
+ }
+ },
+ "Time": {
+ "example": "2015-10-06T00:00:00Z",
+ "format": "yyyy-mm-ddThh:MM:ssZ",
+ "type": "string",
+ "description": "A UTC date"
+ },
+ "UTCTime": {
+ "example": "2016-07-22T00:00:00Z",
+ "format": "yyyy-mm-ddThh:MM:ssZ",
+ "type": "string"
+ }
+ },
+ "paths": {
+ "/state": {
+ "get": {
+ "responses": {
+ "200": {
+ "schema": {
+ "$ref": "#/definitions/State"
+ },
+ "description": ""
+ }
+ },
+ "produces": [
+ "application/json",
+ "text/html;charset=utf-8"
+ ]
+ },
+ "put": {
+ "consumes": [
+ "application/json"
+ ],
+ "responses": {
+ "400": {
+ "description": "Invalid `body`"
+ },
+ "200": {
+ "schema": {
+ "$ref": "#/definitions/State"
+ },
+ "description": ""
+ }
+ },
+ "produces": [
+ "application/json",
+ "text/html;charset=utf-8"
+ ],
+ "parameters": [
+ {
+ "required": true,
+ "schema": {
+ "$ref": "#/definitions/State"
+ },
+ "in": "body",
+ "name": "body"
+ }
+ ]
+ }
+ },
+ "/time": {
+ "get": {
+ "responses": {
+ "200": {
+ "schema": {
+ "$ref": "#/definitions/Time"
+ },
+ "description": ""
+ }
+ },
+ "produces": [
+ "application/json",
+ "text/html;charset=utf-8"
+ ]
+ }
+ }
+ }
+}
diff --git a/test/Mellon/Web/ClientSpec.hs b/test/Mellon/Web/ClientSpec.hs
--- a/test/Mellon/Web/ClientSpec.hs
+++ b/test/Mellon/Web/ClientSpec.hs
@@ -1,7 +1,6 @@
module Mellon.Web.ClientSpec (spec) where
import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
-import Control.Monad.Trans.Except (runExceptT)
import Data.Time.Clock
import Mellon.Controller (controller)
import Mellon.Device (mockLock, mockLockDevice)
@@ -26,7 +25,7 @@
port <- socketPort s
return (fromIntegral port, s)
-runApp :: IO (ThreadId, Manager, BaseUrl)
+runApp :: IO (ThreadId, ClientEnv)
runApp =
do ml <- mockLock
cc <- controller Nothing $ mockLockDevice ml
@@ -34,52 +33,53 @@
let settings = setPort port $ defaultSettings
threadId <- forkIO $ runSettingsSocket settings sock (app cc)
manager <- newManager defaultManagerSettings
- return (threadId, manager, BaseUrl Http "localhost" port "")
+ let clientEnv = ClientEnv manager $ BaseUrl Http "localhost" port ""
+ return (threadId, clientEnv)
-killApp :: (ThreadId, Manager, BaseUrl) -> IO ()
-killApp (threadId, _, _) = killThread threadId
+killApp :: (ThreadId, ClientEnv) -> IO ()
+killApp (threadId, _) = killThread threadId
spec :: Spec
spec = before runApp $ after killApp $
do describe "getTime" $
- do it "returns the server time" $ \(_, manager, baseUrl) ->
+ do it "returns the server time" $ \(_, clientEnv) ->
do now <- getCurrentTime
- Right (Time serverTime) <- runExceptT (getTime manager baseUrl)
+ Right (Time serverTime) <- runClientM getTime clientEnv
let delta = 1.0 :: NominalDiffTime
((serverTime `diffUTCTime` now) < delta) `shouldBe` True
describe "getState" $
- do it "returns the current server state" $ \(_, manager, baseUrl) ->
- do Right state <- runExceptT (getState manager baseUrl)
+ do it "returns the current server state" $ \(_, clientEnv) ->
+ do Right state <- runClientM getState clientEnv
state `shouldBe` Locked
describe "putState" $
- do it "locking when the server is locked is idempotent" $ \(_, manager, baseUrl) ->
- do Right state <- runExceptT $ putState Locked manager baseUrl
+ do it "locking when the server is locked is idempotent" $ \(_, clientEnv) ->
+ do Right state <- runClientM (putState Locked) clientEnv
state `shouldBe` Locked
- it "can unlock the server until a specified date" $ \(_, manager, baseUrl) ->
+ it "can unlock the server until a specified date" $ \(_, clientEnv) ->
do now <- getCurrentTime
let untilTime = 3.0 `addUTCTime` now
- Right state <- runExceptT $ putState (Unlocked untilTime) manager baseUrl
+ Right state <- runClientM (putState (Unlocked untilTime)) clientEnv
state `shouldBe` (Unlocked untilTime)
sleep 3
- Right newState <- runExceptT (getState manager baseUrl)
+ Right newState <- runClientM getState clientEnv
newState `shouldBe` Locked
- it "later unlocks override unlocks that expire earlier" $ \(_, manager, baseUrl) ->
+ it "later unlocks override unlocks that expire earlier" $ \(_, clientEnv) ->
do now <- getCurrentTime
let untilTime = 3.0 `addUTCTime` now
- _ <- runExceptT $ putState (Unlocked untilTime) manager baseUrl
+ _ <- runClientM (putState (Unlocked untilTime)) clientEnv
sleep 1
let newUntilTime = 20.0 `addUTCTime` now
- Right state <- runExceptT $ putState (Unlocked newUntilTime) manager baseUrl
+ Right state <- runClientM (putState (Unlocked newUntilTime)) clientEnv
state `shouldBe` Unlocked newUntilTime
- it "locks override unlocks" $ \(_, manager, baseUrl) ->
+ it "locks override unlocks" $ \(_, clientEnv) ->
do now <- getCurrentTime
let untilTime = 3.0 `addUTCTime` now
- _ <- runExceptT $ putState (Unlocked untilTime) manager baseUrl
+ _ <- runClientM (putState (Unlocked untilTime)) clientEnv
sleep 1
- Right state <- runExceptT $ putState Locked manager baseUrl
+ Right state <- runClientM (putState Locked ) clientEnv
state `shouldBe` Locked
diff --git a/test/Mellon/Web/ServerSpec.hs b/test/Mellon/Web/ServerSpec.hs
--- a/test/Mellon/Web/ServerSpec.hs
+++ b/test/Mellon/Web/ServerSpec.hs
@@ -7,6 +7,7 @@
import Data.Aeson (decode, encode)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB (ByteString)
+import Data.Maybe (fromJust)
import Data.Time.Clock
import Mellon.Controller (controller)
import Mellon.Device (mockLock, mockLockDevice)
@@ -15,9 +16,20 @@
import Network.Wai.Test (SResponse, simpleBody)
import Test.Hspec
import Test.Hspec.Wai ((<:>), WaiSession, get, liftIO, matchHeaders, request, shouldRespondWith, with)
+import Test.QuickCheck
+ (Arbitrary(..), elements, genericShrink, oneof, property)
+import Test.QuickCheck.Instances ()
-import Mellon.Web.Server (State(..), app, docsApp)
+import Mellon.Web.Server (State(..), Time(..), app, swaggerApp)
+instance Arbitrary State where
+ arbitrary = oneof [pure Locked, Unlocked <$> arbitrary]
+ shrink = genericShrink
+
+instance Arbitrary Time where
+ arbitrary = Time <$> arbitrary
+ shrink = genericShrink
+
sleep :: Int -> IO ()
sleep = threadDelay . (* 1000000)
@@ -27,18 +39,22 @@
cc <- controller Nothing $ mockLockDevice ml
return (app cc)
-runDocsApp :: IO Application
-runDocsApp =
+runSwaggerApp :: IO Application
+runSwaggerApp =
do ml <- mockLock
cc <- controller Nothing $ mockLockDevice ml
- return (docsApp cc)
+ return (swaggerApp cc)
putJSON :: ByteString -> LB.ByteString -> WaiSession SResponse
putJSON path = request methodPut path [(hContentType, "application/json;charset=utf-8")]
spec :: Spec
spec =
- do describe "Server time" $
+ do describe "ToJSON/FromJSON" $
+ it "is isomorphic" $ property $
+ \(s :: State) -> fromJust (decode $ encode s) == s
+
+ describe "Server time" $
do with runApp $
do it "should be accurate" $
do now <- liftIO getCurrentTime
@@ -119,7 +135,7 @@
response <- putJSON "/state" (encode Locked)
liftIO $ decode (simpleBody response) `shouldBe` Just Locked
- describe "Docs application" $
- do with runDocsApp $
- do it "serves docs" $
- get "/docs" `shouldRespondWith` 200 { matchHeaders = [hContentType <:> "text/plain"]}
+ describe "Swagger application" $
+ do with runSwaggerApp $
+ do it "serves the Swagger UI" $
+ get "/swagger-ui/" `shouldRespondWith` 200 { matchHeaders = [hContentType <:> "text/html;charset=utf-8"]}
diff --git a/test/Mellon/Web/SwaggerAPISpec.hs b/test/Mellon/Web/SwaggerAPISpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Mellon/Web/SwaggerAPISpec.hs
@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Mellon.Web.SwaggerAPISpec (spec) where
+
+import Mellon.Web.Server (State(..), Time(..), mellonAPI, mellonSwagger)
+
+import Data.Aeson (eitherDecode)
+import qualified Data.ByteString.Lazy.Char8 as C8 (readFile)
+import Paths_mellon_web
+import Servant.Swagger.Test
+import Test.Hspec
+import Test.QuickCheck
+ (Arbitrary(..), elements, genericShrink, oneof, property)
+import Test.QuickCheck.Instances ()
+
+spec :: Spec
+spec =
+ do describe "Swagger" $
+ do context "ToJSON matches ToSchema" $
+ validateEveryToJSON mellonAPI
+ context "swagger.json" $
+ it "matches current file contents" $
+ do path <- getDataFileName "swagger.json"
+ swagger <- eitherDecode <$> C8.readFile path
+ swagger `shouldBe` Right mellonSwagger
+
+instance Arbitrary State where
+ arbitrary = oneof [pure Locked, Unlocked <$> arbitrary]
+ shrink = genericShrink
+
+instance Arbitrary Time where
+ arbitrary = Time <$> arbitrary
+ shrink = genericShrink
diff --git a/test/doctest.hs b/test/doctest.hs
new file mode 100644
--- /dev/null
+++ b/test/doctest.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Test.DocTest
+
+main :: IO ()
+main = doctest ["src"]