mellon-web (empty) → 0.7.0.1
raw patch · 18 files changed
+1494/−0 lines, 18 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, exceptions, hlint, hpio, hspec, hspec-wai, http-client, http-types, lucid, mellon-core, mellon-gpio, mellon-web, mtl, network, optparse-applicative, servant, servant-client, servant-docs, servant-lucid, servant-server, text, time, transformers, wai, wai-extra, warp
Files
- API.md +131/−0
- LICENSE +30/−0
- README.md +79/−0
- Setup.hs +2/−0
- changelog.md +8/−0
- examples/GpioServer.hs +79/−0
- examples/MockServer.hs +15/−0
- mellon-web.cabal +192/−0
- mellon-web.paw +387/−0
- src/Mellon/Web/Client.hs +67/−0
- src/Mellon/Web/Server.hs +22/−0
- src/Mellon/Web/Server/API.hs +181/−0
- src/Mellon/Web/Server/DocsAPI.hs +71/−0
- test/Main.hs +7/−0
- test/Mellon/Web/ClientSpec.hs +85/−0
- test/Mellon/Web/ServerSpec.hs +125/−0
- test/Spec.hs +1/−0
- test/hlint.hs +12/−0
+ API.md view
@@ -0,0 +1,131 @@+## 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>+```
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Drew Hess++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Drew Hess nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,79 @@+# mellon-web++The `mellon-web` package wraps a `mellon-core` controller in a REST+web service, making it possible to control physical access devices+from an HTTP client. The package includes both a WAI application+server, and native Haskell client bindings for the service.++Like the `mellon-core` controller interface, the `mellon-web` REST API+is quite simple. There are only 3 methods:++* `GET /time` returns the system time on the server. This is made+ available for diagnostic purposes, primarily to ensure the server+ has an accurate clock.++* `GET /state` returns the controller's current state (either `Locked`+ or `Unlocked date` where `date` is the UTC time at which the+ controller will automatically lock again).++* `PUT /state` sets the controller's current state. Use this method to+ lock and unlock the controller.++See [API.md](API.md) for detailed documentation on the REST service.++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.++## Example servers++### "Mock" server++An extremely simple example server (with on-line documentation+support) is provided in the `examples` directory. You can run it with+`cabal run mock-mellon-server` and test it using the endpoints+described in [API.md](API.md). The server is will run on the+`localhost` loopback interface on port 8081.++Also included is a [Paw](https://luckymarmot.com/paw) file with a+pre-defined `localhost` environment for use with the example server.++This particular example server uses a "mock lock" device which only+internally logs lock and unlock events without depending on any actual+hardware, so it will run anywhere.++### GPIO server++Another included example server uses the `mellon-gpio` package to+drive a simple physical access device via a GPIO pin. This server must+be run on a Linux host with GPIO hardware, e.g., a Raspberry Pi+running Linux.++This server takes a GPIO pin number and a local port number, then+starts a `mellon-web` server on all local interfaces on the specified+port. When the server receives an unlock request, it will drive a high+signal on the specified GPIO pin. When the unlock expires, or when the+server receives a lock request, it will drive a low signal on the+specified GPIO pin.++To use this server, simply connect a properly-designed physical access+device (e.g., an electric strike driven by a relay circuit such as the+one shown+[here](http://www.petervis.com/Raspberry_PI/Driving_Relays_with_CMOS_and_TTL_Outputs/Driving_Relays_with_CMOS_and_TTL_Outputs.html))+to an available GPIO pin on the host device, then run the server with+the specified GPIO pin number and port. For example, to run the server+on port 7533 using GPIO pin 65:++```+cabal run gpio-mellon-server -- sysfs --port 7533 65+```++The `sysfs` command tells the server to use the Linux `sysfs` GPIO+interpreter. (Currently, this is the only supported GPIO platform.)++**NOTE**: the REST service provided by `gpio-mellon-server` offers no+security/authentication for your access control device! You should+always run it (or any `mellon-web` server) behind a secure proxy web+service or equivalent HTTP(S)-based authentication mechanism.++[](https://travis-ci.org/dhess/mellon)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,8 @@+## 0.7.0.1 (2016-06-13)++- Packaging fixes only.++## 0.7.0.0 (2016-06-02)++- Port to new `mellon-core` package.+- Fix Servant bitrot.
+ examples/GpioServer.hs view
@@ -0,0 +1,79 @@+-- | Run a @mellon-web@ server which wraps a GPIO-driven physical+-- access device.++{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Time.Clock (NominalDiffTime)+import Mellon.Controller (Device(..), controller)+import Mellon.Device.GPIO (sysfsGpioDevice)+import Mellon.Web.Server.DocsAPI (docsApp)+import Network (PortID(..), listenOn)+import Network.Wai.Handler.Warp (defaultSettings, runSettingsSocket, setHost, setPort)+import Options.Applicative+import System.GPIO.Monad+ (Pin(..), PinActiveLevel(..), PinValue(..), PinOutputMode(..),+ withOutputPin)+import System.GPIO.Linux.Sysfs (runSysfsGpioIO)++data GlobalOptions =+ GlobalOptions {_port :: !Int+ ,_minUnlockTime :: !Int+ ,_cmd :: !Command}++data Command+ = Sysfs SysfsOptions++data SysfsOptions = SysfsOptions {_pin :: !Int}++sysfsCmd :: Parser Command+sysfsCmd = Sysfs <$> sysfsOptions++sysfsOptions :: Parser SysfsOptions+sysfsOptions =+ SysfsOptions <$>+ argument auto (metavar "PIN" <>+ help "GPIO pin number")++cmds :: Parser GlobalOptions+cmds =+ GlobalOptions <$>+ option auto (long "port" <>+ short 'p' <>+ metavar "INT" <>+ value 8000 <>+ help "Listen on port") <*>+ option auto (long "min-unlock-time" <>+ short 'u' <>+ metavar "INT" <>+ value 1 <>+ help "Minimum unlock time in seconds") <*>+ hsubparser+ (command "sysfs" (info sysfsCmd (progDesc "Use the Linux sysfs GPIO interpreter")))++runTCPServerSysfs :: Pin -> Int -> NominalDiffTime -> IO ()+runTCPServerSysfs pin port minUnlockTime = runSysfsGpioIO $+ withOutputPin pin OutputDefault (Just ActiveHigh) Low $ \p ->+ liftIO $ runTCPServer minUnlockTime (sysfsGpioDevice p) port++runTCPServer :: NominalDiffTime -> Device d -> Int -> IO ()+runTCPServer minUnlock device port =+ do cc <- controller (Just minUnlock) device+ sock <- listenOn (PortNumber (fromIntegral port))+ runSettingsSocket (setPort port $ setHost "*" defaultSettings) sock (docsApp cc)++run :: GlobalOptions -> IO ()+run (GlobalOptions listenPort minUnlockTime (Sysfs (SysfsOptions pinNumber))) =+ let pin = Pin pinNumber+ in+ runTCPServerSysfs pin listenPort (fromIntegral minUnlockTime)++main :: IO ()+main = execParser opts >>= run+ where opts =+ info (helper <*> cmds)+ (fullDesc <>+ progDesc "A Mellon server for controlling physical access devices via GPIO" <>+ header "gpio-mellon-server")
+ examples/MockServer.hs view
@@ -0,0 +1,15 @@+-- | Run a @mellon-web@ server with a mock lock device on port 8081.++module Main where++import Mellon.Controller (controller)+import Mellon.Device (mockLock, mockLockDevice)+import Mellon.Web.Server (docsApp)+import Network.Wai.Handler.Warp (run)++main :: IO ()+main =+ do ml <- mockLock+ cc <- controller Nothing $ mockLockDevice ml+ putStrLn "Running on port 8081"+ run 8081 $ docsApp cc
+ mellon-web.cabal view
@@ -0,0 +1,192 @@+Name: mellon-web+Version: 0.7.0.1+Cabal-Version: >= 1.10+Build-Type: Simple+Author: Drew Hess <src@drewhess.com>+Maintainer: Drew Hess <src@drewhess.com>+Homepage: https://github.com/dhess/mellon/+Bug-Reports: https://github.com/dhess/mellon/issues/+Stability: experimental+License: BSD3+License-File: LICENSE+Copyright: Copyright (c) 2016, Drew Hess+Tested-With: GHC == 7.10.3, GHC == 8.0.1+Category: Web+Synopsis: A REST web service for Mellon controllers+Description:+ The @mellon-web@ package wraps a @mellon-core@ controller in a REST+ web service, making it possible to control physical access devices+ from an HTTP client. The package includes both a WAI application+ server, and native Haskell client bindings for the service.+ .+ Like the @mellon-core@ controller interface, the @mellon-web@ REST API+ is quite simple. There are only 3 methods:+ .+ * @GET /time@ returns the system time on the server. This is made+ available for diagnostic purposes, primarily to ensure the server+ has an accurate clock.+ .+ * @GET /state@ returns the controller's current state (either @Locked@+ or @Unlocked date@ where @date@ is the UTC time at which the+ controller will automatically lock again).+ .+ * @PUT /state@ sets the controller's current state. Use this method to+ lock and unlock the controller.+ .+ See the included <API.md API.md> document for detailed documentation+ on the REST service.+ .+ 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-Source-Files: changelog.md+ , examples/*.hs+ , mellon-web.paw++-- Build hlint test+Flag test-hlint+ Default: True+ Manual: True++-- Build the mock server example+Flag mock-example+ Default: True+ Manual: True++-- Build the GPIO server example+Flag gpio-example+ Default: True+ Manual: True++Library+ Default-Language: Haskell2010+ HS-Source-Dirs: src+ GHC-Options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ Exposed-Modules: Mellon.Web.Client+ , Mellon.Web.Server+ , Mellon.Web.Server.API+ , Mellon.Web.Server.DocsAPI+ Other-Extensions: DataKinds+ , DeriveGeneric+ , MultiParamTypeClasses+ , OverloadedStrings+ , TypeOperators+ Build-Depends: base >= 4.8 && < 5+ , aeson == 0.11.*+ , bytestring == 0.10.*+ , http-client == 0.4.*+ , http-types == 0.9.*+ , lucid == 2.9.*+ , mellon-core == 0.7.*+ , servant >= 0.7.1 && < 0.8+ , servant-client >= 0.7.1 && < 0.8+ , servant-docs >= 0.7.1 && < 0.8+ , servant-lucid >= 0.7.1 && < 0.8+ , servant-server >= 0.7.1 && < 0.8+ , text == 1.2.*+ , time >= 1.5 && < 2+ , transformers >= 0.4.2 && < 0.6+ , wai == 3.2.*+ , warp == 3.2.*++Executable mock-mellon-server+ Main-Is: MockServer.hs+ Default-Language: Haskell2010+ HS-Source-Dirs: examples+ GHC-Options: -Wall -threaded -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ If !flag(mock-example)+ Buildable: False+ Else + Build-Depends: base+ , mellon-core+ , mellon-web+ , warp++Executable gpio-mellon-server+ Main-Is: GpioServer.hs+ Default-Language: Haskell2010+ HS-Source-Dirs: examples+ GHC-Options: -Wall -threaded -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ Other-Extensions: OverloadedStrings+ If !flag(gpio-example)+ Buildable: False+ Else + Build-Depends: base+ , exceptions >= 0.8.0 && < 1+ , hpio >= 0.8 && < 1+ , mellon-core+ , mellon-gpio == 0.7.*+ , mellon-web+ , mtl+ , network == 2.6.*+ , optparse-applicative >= 0.11.0 && < 0.13+ , time+ , transformers+ , warp++Test-Suite hlint+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: test+ Ghc-Options: -w -threaded -rtsopts -with-rtsopts=-N+ Main-Is: hlint.hs+ If !flag(test-hlint)+ Buildable: False+ Else+ Build-Depends: base+ , hlint == 1.9.*++Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , test+ Ghc-Options: -w -threaded -rtsopts -with-rtsopts=-N+ Main-Is: Main.hs+ Other-Extensions: ScopedTypeVariables+ Build-Depends: base+ , aeson+ , bytestring+ , hspec == 2.2.*+ , hspec-wai >= 0.6.6 && < 0.7+ , http-client+ , http-types+ , lucid+ , mellon-core+ , network+ , servant+ , servant-client+ , servant-docs+ , servant-lucid+ , servant-server+ , text+ , time+ , transformers+ , wai+ , wai-extra == 3.0.*+ , warp+ Other-Modules: Mellon.Web.Client+ , Mellon.Web.Server+ , Mellon.Web.Server.API+ , Mellon.Web.Server.DocsAPI+ , Spec+ , Mellon.Web.ClientSpec+ , Mellon.Web.ServerSpec++Source-Repository head+ Type: git+ Location: git://github.com/dhess/mellon.git++Source-Repository this+ Type: git+ Location: git://github.com/dhess/mellon.git+ Branch: v0.7.0+ Tag: v0.7.0.1a
+ mellon-web.paw view
@@ -0,0 +1,387 @@+<?xml version="1.0" standalone="no"?>+<!DOCTYPE database SYSTEM "file:///System/Library/DTDs/CoreData.dtd">++<database>+ <databaseInfo>+ <version>134481920</version>+ <UUID>1E1D451C-4E87-4F1C-8A5D-6A76267CA5ED</UUID>+ <nextObjectID>132</nextObjectID>+ <metadata>+ <plist version="1.0">+ <dict>+ <key>NSPersistenceFrameworkVersion</key>+ <integer>640</integer>+ <key>NSStoreModelVersionHashes</key>+ <dict>+ <key>LMCookieJar</key>+ <data>+ Fttmf2L4PrGvKUF496+nqgVVGek45TjOe7sUMtjNg8I=+ </data>+ <key>LMEnvironment</key>+ <data>+ uzBoVFcO4YvR9/3ej4AJ1UOOsA/u5DKY2aemusoIseU=+ </data>+ <key>LMEnvironmentDomain</key>+ <data>+ yM1GPGHdquS8IWLtuczlNoqKhIhD9FW6IReSfFffJgs=+ </data>+ <key>LMEnvironmentVariable</key>+ <data>+ P8e0lYd5JZKRabS/eXVSOJ4oitilz67xtv+pLqW1Jqg=+ </data>+ <key>LMEnvironmentVariableValue</key>+ <data>+ my5hNPJ51oDCSa8EgdNxWAnRcDLcERUGjtuXnzhSxQ0=+ </data>+ <key>LMKeyValue</key>+ <data>+ bIXXbyYF2xAv2MXg8JTVFsslmMKuvsfnR86QdUcFkdM=+ </data>+ <key>LMRequest</key>+ <data>+ kYB6By9dZHqmH3YNw3h9tYPoxeG5ZWHPfhLXXp7OLFs=+ </data>+ <key>LMRequestGroup</key>+ <data>+ N3ml+gYVWc4m0LSGLnBDJ37p9isOc41y+TtaM0Eacrc=+ </data>+ <key>LMRequestTreeItem</key>+ <data>+ ak+hYb/lDeG55U0kgGvU5ej7HUltUj0RTrX5z/izNrs=+ </data>+ </dict>+ <key>NSStoreModelVersionHashesVersion</key>+ <integer>3</integer>+ <key>NSStoreModelVersionIdentifiers</key>+ <array>+ <string>LMDocumentVersion3</string>+ </array>+ </dict>+ </plist>+ </metadata>+ </databaseInfo>+ <object type="LMREQUEST" id="z102">+ <attribute name="uuid" type="string">48D5A84F-CA3A-4E31-B9A2-3E90E65179F5</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/state"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">PUT</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="body" type="string">[{"data":{"json":"{\\"state\\":\\"Unlocked\\",\\"until\\":\\"[{\\\\\\"data\\\\\\":{\\\\\\"format\\\\\\":3,\\\\\\"customFormat\\\\\\":[],\\\\\\"now\\\\\\":true,\\\\\\"useTSeparator\\\\\\":1,\\\\\\"date\\\\\\":1443060019.378293,\\\\\\"delta\\\\\\":10,\\\\\\"useZForUTC\\\\\\":1},\\\\\\"identifier\\\\\\":\\\\\\"com.luckymarmot.TimestampDynamicValue\\\\\\"}]\\"}"},"identifier":"com.luckymarmot.JSONDynamicValue"}]</attribute>+ <attribute name="order" type="int64">3</attribute>+ <attribute name="name" type="string">Unlock for 10s</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z110"></relationship>+ </object>+ <object type="LMCOOKIEJAR" id="z103">+ <attribute name="uuid" type="string">46D05D33-1307-4DE8-A337-54150C4D82D4</attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string">Default Jar</attribute>+ </object>+ <object type="LMENVIRONMENTDOMAIN" id="z104">+ <attribute name="uuid" type="string">1BC02327-3607-4075-A036-96A3F21EB896</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">Default Domain</attribute>+ <relationship name="environments" type="0/0" destination="LMENVIRONMENT" idrefs="z108"></relationship>+ <relationship name="variables" type="0/0" destination="LMENVIRONMENTVARIABLE" idrefs="z129 z131 z105"></relationship>+ </object>+ <object type="LMENVIRONMENTVARIABLE" id="z105">+ <attribute name="uuid" type="string">0F7D7E4D-E5E5-430F-90EB-E4617541F817</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">host</attribute>+ <relationship name="domain" type="0/1" destination="LMENVIRONMENTDOMAIN" idrefs="z104"></relationship>+ <relationship name="values" type="0/0" destination="LMENVIRONMENTVARIABLEVALUE" idrefs="z106"></relationship>+ </object>+ <object type="LMENVIRONMENTVARIABLEVALUE" id="z106">+ <attribute name="value" type="string">localhost</attribute>+ <relationship name="environment" type="1/1" destination="LMENVIRONMENT" idrefs="z108"></relationship>+ <relationship name="variable" type="1/1" destination="LMENVIRONMENTVARIABLE" idrefs="z105"></relationship>+ </object>+ <object type="LMREQUEST" id="z107">+ <attribute name="uuid" type="string">08E692C2-8C79-4BF5-95E1-C7CBC9627D79</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/time"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="order" type="int64">5</attribute>+ <attribute name="name" type="string">Get time</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z111"></relationship>+ </object>+ <object type="LMENVIRONMENT" id="z108">+ <attribute name="uuid" type="string">806883AB-58E3-4D72-9C0B-FFF62CB0E228</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">localhost</attribute>+ <relationship name="domain" type="0/1" destination="LMENVIRONMENTDOMAIN" idrefs="z104"></relationship>+ <relationship name="variablesvalues" type="0/0" destination="LMENVIRONMENTVARIABLEVALUE" idrefs="z130 z106 z132"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z109">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z112"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z110">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z102"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z111">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z107"></relationship>+ </object>+ <object type="LMREQUEST" id="z112">+ <attribute name="uuid" type="string">949BC3B1-EE2E-40AB-A805-C59ACFA37E5A</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/state"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">Get state</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z109"></relationship>+ </object>+ <object type="LMREQUEST" id="z113">+ <attribute name="uuid" type="string">296FB78E-5DF8-427F-B0B3-87F36566B5AE</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/state"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">PUT</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="body" type="string">[{"data":{"json":"{\\"state\\":\\"Locked\\",\\"until\\":[]}"},"identifier":"com.luckymarmot.JSONDynamicValue"}]</attribute>+ <attribute name="order" type="int64">4</attribute>+ <attribute name="name" type="string">Lock now</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z114"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z114">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z113"></relationship>+ </object>+ <object type="LMREQUEST" id="z115">+ <attribute name="uuid" type="string">63AA61F1-3718-458E-9ED7-BF94700EFE50</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/state"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="body" type="string"></attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string">Get state (accept JSON)</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z116 z119"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z116">+ <attribute name="value" type="string">application/json</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">Accept</attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z115"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z117">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z118"></relationship>+ </object>+ <object type="LMREQUEST" id="z118">+ <attribute name="uuid" type="string">18CAAEEC-FC1F-40A9-B000-71EF7965A35D</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/state"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="body" type="string"></attribute>+ <attribute name="order" type="int64">2</attribute>+ <attribute name="name" type="string">Get state (accept HTML)</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z120 z117"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z119">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z115"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z120">+ <attribute name="value" type="string">text/html</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">Accept</attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z118"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z121">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z126"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z122">+ <attribute name="value" type="string">text/html</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">Accept</attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z123"></relationship>+ </object>+ <object type="LMREQUEST" id="z123">+ <attribute name="uuid" type="string">F4DDFE27-4F2E-4E50-8CD1-05C666C5B1A5</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/time"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="order" type="int64">7</attribute>+ <attribute name="name" type="string">Get time (accept HTML)</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z122 z124"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z124">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z123"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z125">+ <attribute name="value" type="string">application/json</attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string">Accept</attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z126"></relationship>+ </object>+ <object type="LMREQUEST" id="z126">+ <attribute name="uuid" type="string">62F86462-ED46-4738-9877-86AD97E3535A</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/time"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="order" type="int64">6</attribute>+ <attribute name="name" type="string">Get time (accept JSON)</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z125 z121"></relationship>+ </object>+ <object type="LMREQUEST" id="z127">+ <attribute name="uuid" type="string">A0AE2FB5-7F43-4C52-BFF7-0E922225030D</attribute>+ <attribute name="url" type="string">[{"data":{"environmentVariable":"CF638FE7-0A86-4129-B488-AF6225D53392"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":\\/\\/",{"data":{"environmentVariable":"0F7D7E4D-E5E5-430F-90EB-E4617541F817"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},":",{"data":{"environmentVariable":"7CB28DDF-2140-4675-A9FC-6DF2570EE218"},"identifier":"com.luckymarmot.EnvironmentVariableDynamicValue"},"\\/docs"]</attribute>+ <attribute name="storecookies" type="bool">1</attribute>+ <attribute name="sendcookies" type="bool">1</attribute>+ <attribute name="redirectmethod" type="bool">0</attribute>+ <attribute name="redirectauthorization" type="bool">0</attribute>+ <attribute name="method" type="string">GET</attribute>+ <attribute name="followredirects" type="bool">0</attribute>+ <attribute name="order" type="int64">8</attribute>+ <attribute name="name" type="string">Get docs</attribute>+ <relationship name="parent" type="0/1" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="children" type="0/0" destination="LMREQUESTTREEITEM"></relationship>+ <relationship name="headers" type="0/0" destination="LMKEYVALUE" idrefs="z128"></relationship>+ </object>+ <object type="LMKEYVALUE" id="z128">+ <attribute name="value" type="string"></attribute>+ <attribute name="order" type="int64">0</attribute>+ <attribute name="name" type="string"></attribute>+ <attribute name="enabled" type="bool">1</attribute>+ <relationship name="groupforbodyparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforheaders" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="groupforurlparameters" type="0/1" destination="LMREQUESTGROUP"></relationship>+ <relationship name="request" type="0/1" destination="LMREQUEST" idrefs="z127"></relationship>+ </object>+ <object type="LMENVIRONMENTVARIABLE" id="z129">+ <attribute name="uuid" type="string">7CB28DDF-2140-4675-A9FC-6DF2570EE218</attribute>+ <attribute name="order" type="int64">2</attribute>+ <attribute name="name" type="string">port</attribute>+ <relationship name="domain" type="0/1" destination="LMENVIRONMENTDOMAIN" idrefs="z104"></relationship>+ <relationship name="values" type="0/0" destination="LMENVIRONMENTVARIABLEVALUE" idrefs="z130"></relationship>+ </object>+ <object type="LMENVIRONMENTVARIABLEVALUE" id="z130">+ <attribute name="value" type="string">8081</attribute>+ <relationship name="environment" type="1/1" destination="LMENVIRONMENT" idrefs="z108"></relationship>+ <relationship name="variable" type="1/1" destination="LMENVIRONMENTVARIABLE" idrefs="z129"></relationship>+ </object>+ <object type="LMENVIRONMENTVARIABLE" id="z131">+ <attribute name="uuid" type="string">CF638FE7-0A86-4129-B488-AF6225D53392</attribute>+ <attribute name="order" type="int64">1</attribute>+ <attribute name="name" type="string">protocol</attribute>+ <relationship name="domain" type="0/1" destination="LMENVIRONMENTDOMAIN" idrefs="z104"></relationship>+ <relationship name="values" type="0/0" destination="LMENVIRONMENTVARIABLEVALUE" idrefs="z132"></relationship>+ </object>+ <object type="LMENVIRONMENTVARIABLEVALUE" id="z132">+ <attribute name="value" type="string">http</attribute>+ <relationship name="environment" type="1/1" destination="LMENVIRONMENT" idrefs="z108"></relationship>+ <relationship name="variable" type="1/1" destination="LMENVIRONMENTVARIABLE" idrefs="z131"></relationship>+ </object>+</database>
+ src/Mellon/Web/Client.hs view
@@ -0,0 +1,67 @@+{-|+Module : Mellon.Web.Client+Description : Client actions for the REST web service+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++This module provides client-side actions for interacting with the+server-side 'MellonAPI'.++The client actions are implemented on top of the "Network.HTTP.Client"+and "Servant.Client" modules.++-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module Mellon.Web.Client+ ( -- * Client actions+ --+ -- | These actions take a 'Manager' and a 'BaseUrl', and+ -- should then be run in an 'ExceptT' transformer stack to+ -- produce a result. For example, assuming the service+ -- endpoint is @http://localhost:8081/@:+ --+ -- > > let baseUrl = BaseUrl Http "localhost" 8081 ""+ -- > > manager <- newManager defaultManagerSettings+ -- > > runExceptT $ putState Locked manager baseUrl+ -- > Right Locked+ getTime+ , getState+ , putState++ -- * Server types+ --+ -- | Re-exported for convenience.+ , State(..)+ , 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 Mellon.Web.Server (MellonAPI, State(..), Time(..))++-- | The client API.+clientAPI :: Proxy MellonAPI+clientAPI = Proxy++-- | 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++-- | Get the current state of the server's+-- 'Mellon.Controller.Controller'.+getState :: Manager -> BaseUrl -> ExceptT ServantError IO State++-- | Lock or unlock the server's 'Mellon.Controller.Controller'.+putState :: State -> Manager -> BaseUrl -> ExceptT ServantError IO State++getTime :<|> getState :<|> putState = client clientAPI
+ src/Mellon/Web/Server.hs view
@@ -0,0 +1,22 @@+{-|+Module : Mellon.Web.Server+Description : Top-level server re-exports+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++This module re-exports the @mellon-web@ server modules.++-}++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++import Mellon.Web.Server.API+import Mellon.Web.Server.DocsAPI
+ src/Mellon/Web/Server/API.hs view
@@ -0,0 +1,181 @@+{-|+Module : Mellon.Web.Server.API+Description : A 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 provides a "Servant" REST web service for @mellon-core@+controllers. The service translates REST methods to controller+actions.++See the included <API.md API.md> file for detailed documentation on+the REST service methods and document types.++-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Mellon.Web.Server.API+ ( -- * Types+ MellonAPI+ , State(..)+ , Time(..)++ -- * Servant / WAI functions+ , app+ , mellonAPI+ , server+ ) where++import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson.Types+ (FromJSON(..), ToJSON(..), Options(..), SumEncoding(TaggedObject),+ defaultOptions, genericToJSON, genericParseJSON, tagFieldName,+ contentsFieldName)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime(..), getCurrentTime)+import GHC.Generics+import Lucid+ (ToHtml(..), HtmlT, doctypehtml_, head_, title_, body_)+import Mellon.Controller+ (Controller, lockController, unlockController, queryController)+import qualified Mellon.Controller as Controller (State(..))+import Network.Wai (Application)+import Servant+ ((:>), (:<|>)(..), (:~>)(..), JSON, Get, ReqBody, Put, Proxy(..),+ ServerT, Server, ServantErr, enter, serve)+import Servant.Docs (ToSample(..))+import Servant.HTML.Lucid (HTML)++wrapBody :: Monad m => HtmlT m () -> HtmlT m a -> HtmlT m a+wrapBody title body =+ doctypehtml_ $+ do head_ $+ title_ title+ body_ body++-- | Mimics 'Controller.State', but provides JSON conversions.+-- (Avoids orphan instances.)+data State+ = Locked+ | Unlocked !UTCTime+ deriving (Eq,Show,Generic)++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"}++instance ToJSON State where+ toJSON = genericToJSON stateJSONOptions++instance FromJSON State where+ parseJSON = genericParseJSON stateJSONOptions++sampleDate :: UTCTime+sampleDate = UTCTime { utctDay = fromGregorian 2015 10 06, utctDayTime = 0 }++instance ToSample State where+ toSamples _ =+ [ ("Locked", Locked)+ , ("Unlocked until a given date", Unlocked sampleDate)+ ]++stateDocument :: Monad m => HtmlT m a -> HtmlT m a+stateDocument = wrapBody "Mellon state"++instance ToHtml State where+ toHtml Locked = stateDocument "Locked"+ toHtml (Unlocked time) = stateDocument $ "Unlocked until " >> toHtml (show time)+ toHtmlRaw = toHtml++-- | A newtype wrapper around 'UTCTime', for serving HTML without+-- orphan instances.+newtype Time = Time UTCTime deriving (Eq, Show, Generic)++instance ToJSON Time where+ toJSON = genericToJSON defaultOptions++instance FromJSON Time where+ parseJSON = genericParseJSON defaultOptions++instance ToSample Time where+ toSamples _ = [("2015-10-06",Time sampleDate)]++timeDocument :: Monad m => HtmlT m a -> HtmlT m a+timeDocument = wrapBody "Server time"++instance ToHtml Time where+ toHtml (Time time) = timeDocument $ toHtml $ "Server time is " ++ show time+ toHtmlRaw = toHtml++-- | A "Servant" API for interacting with a 'Controller'.+--+-- In addition to the controller methods, the API also provides a way+-- to obtain the system time on the server, to ensure that the+-- server's clock is accurate.+type MellonAPI =+ "time" :> Get '[JSON, HTML] Time :<|>+ "state" :> Get '[JSON, HTML] State :<|>+ "state" :> ReqBody '[JSON] State :> Put '[JSON, HTML] State++type AppM d m = ReaderT (Controller d) (ExceptT ServantErr m)++serverT :: (MonadIO m) => ServerT MellonAPI (AppM d m)+serverT =+ getTime :<|>+ getState :<|>+ putState+ where+ getTime :: (MonadIO m) => AppM d m Time+ getTime =+ do now <- liftIO getCurrentTime+ return $ Time now++ getState :: (MonadIO m) => AppM d m State+ getState =+ do cc <- ask+ fmap stateToState (queryController cc)++ putState :: (MonadIO m) => State -> AppM d m State+ putState Locked =+ do cc <- ask+ fmap stateToState (lockController cc)+ putState (Unlocked date) =+ do cc <- ask+ fmap stateToState (unlockController date cc)++-- | A 'Proxy' for 'MellonAPI', exported in order to make it possible+-- to extend the API.+mellonAPI :: Proxy MellonAPI+mellonAPI = Proxy++serverToEither :: (MonadIO m) => Controller d -> AppM d m :~> ExceptT ServantErr m+serverToEither cc = Nat $ \m -> runReaderT m cc++-- | A Servant 'Server' which serves the 'MellonAPI' on the given+-- 'Controller'.+--+-- Normally you will just use 'app', but this function is exported so+-- that you can extend/wrap 'MellonAPI'.+server :: Controller d -> Server MellonAPI+server cc = enter (serverToEither cc) serverT++-- | A WAI 'Network.Wai.Application' which runs the service, using the+-- given 'Controller'.+app :: Controller d -> Application+app = serve mellonAPI . server
+ src/Mellon/Web/Server/DocsAPI.hs view
@@ -0,0 +1,71 @@+{-|+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
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.Hspec+import Spec++main :: IO ()+main = hspec spec
+ test/Mellon/Web/ClientSpec.hs view
@@ -0,0 +1,85 @@+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)+import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)+import Network.Socket+import Network.Wai.Handler.Warp+import Servant.Client+import Test.Hspec++import Mellon.Web.Client+import Mellon.Web.Server (app)++sleep :: Int -> IO ()+sleep = threadDelay . (* 1000000)++openTestSocket :: IO (Port, Socket)+openTestSocket = do+ s <- socket AF_INET Stream defaultProtocol+ localhost <- inet_addr "127.0.0.1"+ bind s (SockAddrInet aNY_PORT localhost)+ listen s 1+ port <- socketPort s+ return (fromIntegral port, s)++runApp :: IO (ThreadId, Manager, BaseUrl)+runApp =+ do ml <- mockLock+ cc <- controller Nothing $ mockLockDevice ml+ (port, sock) <- openTestSocket+ let settings = setPort port $ defaultSettings+ threadId <- forkIO $ runSettingsSocket settings sock (app cc)+ manager <- newManager defaultManagerSettings+ return (threadId, manager, BaseUrl Http "localhost" port "")++killApp :: (ThreadId, Manager, BaseUrl) -> IO ()+killApp (threadId, _, _) = killThread threadId++spec :: Spec+spec = before runApp $ after killApp $+ do describe "getTime" $+ do it "returns the server time" $ \(_, manager, baseUrl) ->+ do now <- getCurrentTime+ Right (Time serverTime) <- runExceptT (getTime manager baseUrl)+ 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)+ 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+ state `shouldBe` Locked++ it "can unlock the server until a specified date" $ \(_, manager, baseUrl) ->+ do now <- getCurrentTime+ let untilTime = 3.0 `addUTCTime` now+ Right state <- runExceptT $ putState (Unlocked untilTime) manager baseUrl+ state `shouldBe` (Unlocked untilTime)+ sleep 3+ Right newState <- runExceptT (getState manager baseUrl)+ newState `shouldBe` Locked++ it "later unlocks override unlocks that expire earlier" $ \(_, manager, baseUrl) ->+ do now <- getCurrentTime+ let untilTime = 3.0 `addUTCTime` now+ _ <- runExceptT $ putState (Unlocked untilTime) manager baseUrl+ sleep 1+ let newUntilTime = 20.0 `addUTCTime` now+ Right state <- runExceptT $ putState (Unlocked newUntilTime) manager baseUrl+ state `shouldBe` Unlocked newUntilTime++ it "locks override unlocks" $ \(_, manager, baseUrl) ->+ do now <- getCurrentTime+ let untilTime = 3.0 `addUTCTime` now+ _ <- runExceptT $ putState (Unlocked untilTime) manager baseUrl+ sleep 1+ Right state <- runExceptT $ putState Locked manager baseUrl+ state `shouldBe` Locked
+ test/Mellon/Web/ServerSpec.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Mellon.Web.ServerSpec (spec) where++import Control.Concurrent (threadDelay)+import Data.Aeson (decode, encode)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB (ByteString)+import Data.Time.Clock+import Mellon.Controller (controller)+import Mellon.Device (mockLock, mockLockDevice)+import Network.HTTP.Types (hContentType, methodPut)+import Network.Wai+import Network.Wai.Test (SResponse, simpleBody)+import Test.Hspec+import Test.Hspec.Wai ((<:>), WaiSession, get, liftIO, matchHeaders, request, shouldRespondWith, with)++import Mellon.Web.Server (State(..), app, docsApp)++sleep :: Int -> IO ()+sleep = threadDelay . (* 1000000)++runApp :: IO Application+runApp =+ do ml <- mockLock+ cc <- controller Nothing $ mockLockDevice ml+ return (app cc)++runDocsApp :: IO Application+runDocsApp =+ do ml <- mockLock+ cc <- controller Nothing $ mockLockDevice ml+ return (docsApp 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 with runApp $+ do it "should be accurate" $+ do now <- liftIO getCurrentTime+ response <- get "/time"+ let Just (serverTime :: UTCTime) = decode $ simpleBody response+ let delta = 1.0 :: NominalDiffTime+ liftIO $ ((serverTime `diffUTCTime` now < delta)) `shouldBe` True++ describe "Initial server state" $+ do ml <- runIO $ mockLock+ cc <- runIO $ controller Nothing $ mockLockDevice ml+ now <- runIO $ getCurrentTime+ let untilTime = 30.0 `addUTCTime` now+ with (return $ app cc) $+ do it "should reflect the controller state" $+ do response <- get "/state"+ liftIO $ decode (simpleBody response) `shouldBe` Just Locked+ putJSON "/state" (encode $ Unlocked untilTime) `shouldRespondWith` 200+ with (return $ app cc) $+ do it "even when reusing the same controller in a new server" $+ do response <- get "/state"+ liftIO $ decode (simpleBody response) `shouldBe` Just (Unlocked untilTime)++ describe "Locking when locked" $+ do with runApp $+ do it "should be idempotent" $+ do response <- putJSON "/state" (encode Locked)+ liftIO $ decode (simpleBody response) `shouldBe` Just Locked++ describe "PUT /state" $+ do with runApp $+ do it "should return the new state when locked->unlocked" $+ do now <- liftIO getCurrentTime+ let untilTime = 10.0 `addUTCTime` now+ firstResponse <- putJSON "/state" (encode $ Unlocked untilTime)+ liftIO $ decode (simpleBody firstResponse) `shouldBe` Just (Unlocked untilTime)+ secondResponse <- get "/state"+ liftIO $ decode (simpleBody secondResponse) `shouldBe` Just (Unlocked untilTime)+ it "should return the new state when unlocked->locked" $+ do firstResponse <- putJSON "/state" (encode Locked)+ liftIO $ decode (simpleBody firstResponse) `shouldBe` Just Locked+ secondResponse <- get "/state"+ liftIO $ decode (simpleBody secondResponse) `shouldBe` Just Locked++ describe "Unlocking" $+ do with runApp $+ do it "expires at the specified date" $+ do now <- liftIO getCurrentTime+ let untilTime = 5.0 `addUTCTime` now+ firstResponse <- putJSON "/state" (encode $ Unlocked untilTime)+ liftIO $ decode (simpleBody firstResponse) `shouldBe` Just (Unlocked untilTime)+ liftIO $ sleep 2+ secondResponse <- get "/state"+ liftIO $ decode (simpleBody secondResponse) `shouldBe` Just (Unlocked untilTime)+ liftIO $ sleep 3+ thirdResponse <- get "/state"+ liftIO $ decode (simpleBody thirdResponse) `shouldBe` Just Locked+ with runApp $+ do it "overrides current unlocks that expire earlier" $+ do now <- liftIO getCurrentTime+ let untilTime = 3.0 `addUTCTime` now+ _ <- putJSON "/state" (encode $ Unlocked untilTime)+ liftIO $ sleep 1+ let laterUntilTime = 7.0 `addUTCTime` now+ firstResponse <- putJSON "/state" (encode $ Unlocked laterUntilTime)+ liftIO $ decode (simpleBody firstResponse) `shouldBe` Just (Unlocked laterUntilTime)+ liftIO $ sleep 9+ secondResponse <- get "/state"+ liftIO $ decode (simpleBody secondResponse) `shouldBe` Just Locked++ describe "Locking" $+ do with runApp $+ do it "overrides unlocks" $+ do now <- liftIO $ getCurrentTime+ let untilTime = 20.0 `addUTCTime` now+ _ <- putJSON "/state" (encode $ Unlocked untilTime)+ liftIO $ sleep 1+ 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"]}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/hlint.hs view
@@ -0,0 +1,12 @@+module Main where++import Control.Monad (unless)+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main =+ do args <- getArgs+ hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+ unless (null hints) exitFailure