mellon-web 0.7.0.3 → 0.7.1.0
raw patch · 16 files changed
+479/−286 lines, 16 filesdep +QuickCheckdep +aeson-prettydep +doctestdep ~aesondep ~basedep ~hspec
Dependencies added: QuickCheck, aeson-pretty, doctest, lens, quickcheck-instances, servant-swagger, servant-swagger-ui, swagger2
Dependency ranges changed: aeson, base, hspec, hspec-wai, http-client, optparse-applicative, servant, servant-client, servant-docs, servant-server
Files
- API.md +0/−131
- changelog.md +6/−0
- examples/GpioServer.hs +3/−2
- examples/MockServer.hs +2/−2
- examples/ScheduleUnlock.hs +12/−9
- mellon-web.cabal +49/−17
- src/Mellon/Web/Client.hs +4/−6
- src/Mellon/Web/Server.hs +4/−7
- src/Mellon/Web/Server/API.hs +126/−12
- src/Mellon/Web/Server/DocsAPI.hs +0/−71
- src/Mellon/Web/Server/SwaggerAPI.hs +77/−0
- swagger.json +112/−0
- test/Mellon/Web/ClientSpec.hs +20/−20
- test/Mellon/Web/ServerSpec.hs +25/−9
- test/Mellon/Web/SwaggerAPISpec.hs +33/−0
- test/doctest.hs +6/−0
− API.md
@@ -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-<!DOCTYPE HTML><html><head><title>Mellon state</title></head><body>Locked</body></html>-```--- Unlocked until a given date--```javascript-{"state":"Unlocked","until":"2015-10-06T00:00:00Z"}-```--- Unlocked until a given date--```html-<!DOCTYPE HTML><html><head><title>Mellon state</title></head><body>Unlocked until 2015-10-06 00:00:00 UTC</body></html>-```--## 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-<!DOCTYPE HTML><html><head><title>Mellon state</title></head><body>Locked</body></html>-```--- Unlocked until a given date--```javascript-{"state":"Unlocked","until":"2015-10-06T00:00:00Z"}-```--- Unlocked until a given date--```html-<!DOCTYPE HTML><html><head><title>Mellon state</title></head><body>Unlocked until 2015-10-06 00:00:00 UTC</body></html>-```--## 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-<!DOCTYPE HTML><html><head><title>Server time</title></head><body>Server time is 2015-10-06 00:00:00 UTC</body></html>-```
changelog.md view
@@ -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.
examples/GpioServer.hs view
@@ -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))) =
examples/MockServer.hs view
@@ -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
examples/ScheduleUnlock.hs view
@@ -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)
mellon-web.cabal view
@@ -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 <src@drewhess.com>@@ -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
src/Mellon/Web/Client.hs view
@@ -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
src/Mellon/Web/Server.hs view
@@ -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
src/Mellon/Web/Server/API.hs view
@@ -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)]
− src/Mellon/Web/Server/DocsAPI.hs
@@ -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 <src@drewhess.com>-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
+ src/Mellon/Web/Server/SwaggerAPI.hs view
@@ -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 <src@drewhess.com>+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)
+ swagger.json view
@@ -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"+ ]+ }+ }+ }+}
test/Mellon/Web/ClientSpec.hs view
@@ -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
test/Mellon/Web/ServerSpec.hs view
@@ -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"]}
+ test/Mellon/Web/SwaggerAPISpec.hs view
@@ -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
+ test/doctest.hs view
@@ -0,0 +1,6 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest ["src"]